(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "12-Nov-87 16:53:19" {PHYLUM}<CTAMARIN>EMULATOR>OPCODEASSEMBLER.\;26 45461
|changes| |to:| (FNS |DoOp| |UfnBase| |MakeList| |OperandVal| |AddAtom| |ListEval|
|LoadOperand| |MakePConst| |AddFn| |AssembleOps| |AssembleOps.1|
|InitClink| |IFExpr|)
(VARS OPCODEASSEMBLERCOMS)
|previous| |date:| " 4-Nov-87 12:39:29" {PHYLUM}<CTAMARIN>EMULATOR>OPCODEASSEMBLER.\;20)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT OPCODEASSEMBLERCOMS)
(RPAQQ OPCODEASSEMBLERCOMS ((* * |Special| |Opcode| |Assembler|)
(FNS |AssembleOps| |AssembleOps.1| |AddItem| |AddList| |EvalBytes|
|ClearMemoryArray| |UProp| |AddressAdjust|)
(* |;;;| "Special Opcode Entry List Handelers")
(FNS |ListEval| |ValList| |LoadOperand| |BytesToList| |ExpandList|)
(* |;;;| "Spicialized Operations Returning Code Stream Lists")
(FNS |DoOp| |UfnEntry| |UfnBase| |InitClink| |MakePConst| |AddFn|
|JumpNewPage| |IFExpr|)
(* |;;;| "Specialized Operations")
(FNS |MakeList| |OperandVal| |MakeClosure|)
(FNS |AddAtom| |ReadAtom| |AtomIndex|)
(FNS |AddFnHeader| |NextFnAddr| |AddMemFrame| |AddVmTable|)
(FNS |FreeMemIndexBump|)
(* |;;;| "Old Code ")
(FNS |AddCode| |LoadFnHdr| |LinkCode| |AddUfns|)))
(* * |Special| |Opcode| |Assembler|)
(DEFINEQ
(|AssembleOps|
(LAMBDA (|oplist| |clearFirst?|) (* \; "Edited 9-Nov-87 17:38 by Krivacic")
(* * |note-| |it| |is| |assumed| |that| |no-one| |messes| |with| |FreeMemIndex|
|except| |during| |AssembleOps| -- |it| |is| |also| |assumed| |that| |if| |you|
|ask| |for| |the| |clearFirst?| |that| |you| |will| |set| |up| |FreeMemIndex|
|in| |the| |Tamarin,| |e.g.| |via| |tamSetUp|)
(DECLARE (GLOBALVARS |start| *JUMP-TO-PAGE-LIST* *LIST-CONSTANTS* *OPCODE-LABELS*))
(SETQ *JUMP-TO-PAGE-LIST* NIL)
(SETQ *OPCODE-LABELS* NIL)
(SETQ *LIST-CONSTANTS* NIL)
(LET (|opl|)
(SETQ |start| 0)
(|if| (OR |clearFirst?| (NOT (BOUNDP '|FreeMemIndex|))
(NOT |FreeMemIndex|))
|then| (|ClearMemoryArray|) (* |AddVmTable|)
|else| (SETQ |FreeMemIndex| (|ReadAtom| '|FreeMemIndex| '|val| T)))
(AND |oplist| (SETQ |CurrentOpList| (APPEND |oplist|)))
(SETQ |opl| |CurrentOpList|)
(|AssembleOps.1| |opl|)
(|AddAtom| '|FreeMemIndex| |FreeMemIndex|))))
(|AssembleOps.1|
(LAMBDA (|opl|) (* \; "Edited 9-Nov-87 17:40 by Krivacic")
(DECLARE (GLOBALVARS |start| |StartFreeMemIndex| *OPCODE-LABELS*))
(PROG (\x |bumpcount|)
(|while| |opl| |do| (SETQ |bumpcount| 1)
(|if| (GREATERP |start| |StartFreeMemIndex|)
|then| (PRINTOUT T "Memory Overflow Into Atom Space" T)
(HELP))
(COND
((EQ '@ (CAR |opl|))
(SETQ |start| (TIMES 4 (EVAL (CADR |opl|))))
(SETQ |bumpcount| 0)
(SETQ |opl| (CDR |opl|)))
((EQ '* (CAR |opl|))
(SETQ \x (EVALV (CADR |opl|)))
(|if| (LISTP \x)
|then| (SETQ |opl| (APPEND (LIST '\x)
(EVALV (CADR |opl|))
(CDDR |opl|)))
|else| (SETQ |opl| (CONS '\x (CONS \x (CDDR |opl|)))))
(SETQ |bumpcount| 0))
((NUMBERP (CAR |opl|))
(|StoreTamByte| |start| (CAR |opl|)))
((LISTP (CAR |opl|))
(SETQ |bumpcount| 0)
(SETQ \x (|ListEval| (CAR |opl|)))
(|if| (LISTP \x)
|then| (SETQ |opl| (APPEND (LIST '\x)
\x
(CDR |opl|)))
|elseif| \x
|then| (SETQ |opl| (CONS '\x (CONS \x (CDR |opl|))))))
((SETQ \x (GETPROP (CAR |opl|)
'|TamarinOp|))
(|StoreTamByte| |start| \x))
((NULL (CAR |opl|))
(SETQ |bumpcount| 0))
((EQ (CAR |opl|)
'LABEL)
(SETQ *OPCODE-LABELS* (CONS (LIST (CADR |opl|)
|start|)
*OPCODE-LABELS*)))
(T (PRINTOUT T "Unknown Op: " (PRINT (CAR |opl|)))))
(SETQ |opl| (CDR |opl|))
(|if| (NEQ (|ConcatBits| '(((|Eval| |start|)
10 22 10)))
(|ConcatBits| '(((|Eval| (PLUS |start| |bumpcount|))
10 22 10))))
|then| (PRINTOUT T "Cannot Have Code Cross a Page Bountry" T)
(|Emulator-Error| "Cannot Have Code Cross a Page Bountry"))
(SETQ |start| (PLUS |start| |bumpcount|))))))
(|AddItem|
(LAMBDA (|item|) (* |rtk| "12-May-86 17:36")
(|if| |item|
|then| (|if| (NUMBERP |item|)
|then| (|TamRep| |item|)
|elseif| (LISTP |item|)
|then| (|AddList| |item|)
|elseif| (LITATOM |item|)
|then| (|AddAtom| |item|)
|else| (BREAK1 NIL T (|AddItem| |Error|)
NIL))
|else| (|TamRep| 'NIL))))
(|AddList|
(LAMBDA (|list|) (* \; "Edited 21-Oct-87 18:09 by Krivacic")
(* |;;| "Adds a List into Tamarin Memory, Returning A Pointer to it")
(|if| |list|
|then| (|if| (LISTP |list|)
|then| (PROG ((|Index| |FreeMemIndex|))
(SETQ |FreeMemIndex| (IPLUS |FreeMemIndex| 2))
(|MemoryAccess| |Index| (|AddItem| (CAR |list|)))
(|MemoryAccess| (ADD1 |Index|)
(|AddItem| (CDR |list|)))
(RETURN (|TamRep| '|List| |Index|)))
|else| (|AddItem| |list|))
|else| (|TamRep| 'NIL))))
(|EvalBytes|
(LAMBDA (|bytes| |expr|) (* |agb:| "14-Aug-86 15:11")
(PROG (|word| (|wstart| (QUOTIENT (PLUS |start| 3)
4))
(|val| (EVAL |expr|)))
(|if| (EQ |bytes| 0)
|then| (RETURN NIL))
(|if| (GREATERP |bytes| 0)
|then| (RETURN (|for| \i |from| 1 |to| |bytes|
|collect| (LOGAND 255 (RSH |val| (TIMES (IDIFFERENCE \i 1)
8)))))
|else| (|if| (NEQ (ABS |bytes|)
(LOGAND (ABS |bytes|)
60))
|then| (BREAK1 NIL T (|Need| |Even| |Word| |offset|)
NIL))
(SETQ |val| (|for| \i |from| (ABS |bytes|) |to| 1 |by| -1
|collect| (LOGAND 255 (RSH |val| (TIMES (IDIFFERENCE \i 1)
8)))))
(|while| |val| |do| (|MemoryAccess| |wstart| (IPLUS (LSH (CAR |val|)
24)
(LSH (CADR |val|)
16)
(LSH (CADDR |val|)
8)
(CADDDR |val|)))
(SETQ |wstart| (ADD1 |wstart|))
(SETQ |start| (TIMES |wstart| 4))
(SETQ |val| (CDDDDR |val|)))
(RETURN NIL)))))
(|ClearMemoryArray|
(LAMBDA NIL (* \; "Edited 29-Oct-87 18:51 by Krivacic")
(SETQ |lastwrd| 0)
(|for| \i |from| 0 |to| (SUB1 (MIN 4000 (ARRAYSIZE |MemoryArray|)))
|do| (SETA |MemoryArray| \i 0)
(SETA |MemoryTagArray| \i 0))
(|if| (BOUNDP '|AtomHashArray|)
|then| (CLRHASH |AtomHashArray|)
|else| (SETQ |AtomHashArray| (HARRAY 512)))
(SETQ |FreeMemIndex| 4194816)
(SETQ |FreeMemIndex| 16384)
(SETQ |StartFreeMemIndex| (TIMES |FreeMemIndex| 4))
(|AddAtom| '|FreeMemIndex| |FreeMemIndex|)))
(|UProp|
(LAMBDA (|field| |symbol|) (* \; "Edited 16-Oct-87 11:58 by Krivacic")
(CADR (FASSOC |field| (GETPROP |symbol| '|uField|)))))
(|AddressAdjust|
(LAMBDA (|address| |modsize|) (* \; "Edited 23-Oct-87 17:26 by Krivacic")
(TIMES (QUOTIENT (PLUS |address| (SUB1 |modsize|))
|modsize|)
|modsize|)))
)
(* |;;;| "Special Opcode Entry List Handelers")
(DEFINEQ
(|ListEval|
(LAMBDA (|listoperand|) (* \; "Edited 10-Nov-87 15:22 by Krivacic")
(* |;;| "Return Value(s) of what should be inserted into the code stream")
(LET (\x)
(SELECTQ (CAR |listoperand|)
(|IFExpr| (|IFExpr| (CDR |listoperand|)))
(QUOTE (|MakePConst| (|MakeList| (CADR |listoperand|))))
(NO-CHECK NIL)
(* NIL)
(|if| (SETQ \x (GETPROP (CAR |listoperand|)
'|TamarinOp|))
|then| (|DoOp| (CAR |listoperand|)
\x
(GETPROP (CAR |listoperand|)
'|TamarinOpLength|)
(CDR |listoperand|))
|else| (EVAL |listoperand|))))))
(|ValList|
(LAMBDA (|val| |bytes|) (* \; "Edited 21-Oct-87 16:59 by Krivacic")
(* LOGAND 255 (RSH |val|
(TIMES (IDIFFERENCE \i 1) 8)))
(|for| \i |from| 0 |to| (SUB1 |bytes|) |collect| (|ConcatBits| '((|val| 0 8 (TIMES \i 8)))))))
(|LoadOperand|
(LAMBDA (|operand|) (* \; "Edited 10-Nov-87 15:22 by Krivacic")
(* |;;| "Return Code to Load the Operand")
(|if| (NUMBERP |operand|)
|then|
(* |;;| "Code to Load Numbers")
(|if| (GREATERP 0 |operand|)
|then| (SETQ |operand| (|ConcatBits| '((|operand| 0 32 0)))))
(COND
((EQ |operand| 0)
(LIST '\'0))
((EQ |operand| 1)
(LIST '\'1))
((AND (GREATERP 256 |operand|)
(GEQ |operand| 0))
(LIST 'SICX |operand|))
((AND (GREATERP 65535 |operand|)
(GEQ |operand| 0))
(CONS 'SICXX (|ValList| |operand| 2)))
(T (CONS (SELECTQ (|GetTamTag| |operand|)
(0 'ICONST)
(1 'FCONST)
(2 'PCONST1)
'PCONST2)
(|ValList| |operand| 4))))
|elseif| (LITATOM |operand|)
|then|
(* |;;| "Code to Load Symbols")
(COND
((EQ |operand| 'T)
(LIST '\'T))
((EQ |operand| 'NIL)
(LIST '\'NIL))
((EQ |operand| '|Unbound|)
(LIST '\'UNBOUND))
((SETQ \x (GETPROP |operand| '|TamarinOp|))
(LIST |operand|))
(T (|MakePConst| (|AddAtom| |operand|))))
|elseif| (LISTP |operand|)
|then| (LET ((|val| (|ListEval| |operand|)))
(|if| (NULL (LISTP |val|))
|then| (SETQ |val| (|MakePConst| |val|)))
|val|)
|else| (|Emulator-Error| "Cannot Parse Operand"))))
(|BytesToList|
(LAMBDA (|bytes| |maxbytes|) (* \; "Edited 22-Oct-87 17:59 by Krivacic")
(|for| \i |in| '(0 8 16 24) |as| |cnt| |from| 1 |to| (OR |maxbytes| 4)
|collect| (|ConcatBits| '((|bytes| 0 8 \i))))))
(|ExpandList|
(LAMBDA (|list| |size|) (* \; "Edited 22-Oct-87 11:54 by Krivacic")
(|if| (GREATERP |size| (LENGTH |list|))
|then| (LET ((|elements| (ARRAY |size| 'POINTER NIL 1)))
(|for| |element| |in| |list| |as| \i |from| 1 |do| (SETA |elements| \i |element|)
)
(SETA |elements| |size| (ELT |elements| (LENGTH |list|)))
(|for| \i |from| (LENGTH |list|) |to| (SUB1 |size|)
|do| (SETA |elements| \i NIL))
(|for| \i |from| 1 |to| |size| |collect| (ELT |elements| \i)))
|else| |list|)))
)
(* |;;;| "Spicialized Operations Returning Code Stream Lists")
(DEFINEQ
(|DoOp|
(LAMBDA (|name| |opnumber| |oplength| |operands|) (* \; "Edited 11-Nov-87 15:41 by Krivacic")
(LET
(|liststart| |operand-list| (|posK| (STRPOS 'K |name|))
(|operand1| (AND (LISTP |operands|)
(CAR |operands|)))
(|isjump| (FMEMB |name| '(JUMPX TJUMPX↑ FJUMPX↑ N↑TJUMPX N↑FJUMPX JUMPXX FJUMPK↑ TJUMPK↑
JUMPK))))
(|if| (AND |isjump| (NOT (NUMBERP |operand1|)))
|then| (SETQ |operand-list| (|for| |item| |in| |operands| |join| (|LoadOperand| |item|)))
(SETQ |operand1| (LENGTH |operand-list|))
(SELECTQ |oplength|
(1 (SETQ |liststart| (LIST (PACK (|if| (SUBSTRING |name| (ADD1 |posK|))
|then| (LIST (SUBSTRING |name| 1 (SUB1 |posK|
))
|operand1|
(SUBSTRING |name| (ADD1 |posK|))
)
|else| (LIST (SUBSTRING |name| 1 (SUB1 |posK|))
|operand1|))))))
(2 (SETQ |liststart| (LIST |name| |operand1|)))
(3 (SETQ |liststart| (APPEND (LIST |name|)
(|BytesToList| |operand1| 2))))
(HELP "Unknown oplength"))
(APPEND |liststart| |operand-list|)
|else| (SELECTQ |oplength|
(1 (SETQ |liststart|
(|if| |isjump|
|then| (LIST (PACK (|if| (SUBSTRING |name| |posK|)
|then| (LIST (SUBSTRING |name| 1 (SUB1 |posK|))
|operand1|
(SUBSTRING |name| (ADD1 |posK|)))
|else| (LIST (SUBSTRING |name| 1 (SUB1 |posK|))
|operand1|))))
|else| (LIST |name|))))
(2 (|if| (LISTP |operand1|)
|then| (SETQ |operand1| (EVAL |operand1|)))
(SETQ |liststart| (LIST |name| (|if| (EQ |name| 'LRSH.N)
|then| (DIFFERENCE 32 |operand1|)
|else| |operand1|)))
(SETQ |operands| (CDR |operands|)))
(3 (SETQ |liststart| (APPEND (LIST |name|)
(|BytesToList| (|OperandVal| |operand1|)
2)))
(SETQ |operands| (CDR |operands|)))
(5 (SETQ |liststart| (APPEND (LIST |name|)
(|BytesToList| (|OperandVal| |operand1|)
4)))
(SETQ |operands| (CDR |operands|)))
(HELP "Unknown oplength"))
(APPEND (|for| |item| |in| |operands| |join| (|LoadOperand| |item|))
|liststart|)))))
(|UfnEntry|
(LAMBDA (|opcodename|) (* \; "Edited 22-Oct-87 14:57 by Krivacic")
(|if| (LISTP |opcodename|)
|then| (|for| |entry| |in| |opcodename| |join| (|UfnEntry| |entry|))
|else| (APPEND (LIST 'IREGX (|UProp| '|UfnBase| '\k))
(|MakePConst| (|AddAtom| |opcodename|))
(LIST 'GETBASEPTR.N (|UProp| '|DefCellOffset| '\k2)
'PUTBASEPTR.N |opcodename| 'POP)))))
(|UfnBase|
(LAMBDA NIL (* \; "Edited 11-Nov-87 16:05 by Krivacic")
(DECLARE (GLOBALVARS |FreeMemIndex| *UFN-BASE*))
(SETQ |FreeMemIndex| (|AddressAdjust| |FreeMemIndex| 256))
(PRINTOUT T "UfnBase: " |FreeMemIndex| T)
(SETQ *UFN-BASE* |FreeMemIndex|)
(LET ((|baseaddr| |FreeMemIndex|))
(SETQ |FreeMemIndex| (PLUS |FreeMemIndex| 256))
(APPEND (|MakePConst| (|TamRep| '|Code| |baseaddr|))
(LIST 'IREGX←↑ (|UProp| '|UfnBase| '\k))
(|MakePConst| (|MakeList| (|for| \i |from| 0 |to| 20 |collect| 0)))
(LIST 'IREGX←↑ (|UProp| '|ConsPtr| '\k))))))
(|InitClink|
(LAMBDA (|framecount|) (* \; "Edited 9-Nov-87 17:08 by Krivacic")
(APPEND (|MakePConst| (|InitStackFrames| |framecount|))
(LIST 'MYCLINK←↑))))
(|MakePConst|
(LAMBDA (|ptr|) (* \; "Edited 10-Nov-87 15:25 by Krivacic")
(* |;;| "Make the Proper Pointer opcode, depending on the type of pointer past")
(|if| (NOT (NUMBERP |ptr|))
|then| (SETQ |ptr| (|AddAtom| |ptr|)))
(APPEND (LIST (SELECTQ (|GetTamTag| |ptr|)
(0 'ICONST)
(1 'FCONST)
(2 'PCONST1)
'PCONST2))
(|BytesToList| |ptr|))))
(|AddFn|
(LAMBDA (|parms|) (* \; "Edited 10-Nov-87 15:23 by Krivacic")
(DESTRUCTURING-BIND (|fnname| |code|)
|parms|
(LET ((|wordat| (QUOTIENT (|NextFnAddr|)
4)))
(|AddAtom| |fnname| NIL (|TamRep| '|Code| |wordat|))
(PRINTOUT T "Function: " |fnname| " @ ")
(|PrintData| (|TamRep| '|Code| |wordat|))
(PRINTOUT T ", byte: " (TIMES |wordat| 4)
T)
(LET (|newat| |newatbyte|)
(SETQ |newat| (PLUS |wordat| 12))
(SETQ |newatbyte| (TIMES |newat| 4))
(APPEND (LIST '@ |wordat|)
(|BytesToList| 0)
(|BytesToList| 1)
(|BytesToList| 2)
(|BytesToList| 3)
(|BytesToList| |newatbyte|)
(|BytesToList| |newatbyte|)
(|BytesToList| |newatbyte|)
(|BytesToList| |newatbyte|)
(|BytesToList| |newatbyte|)
(|BytesToList| |newatbyte|)
(|BytesToList| |newatbyte|)
(|BytesToList| |newatbyte|)
|code|))))))
(|JumpNewPage|
(LAMBDA NIL (* \; "Edited 30-Oct-87 14:05 by Krivacic")
(DECLARE (GLOBALVARS *JUMP-TO-PAGE-LIST*))
(LET ((|nextpage| (|AddressAdjust| |start| 1024)))
(SETQ *JUMP-TO-PAGE-LIST* (CONS (CONS |start| |nextpage|)
*JUMP-TO-PAGE-LIST*))
(APPEND (LIST 'JUMPXX)
(|BytesToList| (DIFFERENCE |nextpage| (PLUS |start| 3))
2)
(LIST '@ (LRSH |nextpage| 2))))))
(|IFExpr|
(LAMBDA (|parms|) (* \; "Edited 9-Nov-87 17:33 by Krivacic")
(DESTRUCTURING-BIND (|condition-expr| |then-code| |else-code|)
|parms|
(LET (|condition-list| |then-list| |else-list|)
(SETQ |condition-list| (|LoadOperand| |condition-expr|))
(SETQ |then-list| (|for| |expr| |in| |then-code| |join| (|LoadOperand| |expr|)))
(SETQ |else-list| (|for| |expr| |in| |else-code| |join| (|LoadOperand| |expr|)))
(|if| |else-list|
|then| (SETQ |then-list| (APPEND |then-list| (LIST 'JUMPX (LENGTH |else-list|))))
)
(APPEND |condition-list| (LIST 'FJUMPX↑ (LENGTH |then-list|))
|then-list| |else-list|)))))
)
(* |;;;| "Specialized Operations")
(DEFINEQ
(|MakeList|
(LAMBDA (|new-list| |refcount|) (* \; "Edited 11-Nov-87 15:32 by Krivacic")
(DECLARE (GLOBALVARS |start| |FreeMemIndex| *JUMP-TO-PAGE-LIST* *LIST-CONSTANTS*))
(|if| (LISTP |new-list|)
|then| (PROG (|result| |start-address|)
(|for| |list-cache| |in| *LIST-CONSTANTS* |do| (SETQ |result| (CAR |list-cache|)
)
|when| (EQUAL |new-list| (CADR |list-cache|)))
(|if| |result|
|then| (LET (|memory| |tagbits|)
(SETQ |memory| (|MemoryAccess| |result| NIL NIL))
(SETQ |tagbits| (|ConcatBits| '((|memory| 0 6 34))))
(|MemoryAccess| |result|
(|ConcatBits| '((|memory| 0 34 0)
((|Eval| (PLUS |tagbits| (OR |refcount| 0
)))
34 6 0)))
NIL)
(RETURN (|TamRep| '|Cons| |result|))))
(SETQ |start-address| |FreeMemIndex|)
(SETQ |FreeMemIndex| (PLUS 2 |FreeMemIndex|))
(SETQ *LIST-CONSTANTS* (CONS (LIST |start-address| |new-list|)
*LIST-CONSTANTS*))
(|MemoryAccess| |start-address| (|ConcatBits|
'(((|Eval| (|OperandVal| (CAR |new-list|)
T))
0 34 0)
((|Eval| (OR |refcount| 0))
34 6 0))))
(|MemoryAccess| (ADD1 |start-address|)
(|MakeList| (CDR |new-list|)
1))
(RETURN (|TamRep| '|Cons| |start-address|)))
|else| (|OperandVal| |new-list|))))
(|OperandVal|
(LAMBDA (|operand| |inalist|) (* \; "Edited 11-Nov-87 15:35 by Krivacic")
(* |;;| "Return the Value of the Operand")
(|if| (NUMBERP |operand|)
|then| |operand|
|elseif| (LITATOM |operand|)
|then|
(* |;;| "Return the Symbol Value")
(SELECTQ |operand|
(T (|TamRep| 'T))
(NIL (|TamRep| 'NIL))
(|Unbound| (|TamRep| '|Unbound|))
(|AddAtom| |operand| NIL NIL NIL 1))
|elseif| (LISTP |operand|)
|then|
(* |;;| "Return the List Value, Eval when one of the Special Cases")
(|if| |inalist|
|then| (|MakeList| |operand|)
|else| (EVAL |operand|))
|else| (|Emulator-Error| "Cannot Parse Operand: " |operand|))))
(|MakeClosure|
(LAMBDA (|parms|) (* \; "Edited 4-Nov-87 11:48 by Krivacic")
(DESTRUCTURING-BIND (|closure-name| |closure-init-values|)
|parms|
(LET (|closure-address| |closure-vars-address| (|closure-vars-length| (LENGTH
|closure-init-values|
)))
(SETQ |closure-address| (|FreeMemIndexBump| 4))
(SETQ |closure-vars-address| (|FreeMemIndexBump| (PLUS |closure-vars-length| 2)))
(|for| |address| |from| (PLUS 2 |closure-vars-address|) |as| |initial-value|
|in| |closure-init-values| |do| (|MemoryAccess| |address| |initial-value| T))
(|MemoryAccess| (PLUS |closure-address| (|UProp| '|ClosureEnvOffset| '\k2))
(|TamRep| '|Object| |closure-vars-address|))
(|MemoryAccess| (PLUS |closure-address| (|UProp| '|ClosureCodeOffset| '\k2))
(|ReadAtom| |closure-name| '|def|))
(|AddAtom| |closure-name| NIL (|TamRep| '|Closure| |closure-address|)
NIL NIL)))))
)
(DEFINEQ
(|AddAtom|
(LAMBDA (|atom| |val| |def| |prop| |refcount|) (* \; "Edited 11-Nov-87 14:40 by Krivacic")
(PROG ((|memval| (|TamRep| '|Unbound|))
(|index| (|AtomIndex| |atom|)))
(|if| (NOT |index|)
|then| (SETQ |FreeMemIndex| (|AddressAdjust| |FreeMemIndex| 8))
(PUTHASH |atom| |FreeMemIndex| |AtomHashArray|)
(SETQ |index| |FreeMemIndex|)
(SETQ |FreeMemIndex| (IPLUS |FreeMemIndex| 8))
(|MemoryAccess| |index| (|ConcatBits| '((4 34 6 0)
(|memval| 0 34 0))))
(|for| \i |from| 1 |to| 3 |do| (|MemoryAccess| (IPLUS \i |index|)
|memval|))
(|MemoryAccess| (IPLUS 4 |index|)
(|TamRep| (\\LOLOC |atom|))))
(|if| |refcount|
|then|
(* |;;| "refcount of 1 means bump refcount, else set to imposed value")
(LET (|memory| |tagbits|)
(SETQ |memory| (|MemoryAccess| |index| NIL T))
(SETQ |tagbits| (|ConcatBits| '((|memory| 0 6 34))))
(SETQ |refcount| (OR (AND (EQ 1 |refcount|)
(ADD1 |tagbits|))
|refcount|))
(|MemoryAccess| |index| (|ConcatBits| '((|refcount| 34 6 0)
(|memory| 0 34 0)))
T)))
(|if| |val|
|then| (|MemoryAccess| (IPLUS 1 |index|)
|val|))
(|if| |def|
|then| (|MemoryAccess| (IPLUS 2 |index|)
|def|))
(|if| |prop|
|then| (|MemoryAccess| (IPLUS 3 |index|)
|prop|))
(RETURN (|TamRep| '|Atm| |index|)))))
(|ReadAtom|
(LAMBDA (|atom| |part| |noTypeBits?|) (* \; "Edited 29-Oct-87 12:12 by Krivacic")
(LET ((|result| (|MemoryAccess| (PLUS (OR (GETHASH |atom| |AtomHashArray|)
(HELP "atom not yet defined" |atom|))
(SELECTQ (OR |part| '|val|)
(|val| 1)
(|def| 2)
(|prop| 3)
(|all| (|for| \i |from| 0 |to| 4
|do| (|MemoryAccess| (PLUS (GETHASH |atom|
|AtomHashArray|
)
\i)))
1)
(HELP "bad part" |part|))))))
(|if| |noTypeBits?|
|then| (LOGAND |result| (MASK.1\'S 0 24))
|else| |result|))))
(|AtomIndex|
(LAMBDA (|atom|) (* \; "Edited 6-Oct-87 17:59 by Krivacic")
(GETHASH |atom| |AtomHashArray|)))
)
(DEFINEQ
(|AddFnHeader|
(LAMBDA (|fnname| |wordat| |sp|) (* \; "Edited 22-Oct-87 14:05 by Krivacic")
(|if| (NOT |wordat|)
|then| (SETQ |wordat| (|NextFnAddr|)))
(|if| (NOT |sp|)
|then| (SETQ |sp| 17))
(PROG ((|at| |wordat|)
|newat|)
(|AddAtom| |fnname| NIL (|TamRep| '|Code| |at|))
(SETQ |newat| (PLUS |at| 12))
(SETQ |newatbyte| (TIMES |newat| 4))
(|MemoryAccess| |at| (|TamRep| 0))
(|MemoryAccess| (PLUS |at| 1)
(|TamRep| 0))
(|MemoryAccess| (PLUS |at| 2)
(|TamRep| 0))
(|MemoryAccess| (PLUS |at| 3)
(|TamRep| 0))
(|for| I |from| 0 |to| 7 |do| (|MemoryAccess| (PLUS |at| 4 I)
(|TamRep| |newatbyte|)))
(SETQ |start| |newatbyte|))))
(|NextFnAddr|
(LAMBDA NIL (* \; "Edited 29-Oct-87 12:36 by Krivacic")
(|AddressAdjust| |start| 64)))
(|AddMemFrame|
(LAMBDA (|NextFrame|) (* \; "Edited 1-Oct-87 15:11 by Krivacic")
(PROG ((|Ptr| |FreeMemIndex|)
(|FrameSize| 44))
(|for| \i |from| |FreeMemIndex| |to| (PLUS |FreeMemIndex| |FrameSize|)
|do| (|MemoryAccess| \i (|TamRep| '|Unbound|)
T))
(|MemoryAccess| (PLUS |FreeMemIndex| (CADR (FASSOC '|NextLink| (GETPROP '\k2 '|uField|))))
|NextFrame|)
(SETQ |FreeMemIndex| (PLUS |FreeMemIndex| |FrameSize|))
(RETURN (|TamRep| '|Stack| |Ptr|)))))
(|AddVmTable|
(LAMBDA (|Where| |Size| |NotPresent| |WriteProtect|) (* \; "Edited 28-Sep-87 19:00 by Krivacic")
(|if| (NOT |Where|)
|then| (SETQ |Where| 4096))
(|if| (NOT |Size|)
|then| (SETQ |Size| 4096)
(SETQ |Size| 10)) (* PROG ((|pageaddr| 0))
(|for| \i |from| |Where| |to|
(PLUS |Where| |Size|) |do|
(|MemoryAccess| \i (|TamRep|
(|ConcatBits| (QUOTE
(((|Eval| (LNOT (OZ |NotPresent|))) 12
1 0) ((|Eval| (LNOT (OZ |WriteProtect|)))
13 1 0) (|pageaddr| 0 12 0))))))
(SETQ |pageaddr| (ADD1 |pageaddr|))))
))
)
(DEFINEQ
(|FreeMemIndexBump|
(LAMBDA (|size|) (* \; "Edited 4-Nov-87 10:33 by Krivacic")
(* |;;| " Bump the FreeMemIndex by the given word size")
(* |;;| "Do Not allow the allocated block to cross a page boundry")
(DECLARE (GLOBALVARS |FreeMemIndex|))
(LET ((|allocation-address| |FreeMemIndex|)
(|new-index| (PLUS |FreeMemIndex| |size|)))
(|if| (NEQ (|ConcatBits| '((|new-index| 0 24 8)))
(|ConcatBits| '((|FreeMemIndex| 0 24 8))))
|then| (SETQ |allocation-address| (|ConcatBits| '((|new-index| 8 24 8))))
(SETQ |new-index| (PLUS |allocation-address| |size|)))
(SETQ |FreeMemIndex| |new-index|)
|allocation-address|)))
)
(* |;;;| "Old Code ")
(DEFINEQ
(|AddCode|
(LAMBDA (|theAtom|) (* |jmh| "22-May-86 10:50")
(* * |download| |the| TCODE |property| |of| |theAtom| |<error| |if| |none>| --
|return| |the| |TamRep| |of| |the| |Tamarin-memory| CODEP --
|the| TCODE |property| |is| \a |list:| CAR |is| \a |byte| |array,| |some| |of|
|the| |function-header| |fields| |of| |which| |need| |massaging;|
CDR |is| \a |list| |of| |either| |<atom| 3 |byteOffset>| |or| |<listp| 4
|byteOffset>| |telling| |what| |bytes| |need| |to| |be| |patched| |with| |the|
|TamRep| |of| |what|)
(DECLARE (GLOBALVARS |FreeMemIndex|))
(|if| (NOT |FreeMemIndex|)
|then| (ERROR "FreeMemIndex uninitialized"))
(LET ((|theTCodeProperty| (GETPROP |theAtom| 'TCODE))
|codePAddr| |theTCodeP| |theLinkInfo| |nrBytes| |nrWords| |nrWordsInHdr| |nrBytesInHdr|)
(|if| (NOT (AND (LISTP |theTCodeProperty|)
(PROGN (SETQ |theTCodeP| (CAR |theTCodeProperty|))
(SETQ |theLinkInfo| (CDR |theTCodeProperty|))
(ARRAYP |theTCodeP|))
(EQ (ARRAYTYP |theTCodeP|)
'BYTE)
(EQ 0 (ARRAYORIG |theTCodeP|))
(EQ (SETQ |nrBytes| (ARRAYSIZE |theTCodeP|))
(CEIL |nrBytes| BYTESPERCELL))))
|then| (ERROR |theAtom| "has bad TCode Property"))
(* * |allocate| |space| |for| |the| |tcodep| --
|first| |round| |up| |FreeMemIndex| |as| |necessary| |to| |be| |quad-word|
|aligned,| |just| |in| |case|)
(SETQ |codePAddr| (SETQ |FreeMemIndex| (CEIL |FreeMemIndex| WORDSPERQUAD)))
(SETQ |nrWords| (FOLDHI |nrBytes| BYTESPERCELL))
(|add| |FreeMemIndex| |nrWords|)
(* * |load| |header|)
(SETQ |nrWordsInHdr| (|LoadFnHdr| |codePAddr| |theTCodeP| |nrWords|))
(SETQ |nrBytesInHdr| (UNFOLD |nrWordsInHdr| BYTESPERCELL))
(* * |load| |body| |of| |code| -- NOTE\: |old-format| |name| |tables| |loaded|
|as| |is,| |as| |code|)
(|for| |fromByteAddr| |from| |nrBytesInHdr| |to| (SUB1 |nrBytes|) |as| |toByteAddr|
|from| (IPLUS (UNFOLD |codePAddr| BYTESPERCELL)
|nrBytesInHdr|) |do| (|StoreTamByte| |toByteAddr| (ELT |theTCodeP|
|fromByteAddr|)))
(* * |linking| |of| |atoms| |and| |listps| --
|where| |the| |code| |refers| |to| |atom| |or| |list| |literals,| |ensure|
|that| |they| |exist| |in| |the| |Tamarin,| |and| |patch| |their|
|representations| |into| |the| |byte| |stream|)
(|LinkCode| |codePAddr| |theLinkInfo|)
(* * |done|)
(|TamRep| '|Code| |codePAddr|))))
(|LoadFnHdr|
(LAMBDA (|tamBase| |theTCodeP| |objectSize|) (* \; "Edited 15-May-87 17:17 by Krivacic")
(* * |store| |Tamarin-memory| |form| |of| TFNHDR |of| TCODEP |to| |Tamarin|
|memory| |at| CODEPADDR -- |return| |number| |of| |cells| |in| |function|
|header| -- * * |doesn't| |copy| FLAGS |now| --
|includes| |entry| |vector| |that| |immediately| |follows| |fn| |hdr| |proper|)
(* LET ((|hdrSize| 8) (|fnHdr| (ARRAYBASEPTR |theTCodeP|))
(|self| (|TamRep| (QUOTE |Code|) |tamBase|)))
(|if| (NEQ |hdrSize| (|fetch| (TFNHDR OVERHEADCELLS) |of| T)) |then|
(SHOULDNT "Tam fn hdr size changed?")) (|MemoryAccess|
(PLUS 0 |tamBase|) (|TamRep| (QUOTE |Unbound|)))
(* OBJECTHEADERCELL) (|MemoryAccess| (PLUS 1 |tamBase|)
(|TamRep| (QUOTE |Int|) |objectSize|)) (|MemoryAccess|
(PLUS 2 |tamBase|) (|AddAtom| (|fetch| (TFNHDR FRAMENAME) |of| |fnHdr|)))
(|MemoryAccess| (PLUS 3 |tamBase|) (|TamRep|
(QUOTE |Int|) (LOGOR (LLSH (|fetch| (TFNHDR NTSIZE) |of| |fnHdr|) 16)
(LLSH (|fetch| (TFNHDR NLOCALS) |of| |fnHdr|) 8)
(|fetch| (TFNHDR FVAROFFSET) |of| |fnHdr|))))
(|MemoryAccess| (PLUS 4 |tamBase|) (|TamRep|
(QUOTE |Int|) (LOGOR (LLSH (|fetch| (TFNHDR MAXVAR) |of| |fnHdr|) 16)
(LLSH (|fetch| (TFNHDR USECOUNT) |of| |fnHdr|) 8)
(|fetch| (TFNHDR SP) |of| |fnHdr|)))) (|MemoryAccess|
(PLUS 5 |tamBase|) (|TamRep| (QUOTE |Unbound|)))
(|MemoryAccess| (PLUS 6 |tamBase|) |self|)
(|MemoryAccess| (PLUS 7 |tamBase|) |self|)
(|for| I |from| 0 |to| 7 |do| (|MemoryAccess|
(PLUS I |hdrSize| |tamBase|) (|TamRep| (QUOTE |Int|)
(IPLUS (TFNHDR.EVN |fnHdr| I) (LLSH (LOGAND |tamBase|
(MASK.1\'S 0 24)) 2))))) (PLUS |hdrSize| 8))
))
(|LinkCode|
(LAMBDA (|codeAddr| |linkInfos|) (* \; "Edited 15-May-87 17:17 by Krivacic")
(* * |patch| \a |codep| |in| |Tamarin| |memory| |with| |link| |information| --
|codeAddr| |is| |the| |Tamarin| |address| |of| |the| |codep| --
|linkInfos| |is| \a |list| |of| |<thing| |nrBytes| |byteOffset>,| |each|
|saying| |of| \a |thing| |that| |it| |needs| |to| |be| |in| |the| |Tamarin|
|memory,| |and| |that| |the| |right| |nrBytes| |of| |its| |Tamarin| |pointer|
|representation| |needs| |to| |be| |patched| |into| |the| |codep| |starting|
|at| |the| |byteOffset| -- |atom| |and| |list| |literals| |are| |supported|)
(* |for| |linkInfo| |in| |linkInfos| |bind| |theThing| |nrBytes| |theTamRep|
|do| (SETQ |theThing| (CAR |linkInfo|)) (SETQ |nrBytes|
(CADR |linkInfo|)) (SETQ |byteOffset| (CADDR |linkInfo|))
(SETQ |theTamRep| (|if| (LITATOM |theThing|) |then|
(|if| (MEMB |theThing| (QUOTE (NIL T UNBIND))) |then|
(|TamRep| |theThing|) |else| (|AddAtom| |theThing|)) |elseif|
(LISTP |theThing|) |then| (|AddList| |theThing|) |else|
(HELP "not atom nor list" |theThing|))) (* * |emit| |least| |sig| |byte|
|first|) (|for| |counter| |from| 1 |to| |nrBytes| |as| |bytePointer| |from|
(PLUS (UNFOLD |codeAddr| BYTESPERCELL) |byteOffset|) |do|
(|StoreTamByte| |bytePointer| (LOGAND |theTamRep| 255))
(SETQ |theTamRep| (LRSH |theTamRep| 8))))
))
(|AddUfns|
(LAMBDA (|ufnList|) (* \; "Edited 15-May-87 17:18 by Krivacic")
(* * |ufnList| |is| \a |list| |of| |<opname| |ufnname>s| --
|get| |all| |these| |ufn| |fns'| |tcodeps| |downloaded| |and| |their|
|addresses| |in| |the| |Tamarin's| |ufn| |table| --
|that| |table| |is| |pointed| |to| |by| |the| |tamarin| |atom| |UfnTable| --
|note| |does| |not| |create| |Tamarin| |atoms| |naming| |the| |ufn| |functions|)
(* LET ((|ufnTableBase|
(LOGAND (MASK.1\'S 0 30)
(|MemoryAccess| (ADD1
(LOGAND (MASK.1\'S 0 24)
(|AddAtom| (QUOTE |UfnTable|))))))))
(* |i.e.| |the| |contents| |of| |the|
|value| |cell| |of| |the| |already|
|existing| |tamarin| |atom|
|UfnTable,| |as| \a |raw| |number|)
(|for| X |in| |ufnList| |bind|
|opName| |ufnName| |opNr| |do|
(SETQ |opName| (CAR X))
(SETQ |ufnName| (CADR X))
(|if| (NOT (SETQ |opNr|
(|for| I |from| 0 |to| 255 |thereis|
(EQ |opName| (CAR (ELT |OpPlaArray| I))))))
|then| (HELP "opName not in OpPlaArray"
|opName|)) (|MemoryAccess|
(PLUS |ufnTableBase| |opNr|)
(|AddCode| |ufnName|))))
))
)
(PUTPROPS OPCODEASSEMBLER COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (1851 10960 (|AssembleOps| 1861 . 3062) (|AssembleOps.1| 3064 . 6535) (|AddItem| 6537 .
7100) (|AddList| 7102 . 7903) (|EvalBytes| 7905 . 9895) (|ClearMemoryArray| 9897 . 10535) (|UProp|
10537 . 10718) (|AddressAdjust| 10720 . 10958)) (11017 15368 (|ListEval| 11027 . 11920) (|ValList|
11922 . 12346) (|LoadOperand| 12348 . 14339) (|BytesToList| 14341 . 14623) (|ExpandList| 14625 . 15366
)) (15440 24009 (|DoOp| 15450 . 19068) (|UfnEntry| 19070 . 19602) (|UfnBase| 19604 . 20331) (
|InitClink| 20333 . 20555) (|MakePConst| 20557 . 21104) (|AddFn| 21106 . 22582) (|JumpNewPage| 22584
. 23136) (|IFExpr| 23138 . 24007)) (24054 28739 (|MakeList| 24064 . 26450) (|OperandVal| 26452 .
27411) (|MakeClosure| 27413 . 28737)) (28740 32307 (|AddAtom| 28750 . 30872) (|ReadAtom| 30874 . 32138
) (|AtomIndex| 32140 . 32305)) (32308 35178 (|AddFnHeader| 32318 . 33245) (|NextFnAddr| 33247 . 33413)
(|AddMemFrame| 33415 . 34036) (|AddVmTable| 34038 . 35176)) (35179 36014 (|FreeMemIndexBump| 35189 .
36012)) (36045 45374 (|AddCode| 36055 . 39191) (|LoadFnHdr| 39193 . 41231) (|LinkCode| 41233 . 42903)
(|AddUfns| 42905 . 45372)))))
STOP