mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-11 21:29:42 +02:00
qlunits: updated QDOS unit, added a QLfloat unit to convert longints and doubles to 48bit QLfloats, added a rotating cube example
git-svn-id: trunk@47456 -
This commit is contained in:
Károly Balogh
parent
6f59167c64
commit
84e1be805c
2
.gitattributes
vendored
2
.gitattributes
vendored
@ -8721,8 +8721,10 @@ packages/pxlib/src/pxlib.pp svneol=native#text/plain
|
|||||||
packages/qlunits/Makefile svneol=native#text/plain
|
packages/qlunits/Makefile svneol=native#text/plain
|
||||||
packages/qlunits/Makefile.fpc svneol=native#text/plain
|
packages/qlunits/Makefile.fpc svneol=native#text/plain
|
||||||
packages/qlunits/README.txt svneol=native#text/plain
|
packages/qlunits/README.txt svneol=native#text/plain
|
||||||
|
packages/qlunits/examples/qlcube.pas svneol=native#text/plain
|
||||||
packages/qlunits/fpmake.pp svneol=native#text/plain
|
packages/qlunits/fpmake.pp svneol=native#text/plain
|
||||||
packages/qlunits/src/qdos.pas svneol=native#text/plain
|
packages/qlunits/src/qdos.pas svneol=native#text/plain
|
||||||
|
packages/qlunits/src/qlfloat.pas svneol=native#text/plain
|
||||||
packages/regexpr/Makefile svneol=native#text/plain
|
packages/regexpr/Makefile svneol=native#text/plain
|
||||||
packages/regexpr/Makefile.fpc svneol=native#text/plain
|
packages/regexpr/Makefile.fpc svneol=native#text/plain
|
||||||
packages/regexpr/Makefile.fpc.fpcmake svneol=native#text/plain
|
packages/regexpr/Makefile.fpc.fpcmake svneol=native#text/plain
|
||||||
|
|||||||
209
packages/qlunits/examples/qlcube.pas
Normal file
209
packages/qlunits/examples/qlcube.pas
Normal file
@ -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.
|
||||||
@ -29,9 +29,10 @@ begin
|
|||||||
P.OSes:=[sinclairql];
|
P.OSes:=[sinclairql];
|
||||||
|
|
||||||
T:=P.Targets.AddUnit('qdos.pas');
|
T:=P.Targets.AddUnit('qdos.pas');
|
||||||
|
T:=P.Targets.AddUnit('qlfloat.pas');
|
||||||
|
|
||||||
// P.ExamplePath.Add('examples');
|
P.ExamplePath.Add('examples');
|
||||||
// T:=P.Targets.AddExampleProgram('.pas');
|
T:=P.Targets.AddExampleProgram('qlcube.pas');
|
||||||
|
|
||||||
{$ifndef ALLPACKAGES}
|
{$ifndef ALLPACKAGES}
|
||||||
Run;
|
Run;
|
||||||
|
|||||||
@ -44,20 +44,155 @@ const
|
|||||||
ERR_EX = -17; { Expression error. }
|
ERR_EX = -17; { Expression error. }
|
||||||
ERR_OV = -18; { Arithmetic overflow. }
|
ERR_OV = -18; { Arithmetic overflow. }
|
||||||
ERR_NI = -19; { Not implemented. }
|
ERR_NI = -19; { Not implemented. }
|
||||||
ERR_RO = -20; { Read only. }
|
ERR_RO = -20; { Read only. }
|
||||||
ERR_BL = -21; { Bad line of Basic. }
|
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
|
{ 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) }
|
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';
|
function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; external name '_mt_alchp';
|
||||||
procedure mt_rechp(area: pointer); external name '_mt_rechp';
|
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_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 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
|
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.
|
end.
|
||||||
|
|||||||
182
packages/qlunits/src/qlfloat.pas
Normal file
182
packages/qlunits/src/qlfloat.pas
Normal file
@ -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.
|
||||||
Loading…
Reference in New Issue
Block a user