(FILECREATED "17-FEB-83 17:42:33" <LISPUSERS>ARITHMAC.;9 10237
changes to: (FNS NUMTOAC)
(VARS ARITHMACCOMS)
previous date: "17-FEB-83 17:24:23" <LISPUSERS>ARITHMAC.;6)
(* Copyright (c) 1983 by Xerox Corporation)
(PRETTYCOMPRINT ARITHMACCOMS)
(RPAQQ ARITHMACCOMS [(FNS FBIND FLOATSETQ FLOATSETQMAC LARGESETQ LARGESETQMAC LARGEVAL LBIND NUMTOAC)
(DECLARE: EVAL@COMPILE (FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
NOBOX DECL))
(DECLTYPES (FLOATP BINDFN)
(FLOATP SETFN)
(LARGEP BINDFN)
(LARGEP SETFN))
(MACROS FBIND FLOATSETQ LARGESETQ LBIND FLOAT)
(PROP (10MACRO DMACRO)
FIX)
(PROP AMAC VAGFIX)
(PROP 10MACRO IBOX FBOX)
(PROP DECLOF FBOX IBOX FLOATSETQ LARGESETQ)
(IGNOREDECL)
(DECLARE: DONTEVAL@LOAD DONTCOPY EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE PDP-10))
(ADDVARS (DONTCOMPILEFNS NUMTOAC)))
(DECLARE: EVAL@COMPILE DONTCOPY (PROP (10MACRO DMACRO)
LARGEVAL)
COMPILERVARS
(ADDVARS (NLAMA)
(NLAML LARGESETQ FLOATSETQ)
(LAMA LBIND FBIND])
(DEFINEQ
(FBIND
[LAMBDA NARGS (* bas: "19-OCT-79 18:31" posted: "24-SEP-78 16:09")
(* Produces a constant box for binding floating variables)
(if NARGS=0
then (create FBOX)
else (create FBOX
F ←(the FLOATP (ARG NARGS 1])
(FLOATSETQ
[NLAMBDA (VAR VAL) (* bas: " 9-FEB-83 17:57")
(* Value is the floating box bound to VAR)
(DECLARE (LOCALVARS . T)) (* B/c of EVALV)
(replace F of (OR (FLOATP (EVALV VAR))
(HELP "FLOATP variable not bound to floating box!" VAR))
with (OR (FLOATP (EVAL VAL))
(HELP "Attempt to assign non-floating value to floating variable: "
(LIST VAR (EVAL VAL])
(FLOATSETQMAC
[LAMBDA (ARGS) (* bas: "16-FEB-83 15:25")
(SUBPAIR (QUOTE (VR VAL))
[if (COVERS (QUOTE FLOATP)
(DECLOF (CADR ARGS)))
then ARGS
else (printout T T "Floating SETQ of unknown value: " .P2 ARGS T)
(LIST (CAR ARGS)
(LIST (QUOTE the)
(QUOTE FLOATP)
(CADR ARGS]
(SELECTQ (SYSTEMTYPE)
[(TENEX TOPS20)
(QUOTE (ASSEMBLE NIL (CQ (VAG VAL))
(E (NUMTOAC 2 (QUOTE FLOATP)))
(VAR (HRRZ 1 , VR))
(MOVEM 2 , 0 (1]
(D (QUOTE (replace F of VR with VAL)))
(SHOULDNT])
(LARGESETQ
[NLAMBDA (VAR VAL) (* bas: " 9-FEB-83 17:59")
(* Value is the large box bound to VAR.
RPLFLDVAL gets VAL rather than VAL:I b/c it might be
SMALLP)
(DECLARE (LOCALVARS . T)) (* B/c of EVALV)
(replace I of (OR (LARGEVAL (EVALV VAR))
(HELP "LARGEP variable not bound to large box!" VAR))
with (OR (FIXP (EVAL VAL))
(HELP "Attempt to assign non-integer value to largep variable: " (LIST VAR
(EVAL VAL])
(LARGESETQMAC
[LAMBDA (ARGS) (* bas: "16-FEB-83 15:25")
(SELECTQ (SYSTEMTYPE)
[(TENEX TOPS20)
(SUBPAIR (QUOTE (TYPE VR VAL))
(CONS (SELCOVERSQ (CADR ARGS)
(SMALLP (QUOTE SMALLP))
(LARGEP (QUOTE LARGEP))
(FIXP (QUOTE FIXP))
(PROGN (printout T T "Large SETQ of unknown value: " .P2
ARGS T)
[SETQ ARGS (LIST (CAR ARGS)
(LIST (QUOTE the)
(QUOTE FIXP)
(CADR ARGS]
(QUOTE FIXP)))
ARGS)
(QUOTE (ASSEMBLE NIL (CQ (VAG VAL))
(E (NUMTOAC 2 (QUOTE TYPE)))
(VAR (HRRZ 1 , VR))
(MOVEM 2 , 0 (1]
[D (LIST (QUOTE replace)
(QUOTE I)
(QUOTE of)
(CAR ARGS)
(QUOTE with)
(if (COVERS (QUOTE FIXP)
(DECLOF (CADR ARGS)))
then (CADR ARGS)
else (printout T T "Large SETQ of unknown value: " .P2 ARGS T)
(LIST (QUOTE the)
(QUOTE FIXP)
(CADR ARGS]
(SHOULDNT])
(LARGEVAL
[LAMBDA (V) (* bas: " 9-FEB-83 22:33")
(AND (FIXP V)
(NOT (SMALLP V))
V])
(LBIND
[LAMBDA NARGS (* rmk: "29-OCT-78 18:11" posted: "24-SEP-78 16:09")
(* Produces a constant box for binding large variables)
(if NARGS=0
then (create IBOX)
else (create IBOX
I ←(the FIXP (ARG NARGS 1])
(NUMTOAC
[LAMBDA (AC KNOWNTYPE) (* bas: " 7-AUG-78 19:03" posted: "29-JUN-78 00:11")
(* A peep-hold optimizer called just after code to unbox a number of known type KNOWNTYPE into AC1 has been
compiled. Changes the code list so that the bits end up in AC.)
(DECLARE (USEDFREE CODE))
(COND
((NULL AC)
(SETQ AC 1)))
(PROG (INST)
(SELECTQ
[CAR (SETQ INST (LISTP (CAR CODE]
[FASTCALL
(COND
((EQ (CADR INST)
(QUOTE GUNBOX))
(SETQ CODE (CDR CODE)) (* Remove the unbox instruction)
(SELECTQ KNOWNTYPE
[(FLOATP LARGEP)
(SELECTQ [CAR (SETQ INST (LISTP (CAR CODE]
[HRRZ (COND
[(EQ (CAR (CADDDR INST))
(QUOTE VREF))
(* Unbox the variable by moving indirect through the
value-cell)
(SETQ CODE (CDR CODE))
(STORIN (CONS (QUOTE MOVE)
(CONS AC (CONS (QUOTE ,)
(CONS (QUOTE @)
(CDDDR INST]
(T (STORIN (CONS (QUOTE MOVE)
(CONS AC (QUOTE (, 0 (1]
[LDV (SETQ CODE (CDR CODE))
(STORIN (LIST (QUOTE MOVE)
AC
(QUOTE ,)
(QUOTE @)
(CONS (QUOTE VREF)
(CDR INST]
(STORIN (CONS (QUOTE MOVE)
(CONS AC (QUOTE (, 0 (1]
[SMALLP (STORIN (CONS (QUOTE HRREI)
(CONS AC (QUOTE (, -2048 (1]
[FIXP (STORIN (QUOTE (STE SMALLT)))
[STORIN (CONS (QUOTE SKIPA)
(CONS AC (QUOTE (, 0 (1]
(STORIN (CONS (QUOTE HRREI)
(CONS AC (QUOTE (, -2048 (1]
(HELP "UNRECOGNIZED KNOWNTYPE - NUMTOAC" KNOWNTYPE))
(RETURN]
(LPOPN [COND
((NEQ AC (CADR INST))
(SETQ CODE (CDR CODE))
(STORIN (LIST (QUOTE LPOPN)
AC]
(RETURN))
(LDN [COND
((NEQ AC 1)
(SETQ CODE (CDR CODE))
(STORIN (LIST (QUOTE LDN2)
(CADR INST)
AC]
(RETURN))
(MOVE [COND
((NEQ AC (CADR INST))
(SETQ CODE (CDR CODE))
(STORIN (CONS (QUOTE MOVE)
(CONS AC (CDDR INST]
(RETURN))
(ASSEM (SETQ CODE (CONS [PROG [(CODE (REVERSE (CDR INST]
(DECLARE (SPECVARS . T))
(NUMTOAC AC KNOWNTYPE)
(RETURN (CONS (QUOTE ASSEM)
(DREVERSE CODE]
(CDR CODE)))
(RETURN))
NIL)
(COND
((NEQ AC 1)
(STORIN (CONS (QUOTE MOVE)
(CONS AC (QUOTE (, 1])
)
(DECLARE: EVAL@COMPILE
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
NOBOX DECL)
)
(DECLARE: EVAL@COMPILE
(DECLTYPES (FLOATP FLOATP BINDFN FBIND)
(FLOATP FLOATP SETFN FLOATSETQ)
(LARGEP LARGEP BINDFN LBIND)
(LARGEP LARGEP SETFN LARGESETQ))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS FBIND MACRO [ARGS (COND
[ARGS (LIST (QUOTE FBOX)
(LIST (QUOTE the)
(QUOTE FLOATP)
(CAR ARGS]
(T (QUOTE (FBOX])
(PUTPROPS FLOATSETQ MACRO (ARGS (FLOATSETQMAC ARGS)))
(PUTPROPS LARGESETQ MACRO (ARGS (LARGESETQMAC ARGS)))
(PUTPROPS LBIND MACRO [ARGS (COND
[ARGS (LIST (QUOTE IBOX)
(LIST (QUOTE the)
(QUOTE FIXP)
(CAR ARGS]
(T (QUOTE (IBOX])
(PUTPROPS FLOAT MACRO [ARGS (COND
((COVERS (QUOTE FLOATP)
(DECLOF (CAR ARGS)))
(CAR ARGS))
(T (QUOTE IGNOREMACRO])
)
(PUTPROPS FIX 10MACRO [ARGS (COND ((COVERS (QUOTE FIXP)
(DECLOF (CAR ARGS)))
(CAR ARGS))
(T (QUOTE IGNOREMACRO])
(PUTPROPS FIX DMACRO [ARGS (COND ((COVERS (QUOTE FIXP)
(DECLOF (CAR ARGS)))
(CAR ARGS))
(T (CONS (QUOTE IPLUS)
ARGS])
(PUTPROPS VAGFIX AMAC [(EX R)
(* Compiles EX and diddles code to put it right into R)
(CQ (VAG (FIX EX)))
(E (NUMTOAC R (QUOTE FIXP])
(PUTPROPS IBOX 10MACRO [ARGS (COND [(CAR ARGS)
(LIST (QUOTE ASSEMBLE)
NIL
(LIST (QUOTE VAGFIX)
(CAR ARGS)
2)
(LIST (QUOTE CQ)
(KWOTE (IPLUS 100000)))
(QUOTE (MOVEM 2 , 0 (1]
(T (KWOTE (IPLUS 10000000])
(PUTPROPS FBOX 10MACRO [ARGS (COND [(CAR ARGS)
(LIST (QUOTE ASSEMBLE)
NIL
[LIST (QUOTE CQ)
(LIST (QUOTE VAG)
(LIST (QUOTE FLOAT)
(CAR ARGS]
[QUOTE (E (NUMTOAC 2 (QUOTE FLOATP]
(LIST (QUOTE CQ)
(KWOTE (FPLUS 0.0)))
(QUOTE (MOVEM 2 , 0 (1]
(T (KWOTE (FPLUS 0.0])
(PUTPROPS FBOX DECLOF FLOATP)
(PUTPROPS IBOX DECLOF LARGEP)
(PUTPROPS FLOATSETQ DECLOF FLOATP)
(PUTPROPS LARGESETQ DECLOF LARGEP)
(DECLARE: DOEVAL@COMPILE DONTEVAL@LOAD DONTCOPY
(RESETSAVE COMPILEIGNOREDECL (QUOTE NIL))
)
(DECLARE: DONTEVAL@LOAD DONTCOPY EVAL@COMPILEWHEN (NEQ (COMPILEMODE)
(QUOTE PDP-10))
(ADDTOVAR DONTCOMPILEFNS NUMTOAC)
)
(DECLARE: EVAL@COMPILE DONTCOPY
(PUTPROPS LARGEVAL 10MACRO [LAMBDA (V)
(AND (EQ 18 (NTYP V))
V])
(PUTPROPS LARGEVAL DMACRO [LAMBDA (V)
(AND (EQ (CONSTANT \FIXP)
(NTYPX V))
V])
COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML LARGESETQ FLOATSETQ)
(ADDTOVAR LAMA LBIND FBIND)
)
(PUTPROPS ARITHMAC COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1140 7453 (FBIND 1150 . 1507) (FLOATSETQ 1509 . 2065) (FLOATSETQMAC 2067 . 2697) (
LARGESETQ 2699 . 3349) (LARGESETQMAC 3351 . 4384) (LARGEVAL 4386 . 4534) (LBIND 4536 . 4888) (NUMTOAC
4890 . 7451)))))
STOP