(FILECREATED "12-Jun-86 18:07:00" {ERIS}<TAMARIN>WORK>DT>DASM.;16 9718
changes to: (FNS D.GETMACHINE)
(VARS DASMCOMS)
previous date: "10-Apr-86 12:11:47" {ERIS}<TAMARIN>WORK>DT>DASM.;9)
(* Copyright (c) 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT DASMCOMS)
(RPAQQ DASMCOMS ((FILES ASM)
(COMS (* * fns that know what a D-machine is)
(FNS D.GETMACHINE DASM DPC)
(INITVARS DPC.RESUMELIST))
(COMS (* * generics)
(FNS D.FN.GENC D.SIC.GENC)
(PROP DASMFN FN SIC))))
(FILESLOAD ASM)
(* * fns that know what a D-machine is)
(DEFINEQ
(D.GETMACHINE
[LAMBDA NIL (* jmh "12-Jun-86 14:03")
(* * load SPECVARS for D-machine -- called by ASM, some kind of PRINTCODE, possibly others)
[PROGN (* layout stuff)
(DECLARE (USEDFREE TAM.OUTPUTSTYLE TAM.LINKINFO TAM.FNHDRSTYLE TAM.NTSTYLE
TAM.VARALLOCSTYLE TAM.1STVARSLOT))
[AND (BOUNDP (QUOTE TAM.OUTPUTSTYLE))
(SETQ TAM.OUTPUTSTYLE (PROG1 (QUOTE D)
(* CCODEP -- i.e. CODEARRAY)
]
[AND (BOUNDP (QUOTE TAM.LINKINFO))
(SETQ TAM.LINKINFO (PROG1 NIL (* i.e. no link info attached to CCODEP)
]
[AND (BOUNDP (QUOTE TAM.FNHDRSTYLE))
(SETQ TAM.FNHDRSTYLE (PROG1 (QUOTE D)
(* i.e. CODEARRAY fn hdr -- no entry vector)
]
[AND (BOUNDP (QUOTE TAM.NTSTYLE))
(SETQ TAM.NTSTYLE (PROG1 (QUOTE D)
(* the usual D-machine name table format)
]
[AND (BOUNDP (QUOTE TAM.VARALLOCSTYLE))
(SETQ TAM.VARALLOCSTYLE (PROG1 (QUOTE D)
(* the usual D-machine var alloc -- IVARS + PVARS but
no VARS -- IVARS in separate space from P/FVARS)
]
(AND (BOUNDP (QUOTE TAM.1STVARSLOT))
(SETQ TAM.1STVARSLOT (PROG1 NIL (* with TAM.VARALLOCSTYLE = D-machine, this should not
be used)]
(PROGN (* NO entry vectors so no standardized entry vector
code)
(DECLARE (USEDFREE TAM.LAMBDAEVS TAM.NLAMBDAEVS TAM.LAMBDA*EV TAM.NLAMBDA*EV))
(AND (BOUNDP (QUOTE TAM.LAMBDAEVS))
(SETQ TAM.LAMBDAEVS NIL))
(AND (BOUNDP (QUOTE TAM.LAMBDA*EV))
(SETQ TAM.LAMBDA*EV NIL))
(AND (BOUNDP (QUOTE TAM.NLAMBDAEVS))
(SETQ TAM.NLAMBDAEVS NIL))
(AND (BOUNDP (QUOTE TAM.NLAMBDA*EV))
(SETQ TAM.NLAMBDA*EV NIL)))
[PROGN (* opcode set)
(DECLARE (USEDFREE TAM.ASMFNPROPS TAM.OPCODEPROPS TAM.OPCODEARRAY))
[AND (BOUNDP (QUOTE TAM.ASMFNPROPS))
(SETQ TAM.ASMFNPROPS (PROG1 (QUOTE (DASMFN))
(* D-machine generics are the DASMFN property of
CAR-of instr)
]
[AND (BOUNDP (QUOTE TAM.OPCODEPROPS))
(SETQ TAM.OPCODEPROPS (PROG1 (QUOTE (DOPCODE))
(* D-machine OPCODE records are the DOPCODE property
of CAR-of instr)
]
(AND (BOUNDP (QUOTE TAM.OPCODEARRAY))
(SETQ TAM.OPCODEARRAY (PROG1 \OPCODEARRAY
(* array mapping op byte to OPCODE record, D-machine)
]
(PROGN (* code generation)
(DECLARE (USEDFREE TAM.STACKSTYLE TAM.ALPHASTYLE TAM.VARXSTYLE TAM.OPKSTYLE
TAM.JUMPSTYLE))
[AND (BOUNDP (QUOTE TAM.STACKSTYLE))
(SETQ TAM.STACKSTYLE (PROG1 (QUOTE D)
(* D-machine stack style -- BIND + UNBIND + DUNBIND vs
TUNBIND + TDUNBIND)
]
[AND (BOUNDP (QUOTE TAM.ALPHASTYLE))
(SETQ TAM.ALPHASTYLE (PROG1 (QUOTE D)
(* D-machine -- multi-byte args in instruction stream
presented most significant byte first)
]
[AND (BOUNDP (QUOTE TAM.VARXSTYLE))
(SETQ TAM.VARXSTYLE (PROG1 (QUOTE D)
(* D-machine -- xVARX alpha-byte is in words rel to var area of stack frame -- also LAMBDA* ivar opcodes *raw*
argument is 0-based arg#)
]
[AND (BOUNDP (QUOTE TAM.OPKSTYLE))
(SETQ TAM.OPKSTYLE (PROG1 (QUOTE D)
(* D-machine -- the implicit argument of a 1-byte opcode that has one, is the offset of the opcode into its OP#
range -- the OP# range shows which variants exist)
]
(AND (BOUNDP (QUOTE TAM.JUMPSTYLE))
(SETQ TAM.JUMPSTYLE (PROG1 (QUOTE D)
(* D-machine -- <1> all jumps except the -K ones have signed offsets, counted from the first byte of the
instruction, <2> an opK-format jump is forward from its opcode byte's location by implicit argument + 2)
])
(DASM
[LAMBDA (IL OPTIONS ERRFILE) (* jmh
" 4-Mar-86 17:49")
(ASM IL (QUOTE D)
OPTIONS ERRFILE])
(DPC
[LAMBDA (FN) (* jmh "10-Apr-86 10:01")
(DECLARE (GLOBALVARS DFNFLGFILES))
(LET ((BREAKNAME (QUOTE DPC)))
(DT.XXLIST BREAKNAME [FUNCTION (LAMBDA (FN)
(LET [(CCODEP (if (NOT (LITATOM FN))
then (printout T " printout of " FN
" --" T)
FN
elseif (DT.FNINFILELISTP FN DFNFLGFILES
BREAKNAME)
then (printout T
" printcode of CODE of " FN
" --" T)
(GETPROP FN (QUOTE CODE))
else (printout T " printcode of GETD of "
FN " --" T)
(GETD FN]
(PC.1 CCODEP (QUOTE D]
(QUOTE DT.LASTARG)
(QUOTE DPC.RESUMELIST)
FN])
)
(RPAQ? DPC.RESUMELIST NIL)
(* * generics)
(DEFINEQ
(D.FN.GENC
[LAMBDA (INSTR) (* jmh "18-Nov-85 14:17")
(* * returns list of one instr, unless error in which case returns NIL)
(if (NOT (AND (EQ 3 (LENGTH INSTR))
(ASM.RANGE? (CADR INSTR)
0 377Q)))
then (ASM.ERR "should have 2 args: a 0..255 and an atom")
else (LIST (SELECTQ (CADR INSTR)
(0 (LIST (QUOTE FN0)
(CADDR INSTR)))
(1 (LIST (QUOTE FN1)
(CADDR INSTR)))
(2 (LIST (QUOTE FN2)
(CADDR INSTR)))
(3 (LIST (QUOTE FN3)
(CADDR INSTR)))
(4 (LIST (QUOTE FN4)
(CADDR INSTR)))
(LIST (QUOTE FNX)
(CADR INSTR)
(CADDR INSTR])
(D.SIC.GENC
[LAMBDA (INSTR) (* jmh
"29-Mar-86 09:33")
(* * returns list of one instr, unless error in which case returns NIL)
(if [NOT (AND (EQ 2 (LENGTH INSTR))
(NUMBERP (CADR INSTR]
then (ASM.ERR "should have 1 arg, a number")
else (LIST (if (EQ 0 (CADR INSTR))
then (LIST (QUOTE '0))
elseif (EQ 1 (CADR INSTR))
then (LIST (QUOTE '1))
else (LIST (if (NOT (ASM.RANGE? (CADR INSTR)
-256 65535))
then (QUOTE GCONST)
elseif (MINUSP (CADR INSTR))
then (QUOTE SNIC)
elseif (ILEQ (CADR INSTR)
255)
then (QUOTE SIC)
else (QUOTE SICX))
(CADR INSTR])
)
(PUTPROPS FN DASMFN D.FN.GENC)
(PUTPROPS SIC DASMFN D.SIC.GENC)
(PUTPROPS DASM COPYRIGHT ("Xerox Corporation" 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (611 7469 (D.GETMACHINE 621 . 5688) (DASM 5690 . 5929) (DPC 5931 . 7467)) (7523 9564 (
D.FN.GENC 7533 . 8346) (D.SIC.GENC 8348 . 9562)))))
STOP