(FILECREATED "15-Sep-86 16:01:39" {ERIS}<TAMARIN>WORK>SIMULATE>TACCESS.;26 11587
changes to: (RECORDS TFRAME)
(FNS TF.GETREGABS TF.SETREGABS)
(VARS TACCESSCOMS)
previous date: "12-Jun-86 17:26:38" {ERIS}<TAMARIN>WORK>SIMULATE>TACCESS.;25)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT TACCESSCOMS)
(RPAQQ TACCESSCOMS ((RECORDS TCELL TFUNHDR TMEMFRAME)
(FNS ARRAYBASEPTR TF.GETREG TF.GETREGABS TF.SETREG TF.SETREGABS TMF.GETREG TMF.GETREGABS
TMF.SETREG TMF.SETREGABS TS.MEMFETCH TS.MEMSTORE TMEM.GETMEM TMEM.SETMEM
TMEM.GETMEMOFFSET TMEM.SETMEMOFFSET TTOD DTOT TAMTYPEP TAMSUBTYPEP MAKETAMPTR)
(RECORDS TFNHDR)
(* tends to replace TFUNHDR)
(FNS TFNHDR.EVN)
(* for accessing entry vector cells)))
[DECLARE: EVAL@COMPILE
(ACCESSFNS TCELL ((TYP (LSH DATUM -30))
(SUBTYP (LOGAND (LSH DATUM -24)
63))
(FULLTYP (LOGAND (LSH DATUM -24)
255))
(INT (LOGAND DATUM 1073741823))
(PTR (LOGAND DATUM 16777215))))
(ACCESSFNS TFUNHDR ((HEAD.OF.HEADER DATUM)
(OVERHEADCELLS [LAMBDA NIL 8]))
(* * At the moment, none of these slots point to anything important in D-world. If they ever do, they'll need
smashing methods that mung reference counts correctly)
(BLOCKRECORD HEAD.OF.HEADER ((OBJECTHEADERTYPE BITS 32)
(OBJECTSIZE BITS 32)
(FUNCTIONNAME BITS 32)
(NTSIZE BITS 16)
(NLOCALS BITS 8)
(FVAROFFSET BITS 8)
(FLAGS BITS 8)
(MAXVAR BITS 8)
(USECOUNT BITS 8)
(SP BITS 8)
(PC BITS 32)
(NAMETABLE POINTER)
(CODEBASE POINTER))))
(ACCESSFNS TMEMFRAME ((OFFSETCELLS [LAMBDA NIL 10])
(TMEMWORDFRAMESIZE [LAMBDA NIL 44])
(TMEMFRAMEWORDOFFSET [LAMBDA NIL 4])
(NEXT (TMEM.GETMEMOFFSET DATUM (ITIMES TS.WORDINCR 3))
(TMEM.SETMEMOFFSET DATUM (ITIMES TS.WORDINCR 3)
NEWVALUE))
(* * The computation of the address in FLAGS&BYTES is a horrible hack which will go away as soon as CMLARRAYS
settles)
(FLAGS&BYTES (\ADDBASE (ARRAYBASEPTR TMEM)
(IPLUS (TTOD DATUM)
(ITIMES TS.WORDINCR 4))
1))
(PC (TMEM.GETMEMOFFSET DATUM (ITIMES TS.WORDINCR 5))
(TMEM.SETMEMOFFSET DATUM (ITIMES TS.WORDINCR 5)
NEWVALUE))
(NAMETABLE (TMEM.GETMEMOFFSET DATUM (ITIMES TS.WORDINCR 6))
(TMEM.SETMEMOFFSET DATUM (ITIMES TS.WORDINCR 6)
NEWVALUE))
(CODEBASE (TMEM.GETMEMOFFSET DATUM (ITIMES TS.WORDINCR 7))
(TMEM.SETMEMOFFSET DATUM (ITIMES TS.WORDINCR 7)
NEWVALUE))
(ALINK (TMEM.GETMEMOFFSET DATUM (ITIMES TS.WORDINCR 8))
(TMEM.SETMEMOFFSET DATUM (ITIMES TS.WORDINCR 8)
NEWVALUE))
(CLINK (TMEM.GETMEMOFFSET DATUM (ITIMES TS.WORDINCR 9))
(TMEM.SETMEMOFFSET DATUM (ITIMES TS.WORDINCR 9)
NEWVALUE)))
(BLOCKRECORD FLAGS&BYTES ((TRAP.ON.ENTRY.P FLAG)
(TRAP.ON.EXIT.P FLAG)
(LARGE.FRAME.P FLAG)
(FAST.FRAME.P FLAG)
(PAD.BITS BITS 4)
(MAXVAR BITS 8)
(USECOUNT BITS 8)
(SP BITS 8))))
]
(DEFINEQ
(ARRAYBASEPTR
[LAMBDA (ARRAY) (* jrb: "26-Feb-86 16:14")
(* * VERY dependent on current array structures. Fix this when CMLARRAYS comes out)
(\GETBASEPTR ARRAY 0])
(TF.GETREG
[LAMBDA (FRAME REGNO) (* jrb: "25-Feb-86 14:09")
(TF.GETREGABS FRAME (IPLUS (FETCH (TFRAME OVERHEADCELLS) OF T)
REGNO])
(TF.GETREGABS
[LAMBDA (FRAME REGNO) (* edited: "15-Sep-86 13:57")
(ELTX FRAME REGNO])
(TF.SETREG
[LAMBDA (FRAME REGNO NEWVAL) (* jrb: "25-Feb-86 14:10")
(TF.SETREGABS FRAME (IPLUS (fetch (TFRAME OVERHEADCELLS) of T)
REGNO)
NEWVAL])
(TF.SETREGABS
[LAMBDA (FRAME REGNO NEWVAL) (* edited: "15-Sep-86 13:57")
(SETA FRAME REGNO NEWVAL])
(TMF.GETREG
[LAMBDA (FRAME REGNO) (* edited: "14-Mar-86 17:51")
(TMF.GETREGABS FRAME (IPLUS (fetch (TMEMFRAME OFFSETCELLS) of T)
REGNO])
(TMF.GETREGABS
[LAMBDA (FRAME REGNO) (* edited: "11-Mar-86 10:16")
(if (TS.STACKP FRAME)
then (TMEM.GETMEMOFFSET FRAME (ITIMES REGNO TS.WORDINCR))
else (BREAK1 NIL T (Illegal Type in TMF.GETREGABS)
NIL])
(TMF.SETREG
[LAMBDA (FRAME REGNO NEWVAL) (* edited: "14-Mar-86 17:51")
(TMF.SETREGABS FRAME (IPLUS (FETCH (TMEMFRAME OFFSETCELLS) OF T)
REGNO)
NEWVAL])
(TMF.SETREGABS
[LAMBDA (FRAME REGNO NEWVAL) (* edited: "11-Mar-86 10:18")
(if (TS.STACKP FRAME)
then (TMEM.SETMEMOFFSET FRAME (ITIMES REGNO TS.WORDINCR)
NEWVAL)
else (BREAK1 NIL T (Illegal type in TMF.SEGREGABS)
NIL])
(TS.MEMFETCH
[LAMBDA (ADDR) (* rtk "25-Mar-86 11:07")
(* UNUSED TMEM.GETMEM ADDR)
])
(TS.MEMSTORE
[LAMBDA (ADDR NEWVAL) (* rtk "25-Mar-86 11:07")
(* UNUSED LET ((WADDR (LSH ADDR 1))) (IF (TAMSUBTYPEP (TS.MEMFETCH ADDR) TS.OBJECTP) THEN (\RPLPTR
(ARRAYBASEPTR TMEM) WADDR NIL)) (* * If the new value is a D-pointer it has to be stored with \RPLPTR
(which has to be fed NEWVAL as a pointer and not as an integer) otherwise use SETA) (IF (TAMSUBTYPEP NEWVAL
TS.OBJECTP) THEN (\RPLPTR (ARRAYBASEPTR TMEM) WADDR (\ADDBASE 0 (FETCH (TCELL PTR) OF NEWVAL))) ELSE
(TMEM.SETMEM ADDR NEWVAL)))
])
(TMEM.GETMEM
[LAMBDA (P) (* edited: "11-Mar-86 10:26")
(if (TS.POINTERP P)
then (if (EVENP (fetch (TCELL PTR) of P))
then (ELT TMEM (LRSH (fetch (TCELL PTR) of P)
TS.RADRSHIFT))
else (BREAK1 NIL T (Cannot access memory with odd pointer)
NIL))
else (BREAK1 NIL T (Cannot access memory without a pointer)
NIL])
(TMEM.SETMEM
[LAMBDA (P V) (* edited: "11-Mar-86 10:49")
(if (TS.POINTERP P)
then (if (EVENP (fetch (TCELL PTR) of P))
then (SETA TMEM (LRSH (fetch (TCELL PTR) of P)
TS.RADRSHIFT)
V)
else (BREAK1 NIL T (Cannot access memory with odd pointer)
NIL))
else (BREAK1 NIL T (Cannot access memory without a pointer)
NIL])
(TMEM.GETMEMOFFSET
[LAMBDA (P OFFSET) (* edited: "11-Mar-86 10:27")
(if (TS.POINTERP P)
then (if (AND (EVENP (fetch (TCELL PTR) of P))
(EVENP OFFSET))
then (TMEM.GETMEM (TS.NEWTPTR (fetch (TCELL SUBTYP) of P)
(IPLUS (fetch (TCELL PTR) of P)
OFFSET)))
else (BREAK1 NIL T (Cannot access odd addresses TMEM.GETMEMOFFSET)
NIL))
else (BREAK1 NIL T (Not a Pointer in TMEM.GETMEMOFFSET)
NIL])
(TMEM.SETMEMOFFSET
[LAMBDA (P OFFSET V) (* edited: "11-Mar-86 16:23")
(if (TS.POINTERP P)
then (if (AND (EVENP (fetch (TCELL PTR) of P))
(EVENP OFFSET))
then (TMEM.SETMEM (TS.NEWTPTR (fetch (TCELL SUBTYP) of P)
(IPLUS (fetch (TCELL PTR) of P)
OFFSET))
V)
else (BREAK1 NIL T (Cannot access odd addresses TMEM.SETMEMOFFSET)
NIL))
else (BREAK1 NIL T (Not a Pointer in TMEM.SETMEMOFFSET)
NIL])
(TTOD
[LAMBDA (THING) (* rtk " 4-Mar-86 09:24")
(* * Translates Tamarin world pointers into D-machine equivalents)
(SELECTC (fetch (TCELL TYP) of THING)
(TS.INTEGERTYP (RSH (LLSH THING 2)
2))
(TS.POINTERTYP (SELECTC (fetch (TCELL SUBTYP) of THING)
(TS.ATOMSUBTYP (if (EQP THING TS.NILCONST)
then NIL
elseif (EQP THING TS.TCONST)
then T
else (BREAK1 NIL T (Couldn't translate atom)
NIL)))
(TS.LISTSUBTYP (fetch (TCELL PTR) of THING))
(TS.STACKSUBTYP (fetch (TCELL PTR) of THING))
(TS.UNBOUNDSUBTYP (QUOTE UNBIND))
(BREAK1 NIL T (Couldn't translate random pointer)
NIL)))
(BREAK1 NIL T (Couldn't translate THING)
NIL])
(DTOT
[LAMBDA (X) (* rtk "27-Mar-86 17:12")
(* * Integers in the 30-bit Tamarin range are stored as T-integers; others are stored as D-bignums)
(COND
[(OR (SMALLP X)
(FIXP X))
(if (OR (GREATERP X TS.MAXINT)
(LESSP X TS.MININT))
then (TF.FORCEBIGNUM X)
else (LOGOR TS.INTEGERBITS (LOGAND X 1073741823]
((ATOM X)
(if (EQ X T)
then TS.TCONST
elseif (NULL X)
then TS.NILCONST
else (TF.NEWTATOM X)))
(T (BREAK1 NIL T (Couldn' t translate to Tamarin)
NIL])
(TAMTYPEP
[LAMBDA (THING TYPENO) (* rtk " 3-Mar-86 14:55")
(EQ (fetch (TCELL TYP) of THING)
TYPENO])
(TAMSUBTYPEP
[LAMBDA (THING SUBTYPENO) (* rtk " 3-Mar-86 14:11")
(AND (TAMTYPEP THING TS.POINTERTYP)
(EQ (fetch (TCELL SUBTYP) of THING)
SUBTYPENO])
(MAKETAMPTR
[LAMBDA (SUBTYPE ADDR) (* rtk " 6-Mar-86 16:18")
(* * MAKE A TAMARIN POINTER OF SUBTYPE GIVEN)
(LOGOR (LLSH SUBTYPE 24)
(LOGAND ADDR 16777215])
)
[DECLARE: EVAL@COMPILE
(ACCESSFNS TFNHDR ((HEAD.OF.HEADER DATUM)
(OVERHEADCELLS [LAMBDA NIL 8]))
(BLOCKRECORD HEAD.OF.HEADER ((OBJECTHEADERCELL BITS 32)
(OBJECTSIZE BITS 32)
(FRAMENAME POINTER)
(NTSIZE BITS 16)
(NLOCALS BITS 8)
(FVAROFFSET BITS 8)
(FLAGS BITS 8)
(MAXVAR BITS 8)
(USECOUNT BITS 8)
(SP BITS 8)
(PC BITS 32)
(NAMETABLE BITS 32)
(CODEBASE BITS 32))))
]
(* tends to replace TFUNHDR)
(DEFINEQ
(TFNHDR.EVN
[LAMBDA (baseAddress cellNr newValue) (* jmh "12-Jun-86 16:21")
(* * baseAddress is that of a D-machine array which is a TCODEP -- cellNr from 0 to 7 -- returns old value of
cellNr'th cell of entry-vector array of TCODEP <8 32-bit cells just following fn hdr proper> -- if newValue is
supplied, is smashed into the cell)
(LET* ((wordOffset (UNFOLD (PLUS (fetch (TFNHDR OVERHEADCELLS) of T)
cellNr)
WORDSPERCELL))
(oldValue (\GETBASEFIXP baseAddress wordOffset)))
(if newValue
then (\PUTBASEFIXP baseAddress wordOffset newValue))
oldValue])
)
(* for accessing entry vector cells)
(PUTPROPS TACCESS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3341 10234 (ARRAYBASEPTR 3351 . 3594) (TF.GETREG 3596 . 3800) (TF.GETREGABS 3802 . 3942
) (TF.SETREG 3944 . 4156) (TF.SETREGABS 4158 . 4305) (TMF.GETREG 4307 . 4512) (TMF.GETREGABS 4514 .
4798) (TMF.SETREG 4800 . 5020) (TMF.SETREGABS 5022 . 5321) (TS.MEMFETCH 5323 . 5530) (TS.MEMSTORE 5532
. 6133) (TMEM.GETMEM 6135 . 6577) (TMEM.SETMEM 6579 . 7029) (TMEM.GETMEMOFFSET 7031 . 7575) (
TMEM.SETMEMOFFSET 7577 . 8129) (TTOD 8131 . 9009) (DTOT 9011 . 9626) (TAMTYPEP 9628 . 9787) (
TAMSUBTYPEP 9789 . 10004) (MAKETAMPTR 10006 . 10232)) (10757 11464 (TFNHDR.EVN 10767 . 11462)))))
STOP