From d66f6b27b76dff20858d24258d728a807d1fe798 Mon Sep 17 00:00:00 2001 From: Stephen Heumann Date: Sun, 14 Feb 2021 20:39:22 -0600 Subject: [PATCH] Evaluate arithmetic and shifts in long long constant expressions. 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. --- Exp.macros | 104 ++++++++++++++++++++ Expression.asm | 256 +++++++++++++++++++++++++++++++++++++++++++++++++ Expression.pas | 111 ++++++++++++++++----- 3 files changed, 446 insertions(+), 25 deletions(-) diff --git a/Exp.macros b/Exp.macros index 8d451b7..5b97682 100644 --- a/Exp.macros +++ b/Exp.macros @@ -162,3 +162,107 @@ LONGI OFF .I 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 diff --git a/Expression.asm b/Expression.asm index 378ff8d..db8fd2b 100644 --- a/Expression.asm +++ b/Expression.asm @@ -382,3 +382,259 @@ ml6 ror a shift the answer ; ml7 return 4:ans fix the stack 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 diff --git a/Expression.pas b/Expression.pas index 8090004..a0cd7fa 100644 --- a/Expression.pas +++ b/Expression.pas @@ -269,6 +269,29 @@ function umod (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; @@ -1247,18 +1270,23 @@ var else ekind := longlongconst; + unsigned := ekind = ulonglongconst; GetLongLongVal(llop1, op^.left^.token); GetLongLongVal(llop2, op^.right^.token); case op^.token.kind of barbarop : begin {||} - op1 := ord((llop1.lo <> 0) or (llop1.hi <> 0) or - (llop2.lo <> 0) or (llop2.hi <> 0)); + llop1.hi := 0; + llop1.lo := + ord((llop1.lo <> 0) or (llop1.hi <> 0) or + (llop2.lo <> 0) or (llop2.hi <> 0)); ekind := intconst; end; andandop : begin {&&} - op1 := ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and - ((llop2.lo <> 0) or (llop2.hi <> 0))); + llop1.hi := 0; + llop1.lo := + ord(((llop1.lo <> 0) or (llop1.hi <> 0)) and + ((llop2.lo <> 0) or (llop2.hi <> 0))); ekind := intconst; end; carotch : begin {^} @@ -1274,34 +1302,63 @@ var llop1.hi := llop1.hi & llop2.hi; end; eqeqop : begin {==} - op1 := ord((llop1.lo = llop2.lo) and - (llop1.hi = llop2.hi)); + llop1.hi := 0; + llop1.lo := ord((llop1.lo = llop2.lo) and + (llop1.hi = llop2.hi)); ekind := intconst; end; exceqop : begin {!=} - op1 := ord((llop1.lo <> llop2.lo) or - (llop1.hi <> llop2.hi)); + llop1.hi := 0; + llop1.lo := ord((llop1.lo <> llop2.lo) or + (llop1.hi <> llop2.hi)); ekind := intconst; end; ltch, {<} gtch, {>} lteqop, {<=} - gteqop, {>=} - ltltop, {<<} - gtgtop, {>>} - plusch, {+} - minusch, {-} - asteriskch, {*} - slashch, {/} - percentch: begin {%} - if kind in [normalExpression,autoInitializerExpression] - then goto 1; - Error(157); - llop1 := longlong0; - op1 := 0; - if op^.token.kind in [ltch,gtch,lteqop,gteqop] then - ekind := intconst; - end; + gteqop : begin {>=} + if kind in [normalExpression,autoInitializerExpression] + then goto 1; + Error(157); + llop1 := longlong0; + op1 := 0; + if op^.token.kind in [ltch,gtch,lteqop,gteqop] then + ekind := intconst; + end; + ltltop : begin {<<} + shl64(llop1, long(llop2.lo).lsw); + ekind := kindLeft; + end; + gtgtop : begin {>>} + if kindleft = ulonglongconst then + 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); end; {case} @@ -1314,8 +1371,12 @@ var op^.token.qval := llop1; op^.token.class := longlongConstant; end {if} + else if ekind in [longconst,ulongconst] then begin + op^.token.lval := llop1.lo; + op^.token.class := longConstant; + end {if} else begin - op^.token.ival := long(op1).lsw; + op^.token.ival := long(llop1.lo).lsw; op^.token.class := intConstant; end; {else} goto 1;