!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
!
@0integer fn {|DADDR} addr(name n)
@0integer 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
@0bytemap {|LENREF} length(string (*)name z)
@0bytemap {|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>
@0record (*) {|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