Apple-2gs-SW/ORCA-C
1
0
Fork 0
mirror of https://github.com/byteworksinc/ORCA-C.git synced 2025-02-06 04:30:13 +00:00
Code Issues Projects Releases Wiki Activity

Evaluate arithmetic and shifts in long long constant expressions.

Browse Source 
This winds up calling functions for these operations in ORCALib, so an up-to-date version of that must now be available to build the ORCA/C compiler.
This commit is contained in:
Stephen Heumann 2021-02-14 20:39:22 -06:00
parent 76cc4b9ca7
commit d66f6b27b7
3 changed files with 446 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
Exp.macros
View File

@ -162,3 +162,107 @@
LONGI OFF LONGI OFF
.I .I
MEND MEND
macro
&l ph8 &n1
lclc &c
&l anop
&c amid &n1,1,1
aif s:longa=1,.a
rep #%00100000
.a
aif "&c"="#",.d
aif "&c"="[",.b
aif "&c"<>"{",.c
&c amid &n1,l:&n1,1
aif "&c"<>"}",.g
&n1 amid &n1,2,l:&n1-2
&n1 setc (&n1)
.b
ldy #6
~&SYSCNT lda &n1,y
pha
dey
dey
bpl ~&SYSCNT
ago .e
.c
ldx #6
~&SYSCNT lda &n1,x
pha
dex
dex
bpl ~&SYSCNT
ago .e
.d
&n1 amid &n1,2,l:&n1-1
bra ~b&SYSCNT
~a&SYSCNT dc i8"&n1"
~b&SYSCNT ldx #6
~c&SYSCNT lda ~a&SYSCNT,x
pha
dex
dex
bpl ~c&SYSCNT
.e
aif s:longa=1,.f
sep #%00100000
.f
mexit
.g
mnote "Missing closing '}'",16
mend
macro
&l pl8 &n1
lclc &c
&l anop
aif s:longa=1,.a
rep #%00100000
.a
&c amid &n1,1,1
aif "&c"<>"{",.b
&c amid &n1,l:&n1,1
aif "&c"<>"}",.f
&n1 amid &n1,2,l:&n1-2
pla
sta (&n1)
ldy #2
pla
sta (&n1),y
ldy #4
pla
sta (&n1),y
ldy #6
pla
sta (&n1),y
ago .d
.b
aif "&c"<>"[",.c
pla
sta &n1
ldy #2
pla
sta &n1,y
ldy #4
pla
sta &n1,y
ldy #6
pla
sta &n1,y
ago .d
.c
pla
sta &n1
pla
sta &n1+2
pla
sta &n1+4
pla
sta &n1+6
.d
aif s:longa=1,.e
sep #%00100000
.e
mexit
.f
mnote "Missing closing '}'",16
mend

256
Expression.asm
View File

@ -382,3 +382,259 @@ ml6 ror a shift the answer
; ;
ml7 return 4:ans fix the stack ml7 return 4:ans fix the stack
end end
****************************************************************
*
* procedure umul64 (var x: longlong; y: longlong);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
umul64 start exp
subroutine (4:x,4:y),0
ph8 [x]
ph8 [y]
jsl ~UMUL8
pl8 [x]
return
end
****************************************************************
*
* procedure udiv64 (var x: longlong; y: longlong);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
udiv64 start exp
subroutine (4:x,4:y),0
ph8 [x]
ph8 [y]
jsl ~UDIV8
pl8 [x]
pla
pla
pla
pla
return
end
****************************************************************
*
* procedure div64 (var x: longlong; y: longlong);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
div64 start exp
subroutine (4:x,4:y),0
ph8 [x]
ph8 [y]
jsl ~CDIV8
pl8 [x]
pla
pla
pla
pla
return
end
****************************************************************
*
* procedure umod64 (var x: longlong; y: longlong);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
umod64 start exp
subroutine (4:x,4:y),0
ph8 [x]
ph8 [y]
jsl ~UDIV8
pla
pla
pla
pla
pl8 [x]
return
end
****************************************************************
*
* procedure rem64 (var x: longlong; y: longlong);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
rem64 start exp
subroutine (4:x,4:y),0
ph8 [x]
ph8 [y]
jsl ~CDIV8
pla
pla
pla
pla
pl8 [x]
return
end
****************************************************************
*
* procedure add64 (var x: longlong; y: longlong);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
add64 start exp
subroutine (4:x,4:y),0
ph8 [x]
ph8 [y]
jsl ~ADD8
pl8 [x]
return
end
****************************************************************
*
* procedure sub64 (var x: longlong; y: longlong);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
sub64 start exp
subroutine (4:x,4:y),0
ph8 [x]
ph8 [y]
jsl ~SUB8
pl8 [x]
return
end
****************************************************************
*
* procedure shl64 (var x: longlong; y: integer);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
shl64 start exp
subroutine (4:x,2:y),0
ph8 [x]
lda y
jsl ~SHL8
pl8 [x]
return
end
****************************************************************
*
* procedure ashr64 (var x: longlong; y: integer);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
ashr64 start exp
subroutine (4:x,2:y),0
ph8 [x]
lda y
jsl ~ASHR8
pl8 [x]
return
end
****************************************************************
*
* procedure lshr64 (var x: longlong; y: integer);
*
* Inputs:
* x,y - operands
*
* Outputs:
* x - result
*
****************************************************************
*
lshr64 start exp
subroutine (4:x,2:y),0
ph8 [x]
lda y
jsl ~LSHR8
pl8 [x]
return
end

111
Expression.pas
View File

@ -269,6 +269,29 @@ function umod (x,y: longint): longint; extern;
function umul (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern;
{-- External 64-bit math routines ------------------------------}
{ Procedures for arithmetic and shifts compute "x := x OP y". }
procedure umul64 (var x: longlong; y: longlong); extern;
procedure udiv64 (var x: longlong; y: longlong); extern;
procedure div64 (var x: longlong; y: longlong); extern;
procedure umod64 (var x: longlong; y: longlong); extern;
procedure rem64 (var x: longlong; y: longlong); extern;
procedure add64 (var x: longlong; y: longlong); extern;
procedure sub64 (var x: longlong; y: longlong); extern;
procedure shl64 (var x: longlong; y: integer); extern;
procedure ashr64 (var x: longlong; y: integer); extern;
procedure lshr64 (var x: longlong; y: integer); extern;
{---------------------------------------------------------------} {---------------------------------------------------------------}
function Unary(tp: baseTypeEnum): baseTypeEnum; function Unary(tp: baseTypeEnum): baseTypeEnum;
@ -1247,18 +1270,23 @@ var
else else
ekind := longlongconst; ekind := longlongconst;
unsigned := ekind = ulonglongconst;
GetLongLongVal(llop1, op^.left^.token); GetLongLongVal(llop1, op^.left^.token);
GetLongLongVal(llop2, op^.right^.token); GetLongLongVal(llop2, op^.right^.token);
case op^.token.kind of case op^.token.kind of
barbarop : begin {||} barbarop : begin {||}
op1 := ord((llop1.lo <> 0) or (llop1.hi <> 0) or llop1.hi := 0;
(llop2.lo <> 0) or (llop2.hi <> 0)); llop1.lo :=
ord((llop1.lo <> 0) or (llop1.hi <> 0) or
(llop2.lo <> 0) or (llop2.hi <> 0));
ekind := intconst; ekind := intconst;
end; end;
andandop : begin {&&} andandop : begin {&&}
op1 := ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and llop1.hi := 0;
((llop2.lo <> 0) or (llop2.hi <> 0))); llop1.lo :=
ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and
((llop2.lo <> 0) or (llop2.hi <> 0)));
ekind := intconst; ekind := intconst;
end; end;
carotch : begin {^} carotch : begin {^}
@ -1274,34 +1302,63 @@ var
llop1.hi := llop1.hi & llop2.hi; llop1.hi := llop1.hi & llop2.hi;
end; end;
eqeqop : begin {==} eqeqop : begin {==}
op1 := ord((llop1.lo = llop2.lo) and llop1.hi := 0;
(llop1.hi = llop2.hi)); llop1.lo := ord((llop1.lo = llop2.lo) and
(llop1.hi = llop2.hi));
ekind := intconst; ekind := intconst;
end; end;
exceqop : begin {!=} exceqop : begin {!=}
op1 := ord((llop1.lo <> llop2.lo) or llop1.hi := 0;
(llop1.hi <> llop2.hi)); llop1.lo := ord((llop1.lo <> llop2.lo) or
(llop1.hi <> llop2.hi));
ekind := intconst; ekind := intconst;
end; end;
ltch, {<} ltch, {<}
gtch, {>} gtch, {>}
lteqop, {<=} lteqop, {<=}
gteqop, {>=} gteqop : begin {>=}
ltltop, {<<} if kind in [normalExpression,autoInitializerExpression]
gtgtop, {>>} then goto 1;
plusch, {+} Error(157);
minusch, {-} llop1 := longlong0;
asteriskch, {*} op1 := 0;
slashch, {/} if op^.token.kind in [ltch,gtch,lteqop,gteqop] then
percentch: begin {%} ekind := intconst;
if kind in [normalExpression,autoInitializerExpression] end;
then goto 1; ltltop : begin {<<}
Error(157); shl64(llop1, long(llop2.lo).lsw);
llop1 := longlong0; ekind := kindLeft;
op1 := 0; end;
if op^.token.kind in [ltch,gtch,lteqop,gteqop] then gtgtop : begin {>>}
ekind := intconst; if kindleft = ulonglongconst then
end; lshr64(llop1, long(llop2.lo).lsw)
else
ashr64(llop1, long(llop2.lo).lsw);
ekind := kindLeft;
end;
plusch : add64(llop1, llop2); {+}
minusch : sub64(llop1, llop2); {-}
asteriskch : umul64(llop1, llop2); {*}
slashch : begin {/}
if (llop2.lo = 0) and (llop2.hi = 0) then begin
Error(109);
llop2 := longlong1;
end; {if}
if unsigned then
udiv64(llop1, llop2)
else
div64(llop1, llop2);
end;
percentch : begin {%}
if (llop2.lo = 0) and (llop2.hi = 0) then begin
Error(109);
llop2 := longlong1;
end; {if}
if unsigned then
umod64(llop1, llop2)
else
rem64(llop1, llop2);
end;
otherwise: Error(57); otherwise: Error(57);
end; {case} end; {case}
@ -1314,8 +1371,12 @@ var
op^.token.qval := llop1; op^.token.qval := llop1;
op^.token.class := longlongConstant; op^.token.class := longlongConstant;
end {if} end {if}
else if ekind in [longconst,ulongconst] then begin
op^.token.lval := llop1.lo;
op^.token.class := longConstant;
end {if}
else begin else begin
op^.token.ival := long(op1).lsw; op^.token.ival := long(llop1.lo).lsw;
op^.token.class := intConstant; op^.token.class := intConstant;
end; {else} end; {else}
goto 1; goto 1;