mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-18 05:00:07 +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.fpc 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/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.fpc 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];
|
||||
|
||||
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;
|
||||
|
||||
@ -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.
|
||||
|
||||
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