!PRIM + PERM file for Motorola 68000 IMP Compiler V2.0
!After compilation -NOCHECK-NOLINE-MAP-LIST,
! the MEX file together with the LIS file are used by PRIMGEN
! to modify the const arrays in the body of the compiler.  
!     *** The comment { followed by | is used to flag identifiers
!         which are to be known to the compiler.
!         The case (lower or upper) of the basic identifier is
!         preserved -- which is a way of hiding those that should
!         not be accessible to the user.
!         The form |@ is used to flag a PRIM routine (code here)
!         if it does not otherwise need to be known.
!     *** NB PRIM routines cannot reference other PRIM routines ***
!     ***    nor external or system routines                    ***
!     *   signal entered by jump with user program PC last thing
!         on stack
!         Minor point: RTS (rather than signal) usually put at end
!         to help interpretation of dis-assembly
{| NULL                @
{| PROCSTAR            @
{| INTTYPE             integer
{| @                   MAXINT
{| SHORTTYPE           shortinteger
{| HALFTYPE            halfinteger
{| BYTETYPE            byteinteger
{| MITETYPE            miteinteger
{| BOOLTYPE            BOOLEAN
{| CHARTYPE            char
{| STRINGSTAR          string
{| STRING1             @
{| STRINGTYPE          @
{| ARRSTAR             array
{| NULLSETTYPE         @
{| RECSTAR             record
{| @                   TEXT
{| REALTYPE            real
!
@16_3F00-6 %routine {|}   SIGNAL
!
@0%integer%fn {|DADDR}  addr(%name n)
@0%integer%fn {|DSIZEOF}sizeof(%name n)

%routine {|}           INDEX
!Array index.
!A0 points at [UB,LB,Size], D0 is index
!Check in range; subtract LB; scale by Size.
%label hi,ok,bigel,bigx,big
%conststring(21) mess="Array bounds exceeded"
  *cmp (a0)+,d0; *bgt hi;  !index > UB ->
  *sub (a0)+,d0; *bge ok;  !index >= LB ->
  *add -(a0),d0;           !restore index
hi:
  *lea mess,a0;  *move d0,d2;  *move #2,d1;  *move #16_76,d0
  *jmp signal
!  %signal 6,2,d0,"Array bounds exceeded"
ok:
  *tst.w (a0)+; *bne bigel;  !element size >= 64k ->
  *swap d0
  *tst.w d0; *bne bigx;      !adjusted index >= 64k ->
  *swap d0
  *mulu (a0)+,d0
  *rts
bigel:                       !(index can't also be big)
  *move d1,-(sp)
  *move d0,d1
  *mulu -2(a0),d1
  *bra big
bigx:
  *move d1,-(sp)
  *move d0,d1
  *swap d0
  *mulu (a0),d1
big:
  *swap d1
  *mulu (a0)+,d0
  *add d1,d0
  *move (sp)+,d1
%end

@0%bytemap {|LENREF}         length(%string(*)%name z)
@0%bytemap {|SINDEX}         charno(%string(*)%name z, %integer n)

@16_3F00-12 %routine {|}        IMUL
@16_3F00-18 %routine {|}        IDIV
@16_3F00-30 %routine {|}        IPOW
@16_3F00-36 %routine {|}        FNEG
@16_3F00-42 %routine {|}        FADD
@16_3F00-48 %routine {|}        FSUB
@16_3F00-54 %routine {|}        FMUL
@16_3F00-60 %routine {|}        FDIV
@16_3F00-66 %routine {|}        FPOW
@16_3F00-72 %real%fn {|}        float(%integer a)
@0 %integer%fn {|DREM}        rem(%integer a,b)

%routine {|}                 UNASS
!Unassigned test.
! The CMP is done before calling (call sequence does not alter CC)
%label ok
%conststring mess="Unassigned variable"
  *bne ok
  *lea mess,a0; *move #1,d1; *move #16_58,d0
  *jmp signal
!  %signal 4,2,,"Unassigned variable"
ok:
%end

%routine {|}                  ADOK
!Address test (not NIL or unassigned)
! The CMP is done before calling (call sequence does not alter CC)
%label ok
%conststring mess="Invalid address"
  *bgt ok
  *lea mess,a0; *move #1,d1; *move #16_58,d0
  *jmp signal
!  %signal 4,2,,"Invalid address"
ok:
%end

%routine {|}                  STACKOK
!Check that stack can be extended by -D4 bytes
! (but do not alter SP)
! ** then reset D4 (byte reg) **
%label ok
%conststring mess="Stack space exhausted"
  *add a7,d4; *cmp d6,d4; *bge ok
  *clr d4
  *lea mess,a0; *move #3,d1; *move #16_55,d0
  *jmp signal
ok:*clr d4
%end

%routine {|}            ASIZE
!(%integer element size, lower bound, upper bound)
!Preliminary to claiming array space
!result = EL*(UB-LB+1)
%label ok
%conststring mess="Array bounds inside out"
  *sub d2,d1
  *ble ok
  *lea mess,a0; *move #3,d1; *move #16_55,d0
  *jmp signal
!  %signal 5,3,,"Array bounds inside out"
ok:*neg d1
  *addq #1,d1
  *jmp imul;                   !=> multiply
%end

%routine {|}         CONCAT
!(%string(*)%name s,t,%integer maxlen)
!Concatenate S to T
%label bad,ok,done
%conststring mess="String too big"
  *move.b (a1),d4;     !length(dest)
  *sub.b d4,d0
  *bcs bad
  *sub.b (a0),d0;      !length(source)
  *bcc ok
bad:
  *lea mess,a0; *move #3,d1; *move #16_51,d0
  *jmp signal
! %signal 1,3,,"String too long"
ok:
  *move.b (a0)+,d0
  *beq done
  *add.b d0,(a1)
loop:
  *move.b (a0)+,1(a1,d4)
  *add.b #1,d4
  *sub.b #1,d0
  *bne loop
done:
  *move a1,a0
%end

%string(1)%fn {|DTOSTRING}   tostring(%integer k)
!Used only for awkward contexts; others compiled in-line
  *move.w d0,-(sp)
  *move #1,d0; *move.b d0,(sp)
  *move sp,a0
  *add #2,sp
!%string(1) s
!  charno(s,1) = k;  length(s) = 1
!  %result = s
%end

%routine {|}                  AGET
!Claim space for array from stack
!D0=size (checked > 0: see ASIZE)
!A7:=address of array, A0 also used
%label ok,bad,loop1,loop,count
%conststring mess="No space for array"
  *addq #3,d0;  *asr #2,d0;  *lsl #2,d0;  !make multiple of 4 bytes
  *blt bad;                               ![safety]
  *move a7,a0; *sub d0,a0;                !new SP (actually 4 less)
  *cmp d6,a0; *bge ok
bad:
  *move d0,d2
  *lea mess,a0; *move #1,d1; *move #16_72,d0
  *jmp signal
!  %signal 2,1,,"No space for array"
ok:
  *move (a7)+,a0;                          !return address
  *lsr #2,d0
  *bra count
loop1:
  *swap d0
loop:
  *move d7,-(a7);           !un-assign
count:
  *dbra d0,loop; *swap d0; *dbra d0,loop1
  *jmp (a0)
%end

%routine {|}                  FOROK
!%for loop check
!D0=start-inc, D1=inc, D2=final (unchanged)
! Check D2-D0 / D1 is integral and non-neg
%label ok1,ok2,no
%conststring mess="Invalid %for loop"
  *move d0,-(sp)
  *sub d2,d0; *beq ok2;          !always ok if D0=D2 (even if D1=0)
  *move d1,-(sp); *beq no
  *jsr idiv;                      ![no error possible(?)]
  *tst d0; *blt ok1;             !going in right direction
no:
  *add #8,sp
  *lea mess,a0; *move #1,d1; *move #16_55,d0
  *jmp signal
! %signal 5,1,,"Invalid for loop"
ok1:*tst d1; *bne no;              !must hit spot on
  *move (sp)+,d1
ok2:*move (sp)+,d0
%end

%routine {|}                  CHECK
! Out-of-range error report
%conststring mess="Out of range"
  *lea mess,a0; *move #1,d1; *move #16_56,d0
  *jmp signal
%end

%routine {|}                  SCOMP
! String comparison
! Performs unassigned check, then compares strings A,B
! [Test for straight =,# compiled in-line when no unass check]
! A0=#A, A1=#B, D7=unassigned-pattern
! CC:= X,V,N:undefined, Z:set iff A=B,  C:set iff A<B
! D0-D7,A0-A7: unchanged
%label Bless,Bshort,Anull,done,unass,ok1,ok
%conststring mess="Unassigned variable"
  *cmp.w #0,a0; *ble unass
  *cmp.w #0,a1; *ble unass
  *cmp.b (a0),d7; *bne ok1
  *cmp.b 1(a0),d7; *beq unass
ok1:
  *cmp.b (a1),d7; *bne ok
  *cmp.b 1(a1),d7; *bne ok
unass:
  *lea mess,a0; *move #2,d1; *move #16_54,d0
  *jmp signal
!  %signal 4,2,,"Unassigned variable"
ok:
  *movem d0-d1/a0-a1,-(sp)
  *clr.w d0
  *move.b (a0)+,d0      {length(A)
  *beq Anull
  *clr.w d1
  *move.b (a1)+,d1      {length(B)
  *beq Bless            {(B="")<(A#"") ->
  *subq #1,d0
  *subq #1,d1
  *cmp.w d1,d0
  *bgt Bshort           {length(B) < length(A) ->
  *sub.w d0,d1          {d1 = length(B)-length(A) >= 0
  *cmpm (a1)+,(a0)+
  *dbne d0,#-4
  *bne done
  *neg.w d1
done:*movem (sp)+,d0-d1/a0-a1
  *rts
Bshort:*cmpm (a1)+,(a0)+
  *dbne d1,Bshort
  *bne done
Bless:*moveq #1,d1       {A>B
  *movem (sp)+,d0-d1/a0-a1
  *rts
Anull:*move.b (a1),d0
  *neg.w d0                 {B#"" means A<B (otherwise A=B)
  *movem (sp)+,d0-d1/a0-a1
%end

%routine {|}             STRCOPY
! (%string(*)%name source,dest, %integer maxlen)
%label ok
%conststring mess="String too big"
  *cmp.b (a0),d0;     !actual length v max
  *bcc ok
  *lea mess,a0; *move #3,d1; *move #16_51,d0
  *jmp signal
!  %signal 1,3,,"String too big"
ok:
  *clr d0;  *move.b (a0),d0
  *move.b (a0)+,(a1)+
  *dbra d0,#-4
%end

%routine {|}                  STRTOSTK
! (%string(*)%name s)
!Push string onto stack, occupying D0 bytes
! uses A1,A2,(D4) as well
![assume stack check done externally]
%label reverse,ok
%conststring mess="String too big"
  *cmp.b (a0),d0;     !actual length v max
  *bcc ok
  *lea mess,a0; *move #1,d1; *move #16_56,d0
  *jmp signal
!  %signal 6,1,,"String too big"
ok:
  *and.w #16_FE,d0
  *move (sp)+,a2;                   !remove RETAD
  *sub.w d0,a7;  *sub #2,a7
  *move a7,a1
  *cmp a0,a7;                       !choose method (in case overlap)
  *bgt reverse
  *move.b (a0),d0
  *move.b (a0)+,(a1)+
  *dbra d0,#-4
  *move a7,a0; *move a7,a1
  *jmp (a2)
reverse:
  *move.b (a0)+,d0; *add #1,a1
  *add.w d0,a0;  *add.w d0,a1
  *move.b -(a0),-(a1)
  *dbra d0,#-4
  *move a7,a0; *move a7,a1
  *jmp (a2)
%end

@16_3F00-120 %volatile%record(*)%map {|DNEW} new(%name v)

%systempredicatespec {|}    resolves(%c
  %string(*)%name source,%string(255) s,%string(*)%name fore,aft)

%string(255)%fn {|@}         substring(%string(*)%name s, %integer from,to)
%label ok
  *lea -256(sp),a1
  *move a0,a2; *add d0,a2
  *move a1,a0;   !result
  *sub d0,d1
  *bge ok
  *clr.b (a1)
  *rts
ok:*move.b d1,(a1); *add.b #1,(a1)+
  *move.b (a2)+,(a1)+
  *dbra d1,#-4
!%string(255) t
!  t = ""
!  %while from <= to %cycle
!    t = t.tostring(charno(s,from));  from = from+1
!  %repeat
!  %result = t
%end

%recordformat {|DEVENTF}     eventfm(%c
  %byte {|@}                 event,sub, %short line,
  %integer                   extra,
  %string(255)               message)
@32(a5)%record(eventfm) {|DEVENT} event

%constinteger                 nl=10
%constchar                    snl=char<10>
@0%record(*) {|DNIL}          nil

@16_3F00-126 %routine         dispose(%name v)
@16_3F00-78 %integer%fn       round(%real x)
@16_3F00-84 %integer%fn       trunc(%real x)
@16_3F00-90 %real%fn          fraction(%real x)
@16_3F00-96 %integer%fn       int(%real x)
@16_3F00-102 %integer%fn      intpt(%real x)
@16_3F00-108 %real%fn         fracpt(%real x)
@16_3F00-114 %real%fn         sqrt(%real x)

@16_3F00-132 %integer%fn      nextsymbol
@16_3F00-138 %integer%fn      readsymbol
@16_3F00-138 %routine         skipsymbol
@16_3F00-144 %routine         printsymbol(%integer k)
@16_3F00-150 %routine {|DPRINTSTR} printstring(%string(255) z)
!!@16_3F00-156 %routine         openinput(%integer stream,%string(255)name)
!!@16_3F00-162 %routine         openoutput(%integer stream,%string(255)name)
%external%routine%spec        openinput(%integer stream,%string(255)name)
%external%routine%spec        openoutput(%integer stream,%string(255)name)
@16_3F00-168 %routine         selectinput(%integer stream)
@16_3F00-174 %routine         selectoutput(%integer stream)
%external%routine%spec        setinput(%integer position)
%external%routine%spec        setoutput(%integer position)
%external%routine%spec        resetinput
%external%routine%spec        resetoutput
@16_3F00-192 %routine         closeinput
@16_3F00-198 %routine         closeoutput
%external%routine%spec        prompt(%string(255) s)
%routine {|@}                 newline
  *move #nl,d0; *jmp printsymbol
%end
%routine {|@}                 space
  *move #' ',d0; *jmp printsymbol
%end
%system%routine%spec          spaces(%integer i)
%system%routine%spec          newlines(%integer i)
%system%volatile%string(255)%fn%spec   read %alias "readstring"
%system%volatile%real%fn%spec%alias    read %alias "readreal"
%system%volatile%integer%fn%spec%alias read
%system%routine%spec {|DWRITE}write(%integer m, n)
%external%volatile%integer%fn%spec       cputime
%system%routine%spec          print(%real x, %integer n,m)
%system%routine%spec          printfl(%real x, %integer n)
@392(a5) %integer             instream,outstream
@464(a5) %string(255)         cliparam
%control 16