qlunits: updated QDOS unit, added a QLfloat unit to convert longints and doubles to 48bit QLfloats, added a rotating cube example

git-svn-id: https://svn.freepascal.org/svn/fpc/trunk@47456 3ad0048d-3df7-0310-abae-a5850022a9f2

4 files changed, 530 insertions, 3 deletions

diff --git a/packages/qlunits/examples/qlcube.pas b/packages/qlunits/examples/qlcube.pas
new file mode 100644
index 0000000000..caacb5ccac
--- /dev/null
+++ b/packages/qlunits/examples/qlcube.pas
@@ -0,0 +1,209 @@
+{
+    Copyright (c) 2017-2020 Karoly Balogh
+
+    Rotating 3D cube on a Sinclair QL
+    Example program for Free Pascal's Sinclair QL support
+
+    This example program is in the Public Domain under the terms of
+    Unlicense: http://unlicense.org/
+
+ **********************************************************************}
+
+program qlcube;
+
+uses
+  qdos, qlfloat;
+
+type
+  tvertex = record
+    x: longint;
+    y: longint;
+    z: longint;
+  end;
+
+const
+  cube: array[0..7] of tvertex = (
+     ( x: -1; y: -1; z: -1; ), // 0
+     ( x:  1; y: -1; z: -1; ), // 1
+     ( x:  1; y:  1; z: -1; ), // 2
+     ( x: -1; y:  1; z: -1; ), // 3
+
+     ( x: -1; y: -1; z:  1; ), // 4
+     ( x:  1; y: -1; z:  1; ), // 5
+     ( x:  1; y:  1; z:  1; ), // 6
+     ( x: -1; y:  1; z:  1; )  // 7
+  );
+
+type
+  tface = record
+    v1, v2, v3: longint;
+    edge: longint;
+  end;
+
+const
+  sincos_table: array[0..255] of longint = (
+         0,  1608,  3216,  4821,  6424,  8022,  9616, 11204,
+     12785, 14359, 15924, 17479, 19024, 20557, 22078, 23586,
+     25079, 26557, 28020, 29465, 30893, 32302, 33692, 35061,
+     36409, 37736, 39039, 40319, 41575, 42806, 44011, 45189,
+     46340, 47464, 48558, 49624, 50659, 51664, 52638, 53580,
+     54490, 55367, 56211, 57021, 57797, 58537, 59243, 59913,
+     60546, 61144, 61704, 62227, 62713, 63161, 63571, 63943,
+     64276, 64570, 64826, 65042, 65219, 65357, 65456, 65515,
+     65535, 65515, 65456, 65357, 65219, 65042, 64826, 64570,
+     64276, 63943, 63571, 63161, 62713, 62227, 61704, 61144,
+     60546, 59913, 59243, 58537, 57797, 57021, 56211, 55367,
+     54490, 53580, 52638, 51664, 50659, 49624, 48558, 47464,
+     46340, 45189, 44011, 42806, 41575, 40319, 39039, 37736,
+     36409, 35061, 33692, 32302, 30893, 29465, 28020, 26557,
+     25079, 23586, 22078, 20557, 19024, 17479, 15924, 14359,
+     12785, 11204,  9616,  8022,  6424,  4821,  3216,  1608,
+         0, -1608, -3216, -4821, -6424, -8022, -9616,-11204,
+    -12785,-14359,-15924,-17479,-19024,-20557,-22078,-23586,
+    -25079,-26557,-28020,-29465,-30893,-32302,-33692,-35061,
+    -36409,-37736,-39039,-40319,-41575,-42806,-44011,-45189,
+    -46340,-47464,-48558,-49624,-50659,-51664,-52638,-53580,
+    -54490,-55367,-56211,-57021,-57797,-58537,-59243,-59913,
+    -60546,-61144,-61704,-62227,-62713,-63161,-63571,-63943,
+    -64276,-64570,-64826,-65042,-65219,-65357,-65456,-65515,
+    -65535,-65515,-65456,-65357,-65219,-65042,-64826,-64570,
+    -64276,-63943,-63571,-63161,-62713,-62227,-61704,-61144,
+    -60546,-59913,-59243,-58537,-57797,-57021,-56211,-55367,
+    -54490,-53580,-52638,-51664,-50659,-49624,-48558,-47464,
+    -46340,-45189,-44011,-42806,-41575,-40319,-39039,-37736,
+    -36409,-35061,-33692,-32302,-30893,-29465,-28020,-26557,
+    -25079,-23586,-22078,-20557,-19024,-17479,-15924,-14359,
+    -12785,-11204, -9616, -8022, -6424, -4821, -3216, -1608
+  );
+
+function sin(x: longint): longint; inline;
+begin
+  sin:=sincos_table[x and 255];
+end;
+
+function cos(x: longint): longint; inline;
+begin
+  cos:=sincos_table[(x + 64) and 255];
+end;
+
+function mulfp(a, b: longint): longint; inline;
+begin
+  mulfp:=sarint64((int64(a) * b),16);
+end;
+
+function divfp(a, b: longint): longint;
+begin
+  divfp:=(int64(a) shl 16) div b;
+end;
+
+procedure rotate_vertex(const v: tvertex; var vr: tvertex; xa, ya, za: longint);
+var
+  x,y,z: longint;
+  s,c: longint;
+begin
+  s   :=sin(ya);
+  c   :=cos(ya);
+  x   :=mulfp(c,v.x) - mulfp(s,v.z);
+  z   :=mulfp(s,v.x) + mulfp(c,v.z);
+  if za <> 0 then
+    begin
+      vr.x:=mulfp(cos(za),x)   + mulfp(sin(za),v.y);
+      y   :=mulfp(cos(za),v.y) - mulfp(sin(za),x);
+    end
+  else
+    begin
+      vr.x:=x;
+      y:=v.y;
+    end;
+  vr.z:=mulfp(cos(xa),z)   - mulfp(sin(xa),y);
+  vr.y:=mulfp(sin(xa),z)   + mulfp(cos(xa),y);
+end;
+
+procedure perspective_vertex(const v: tvertex; zc: longint; var xr,yr: longint);
+var
+  rzc: longint;
+begin
+  rzc:=divfp(1 shl 16,(v.z - zc));
+  xr:=mulfp(mulfp(v.x,zc),rzc);
+  yr:=mulfp(mulfp(v.y,zc),rzc);
+end;
+
+procedure init_cube;
+var
+  i: longint;
+begin
+  for i:=low(cube) to high(cube) do
+    begin
+      cube[i].x:=cube[i].x shl 16;
+      cube[i].y:=cube[i].y shl 16;
+      cube[i].z:=cube[i].z shl 16;
+    end;
+end;
+
+
+var
+  mx, my: smallint;
+
+function min(a, b: smallint): smallint;
+begin
+  if a < b then
+    min:=a
+  else
+    min:=b;
+end;
+
+procedure draw_line(x1,y1,x2,y2: smallint);
+begin
+  sd_line(QCON,-1,x1,y1,x2,y2);
+end;
+
+procedure cube_redraw;
+var
+  i,s,e,cx,cy,vx,vy: longint;
+  vr: tvertex;
+  scale: longint;
+  rect:TQLRect;
+  fcubex: array[low(cube)..high(cube)] of Tqlfloat;
+  fcubey: array[low(cube)..high(cube)] of Tqlfloat;
+begin
+  rect.q_x:=0;
+  rect.q_y:=0;
+  rect.q_width:=140;
+  rect.q_height:=100;
+
+  scale:=(min(rect.q_width,rect.q_height) div 6) shl 16;
+  cx:=rect.q_x + rect.q_width div 2;
+  cy:=rect.q_y + rect.q_height div 2;
+  for i:=low(cube) to high(cube) do
+    begin
+      rotate_vertex(cube[i],vr,-my,-mx,0);
+      perspective_vertex(vr,3 shl 16,vx,vy);
+      longint_to_qlfp(@fcubex[i],cx + sarlongint(mulfp(vx,scale),16));
+      longint_to_qlfp(@fcubey[i],cy + sarlongint(mulfp(vy,scale),16));
+    end;
+
+  sd_clear(QCON,-1);
+  for i:=0 to 3 do 
+    begin
+      e:=(i+1) and 3;
+      sd_line(QCON,-1,@fcubex[i],@fcubey[i],@fcubex[e],@fcubey[e]);
+      s:=i+4; e:=e+4;
+      sd_line(QCON,-1,@fcubex[s],@fcubey[s],@fcubex[e],@fcubey[e]);
+      sd_line(QCON,-1,@fcubex[i],@fcubey[i],@fcubex[s],@fcubey[s]);
+    end;
+end;
+
+procedure main_loop;
+begin
+  repeat
+    inc(mx,5);
+    inc(my,7);
+    cube_redraw;
+  until false;
+end;
+
+begin
+  init_cube;
+
+  main_loop;
+end.
diff --git a/packages/qlunits/fpmake.pp b/packages/qlunits/fpmake.pp
index dbc0987121..57d2889ea9 100644
--- a/packages/qlunits/fpmake.pp
+++ b/packages/qlunits/fpmake.pp
@@ -29,9 +29,10 @@ begin
     P.OSes:=[sinclairql];
 
     T:=P.Targets.AddUnit('qdos.pas');
+    T:=P.Targets.AddUnit('qlfloat.pas');
 
-//    P.ExamplePath.Add('examples');
-//    T:=P.Targets.AddExampleProgram('.pas');
+    P.ExamplePath.Add('examples');
+    T:=P.Targets.AddExampleProgram('qlcube.pas');
 
 {$ifndef ALLPACKAGES}
     Run;
diff --git a/packages/qlunits/src/qdos.pas b/packages/qlunits/src/qdos.pas
index b8b023d4ba..c2677c88cb 100644
--- a/packages/qlunits/src/qdos.pas
+++ b/packages/qlunits/src/qdos.pas
@@ -44,20 +44,155 @@ const
   ERR_EX = -17;  { Expression error. }
   ERR_OV = -18;  { Arithmetic overflow. }
   ERR_NI = -19;  { Not implemented. }
-  ERR_RO = -20;	 { Read only. }
+  ERR_RO = -20;  { Read only. }
   ERR_BL = -21;  { Bad line of Basic. }
 
+const
+  Q_OPEN = 0;
+  Q_OPEN_IN = 1;
+  Q_OPEN_NEW = 2;
+  Q_OPEN_OVER = 3;  { Not available on microdrives. }
+  Q_OPEN_DIR = 4;
+
+type
+  Tqlfloat = array[0..5] of byte;
+  Pqlfloat = ^Tqlfloat;
+
+type
+  TQLRect = record
+    q_width : word;
+    q_height : word;
+    q_x : word;
+    q_y : word;
+  end;
+  PQLRect = ^TQLRect;
+
+type
+  TWindowDef = record
+    border_colour : byte;
+    border_width : byte;
+    paper : byte;
+    ink : byte;
+    width : word;
+    height : word;
+    x_origin: word;
+    y_origin: word;
+  end;
+  PWindowDef = ^TWindowDef;
+
 
 { the functions declared as external here are implemented in the system unit. They're included
   here via externals, do avoid double implementation of assembler wrappers (KB) }
 
+function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; external name '_mt_inf';
+
+procedure mt_dmode(s_mode: pword; d_type: pword); external name '_mt_dmode';
+
 function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; external name '_mt_alchp';
 procedure mt_rechp(area: pointer); external name '_mt_rechp';
 
+function io_open_qlstr(name_qlstr: pointer; mode: longint): Tchanid; external name '_io_open_qlstr';
+function io_open(name: pchar; mode: longint): Tchanid; external name '_io_open';
+function io_close(chan: Tchanid): longint; external name '_io_close';
+
 function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
 function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; external name '_io_sstrg';
 
+function sd_wdef(chan: Tchanid; timeout: Ttimeout; border_colour: byte; border_width: word; window: PQLRect): longint; external name '_sd_wdef'; 
+function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; external name '_sd_clear';
+
+function ut_con(params: PWindowDef): Tchanid; external name '_ut_con';
+function ut_scr(params: PWindowDef): Tchanid; external name '_ut_scr';
+
+
+procedure sd_point(chan: Tchanid; timeout: Ttimeout; x: Pqlfloat; y: Pqlfloat);
+procedure sd_point(chan: Tchanid; timeout: Ttimeout; x: double; y: double);
+
+procedure sd_line(chan: Tchanid; timeout: Ttimeout; x_start: Pqlfloat; y_start: Pqlfloat; x_end: Pqlfloat; y_end: Pqlfloat);
+procedure sd_line(chan: Tchanid; timeout: Ttimeout; x_start: double; y_start: double; x_end: double; y_end: double);
+
 
 implementation
 
+uses
+  qlfloat;
+
+const
+  _SD_POINT = $30;
+  _SD_LINE = $31;
+
+procedure sd_point(chan: Tchanid; timeout: Ttimeout; x: Pqlfloat; y: Pqlfloat);
+var
+  stack: array[0..1] of TQLFloat;
+begin
+  stack[1]:=x^;
+  stack[0]:=y^;
+  asm
+    move.l d3,-(sp)
+    move.w timeout,d3
+    move.l chan,a0
+    lea.l stack,a1
+    moveq.l #_SD_POINT,d0
+    trap #3
+    move.l (sp)+,d3
+  end;
+end;
+
+procedure sd_point(chan: Tchanid; timeout: Ttimeout; x: double; y: double);
+var
+  stack: array[0..1] of TQLFloat;
+begin
+  double_to_qlfp(@stack[1],@x);
+  double_to_qlfp(@stack[0],@y);
+  asm
+    move.l d3,-(sp)
+    move.w timeout,d3
+    move.l chan,a0
+    lea.l stack,a1
+    moveq.l #_SD_POINT,d0
+    trap #3
+    move.l (sp)+,d3
+  end;
+end;
+
+
+procedure sd_line(chan: Tchanid; timeout: Ttimeout; x_start: Pqlfloat; y_start: Pqlfloat; x_end: Pqlfloat; y_end: Pqlfloat);
+var
+  stack: array[0..3] of TQLFloat;
+begin
+  stack[3]:=x_start^;
+  stack[2]:=y_start^;
+  stack[1]:=x_end^;
+  stack[0]:=y_end^;
+  asm
+    move.l d3,-(sp)
+    move.w timeout,d3
+    move.l chan,a0
+    lea.l stack,a1
+    moveq.l #_SD_LINE,d0
+    trap #3
+    move.l (sp)+,d3
+  end;
+end;
+
+procedure sd_line(chan: Tchanid; timeout: Ttimeout; x_start: double; y_start: double; x_end: double; y_end: double);
+var
+  stack: array[0..3] of TQLFloat;
+begin
+  double_to_qlfp(@stack[3],@x_start);
+  double_to_qlfp(@stack[2],@y_start);
+  double_to_qlfp(@stack[1],@x_end);
+  double_to_qlfp(@stack[0],@y_end);
+  asm
+    move.l d3,-(sp)
+    move.w timeout,d3
+    move.l chan,a0
+    lea.l stack,a1
+    moveq.l #_SD_LINE,d0
+    trap #3
+    move.l (sp)+,d3
+  end;
+end;
+
+
 end.
diff --git a/packages/qlunits/src/qlfloat.pas b/packages/qlunits/src/qlfloat.pas
new file mode 100644
index 0000000000..d96a523d6e
--- /dev/null
+++ b/packages/qlunits/src/qlfloat.pas
@@ -0,0 +1,182 @@
+{
+    Conversion code from various number formats to QL Float format.
+
+    Code ported from the C68/QL-GCC libc implementation available at:
+    http://morloch.hd.free.fr/qdos/qdosgcc.html
+
+    The QL wiki claims the original of these sources are by
+    Dave Walker, and they are in the Public Domain.
+    https://qlwiki.qlforum.co.uk/doku.php?id=qlwiki:c68
+
+ **********************************************************************}
+unit qlfloat;
+
+interface
+
+uses
+  qdos;
+
+function longint_to_qlfp(qlf: Pqlfloat; val: longint): Pqlfloat;
+function double_to_qlfp(qlf: Pqlfloat; val: Pdouble): Pqlfloat;
+
+
+implementation
+
+function longint_to_qlfp(qlf: Pqlfloat; val: longint): Pqlfloat; assembler; nostackframe;
+asm
+  { pointer to qlfloat is in a0 }
+  { val is in d0 }
+
+  movem.l d2-d4/a0,-(sp)  { save register variables and a0 }
+  moveq.l #0,d2           { sign value }
+  move.l  d2,d3           { shift value }
+  tst.l   d0              { zero or -ve ? }
+  beq     @zeroval        { zero }
+  bpl     @plusval        { +ve }
+
+{ i is negative here. set the sign value then make i positive }
+
+  moveq   #1,d2           { boolean to say -ve }
+  not.l   d0              { i has all bits reversed }
+  bne     @plusval        { i was not -1, so can continue }
+
+{ i was -1, so cannot go into following loop, as it now is zero }
+
+  moveq   #0,d2           { pretend i was positive }
+  move.l  #$80000000,d1   { set d1 correctly }
+  move.w  #31,d3          { shift value }
+  bra     @outloop        { continue }
+
+@plusval:
+  move.l  d0,d1           { save a copy of the original i }
+
+{ check for shortcuts with shifts }
+
+  and.l   #$ffffff00,d0   { shift by 23 ? }
+  bne     @bigger23       { no cheat available }
+  move.w  #23,d3          { shift value is 23 }
+  lsl.l   d3,d1           { shift copy of i }
+  bra     @nbigger        { continue }
+
+{ check for 15 bit shortcut shift }
+
+@bigger23:
+  move.l  d1,d0           { restore i }
+  and.l   #$ffff0000,d0   { shift by 15 ? }
+  bne     @nbigger        { no cheat available }
+  move.w  #15,d3          { shift value is 15 }
+  lsl.l   d3,d1           { shift copy of i }
+
+{ no shortcuts available }
+
+@nbigger:
+  move.l  d1,d0           { restore i }
+  and.l   #$40000000,d0   { if(!(i & 0x40000000)) }
+  bne     @outloop        { bit is set, no more shifts }
+  lsl.l   #1,d1           { shift copy of i }
+  addq.l  #1,d3           { increment shift count }
+  bra     @nbigger        { ensures i is restored }
+
+{ finished shifts - copy into qlfloat }
+{ correct shifted i is in d1, d0 contains i & 0x40000000 }
+
+@outloop:
+  move.w  #$81f,d4
+  sub.w   d3,d4           { set exponent correctly }
+  move.w  d4,(a0)+        { copy into exponent }
+
+{ difference here between positive and negative numbers
+; negative should just be shifted until first zero, so as we
+; have 2s complemented and shifted until first one, we must now
+; re-complement what is left }
+
+  tst.b   d2
+  beq     @setmant        { positive value here - just copy it }
+
+{ negative value, xor it with -1 shifted by same amount as in shift (d3)
+; to convert it back to -ve representation }
+
+  moveq.l #-1,d2          { set d2 to all $FFs }
+  lsl.l   d3,d2           { shift it by shift (d3 ) }
+  eor.l   d2,d1           { not the value by xoring }
+
+{ negative value restored by above }
+
+@setmant:
+  move.l  d1,(a0)         { copy into mantissa }
+@fin:
+  movem.l (sp)+,d2-d4/a0  { reset register variables and return value }
+  rts
+
+{ quick exit if zero }
+
+@zeroval:
+  move.w  d2,(a0)+        { zero exponent }
+  move.l  d2,(a0)         { zero mantissa }
+  bra     @fin
+end;
+
+
+function double_to_qlfp(qlf: Pqlfloat; val: Pdouble): Pqlfloat; assembler; nostackframe;
+asm
+{----------------------------- IEEE -----------------------------------
+; routine to convert IEEE double precision (8 byte) floating point
+; to a QLFLOAT_t.
+}
+  { pointer to qlfloat is in a0 }
+  move.l  (a1),d0        { high long of IEEE double }
+
+{ SNG - avoid loading low part for now so we can treat D1 as temporary }
+
+  add.l   d0,d0          { Put sign bit in carry }
+  lsr.l   #1,d0          { put zero where sign was }
+  bne     @notzero       { not zero }
+  move.l  4(a1),d1       { Test low bits too (probably zero!) }
+  bne     @notzero
+
+{ here the double was a signed zero - set the QLFLOAT_t and return }
+
+  move.w  d1,(a0)+       { We know that D1 is 0 at this point }
+  bra     @positive
+
+{ was not zero - do manipulations }
+
+@notzero:
+  move.l  d0,d1          { set non-signed high part copy }
+{                          We are going to lose least significant byte so we
+;                          can afford to over-write it.  We can thus take
+;                          advantage that the shift size when specified in
+;                          a register is modulo 64 }
+  move.b  #20,d0         { shift amount for exponent }
+  lsr.l   d0,d0          { get exponent - tricky but it works! }
+  add.w   #$402,d0       { adjust to QLFLOAT_t exponent }
+  move.w  d0,(a0)+       { set QLFLOAT_t exponent }
+
+{ now deal with mantissa }
+
+  and.l   #$fffff,d1     { get top 20 mantissa bits }
+  or.l    #$100000,d1    { add implied bit }
+  moveq   #10,d0         { shift amount ;; save another 2 code bytes }
+  lsl.l   d0,d1          { shift top 21 bits into place }
+
+  move.l  4(a1),d0       { get less significant bits }
+
+{                          We are going to lose least significant byte so we
+;                          can afford to over-write it.  We can thus take
+;                          advantage that the shift size when specified in
+;                          a register is modulo 64 }
+  move.b  #22,d0         { amount to shift down low long: not MOVEQ! }
+  lsr.l   d0,d0          { position low 10 bits of mantissa }
+  or.l    d0,d1          { D1 now positive mantissa }
+
+@lowzer:
+  tst.b   (a1)           { Top byte of IEEE argument }
+  bpl     @positive      { No need to negate if positive }
+  neg.l   d1             { Mantissa in D1 now }
+@positive:
+  move.l  d1,(a0)        { put mantissa in QLFLOAT_t }
+  subq.l  #2,a0          { correct for return address }
+  move.l  a0,d0          { set return value as original QLFLOAT_t address }
+end;
+
+end.