(FILECREATED "12-JUN-83 03:42:46" {PHYLUM}<LISPCORE>SYSTEM>MISC.;34 47593
changes to: (VARS DURATIONCOMS)
(FNS \TIMER.TIMERP \TIMER.MAKETIMER \SETUPTIMERmacrofn SETUPTIMER.DATE SETUPTIMER
\CanonicalizeTimerUnits TIMEREXPIRED?)
(MACROS TIMER.MAKESAFETIMER \MACRO.MX.FOR.MISC \TIMER.PLUS \TIMER.IN.TICKS
EXPAND.SETUPTIMER CANONICAL.TIMERUNITS.FOR.MISC SETUPTIMER.DATE
\TIMER.TIMERP \TIMER.MAKETIMER \TIMER.IN.SECONDS \TIMER.IN.MILLISECONDS
\TIMER.COERCE TIMEREXPIRED?)
previous date: "12-JUN-83 02:03:54" {PHYLUM}<JONL>MISC.;1)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT MISCCOMS)
(RPAQQ MISCCOMS ((FNS ADD1VAR ADDTOVAR APPENDTOVAR APPEND ASSOC ATTACH CHANGEPROP CONSTANTS
CONSTANTEXPRESSIONP COPY DEFINEQ DEFLIST DREMOVE DREVERSE DSUBST EQLENGTH
ERSETQ EVERY GENSYM GENSYM? GETLIS INTERSECTION KWOTE LAST LASTN LCONC LDIFF
LDIFFERENCE LENGTH LISTGET LISTGET1 LISTPUT LISTPUT1 LSUBST MAP MAP2C MAP2CAR
MAPC MAPCAR MAPCON MAPCONC MAPLIST MEMBER NLEFT NLSETQ NOTANY NOTEVERY NTH
PUTASSOC RATOMS REMOVE REVERSE RPT RPTQ FRPTQ SASSOC SAVEDEF SAVEDEF1 SELECT
SELECT1 SELECTC SETQQ SOME STRMEMB SUB1VAR SUBSET SUBST TAILP TCONC TIME UNION)
(DECLARE: DONTEVAL@LOAD DOCOPY (INITVARS (COMPVARMACROHASH NIL)))
(ADDVARS (CONSTANTFOLDFNS PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT
OR AND))
(GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS)
(DECLARE: EVAL@LOADWHEN (NOT (BOUNDP (QUOTE GENNUM)))
DOCOPY
(VARS (GENNUM 10000)
(GENSTR "A0001")))
(ALISTS (PRETTYEQUIVLST SELECTC)
(DWIMEQUIVLST SELECTC))
(BLOCKS (COPY COPY)
(SUBST SUBST)
(DSUBST DSUBST)
(LSUBST LSUBST)
(NIL GENSYM GENSYM? (LINKFNS . T)
(GLOBALVARS GENSTR GENNUM))
(NIL ADD1VAR APPEND ASSOC ATTACH CHANGEPROP DREMOVE DREVERSE EVERY GETLIS
INTERSECTION KWOTE LAST LASTN LCONC LDIFF LDIFFERENCE LENGTH LISTGET LISTGET1
LISTPUT LISTPUT1 MAP MAP2C MAP2CAR MAPC MAPCAR MAPCON MAPCONC MAPLIST MEMBER
NLEFT NOTANY NOTEVERY NTH PUTASSOC RATOMS REMOVE REVERSE RPTQ FRPTQ SASSOC
SAVEDEF SAVEDEF1 SETQQ SOME STRMEMB SUB1VAR SUBSET TAILP TCONC TIME UNION
(LOCALVARS . T))
(NIL ADDTOVAR APPENDTOVAR (LOCALVARS . T)
(GLOBALVARS DFNFLG))
(SELECT SELECT SELECT1))
(COMS * DURATIONCOMS)
(DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (BLKLIBRARY EQUAL)))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA SELECTC SELECT FRPTQ RPTQ DEFINEQ CONSTANTS APPENDTOVAR ADDTOVAR)
(NLAML TIME SUB1VAR SETQQ NLSETQ ERSETQ ADD1VAR)
(LAMA APPEND)))))
(DEFINEQ
(ADD1VAR
(NLAMBDA (ADD1X)
(SET ADD1X (ADD1 (EVAL ADD1X)))))
(ADDTOVAR
(NLAMBDA X (* rmk: " 4-JAN-82 15:45")
(RESETVARS ((DFNFLG DFNFLG))
(COND
((EQ DFNFLG (QUOTE ALLPROP))
(SETQQ DFNFLG PROP)))
(RETURN (PROG (VAR TEM)
(SAVESET (SETQ VAR (CAR X))
(COND
((OR (LISTP (SETQ TEM (GETTOPVAL VAR)))
(CDR X))
(UNION (CDR X)
(LISTP TEM)))
((NEQ TEM (QUOTE NOBIND))
TEM))
T)
(RETURN VAR))))))
(APPENDTOVAR
(NLAMBDA X (* rmk: " 4-JAN-82 15:46")
(RESETVARS ((DFNFLG DFNFLG))
(COND
((EQ DFNFLG (QUOTE ALLPROP))
(SETQQ DFNFLG PROP)))
(RETURN (PROG (VAR TEM)
(SAVESET (SETQ VAR (CAR X))
(COND
((OR (LISTP (SETQ TEM (GETTOPVAL VAR)))
(CDR X))
(UNION (LISTP TEM)
(CDR X)))
((NEQ TEM (QUOTE NOBIND))
TEM))
T)
(RETURN VAR))))))
(APPEND
(LAMBDA L (* lmm " 4-NOV-80 10:31")
(AND (NEQ L 0)
(PROG (VAL (N (SUB1 L))
X Z)
(DECLARE (LOCALVARS VAL N X Z))
(COND
((NEQ N 0)
(SETQ VAL (ARG L L)))
(T (SETQ N 1)))
LP (SETQ X (ARG L N))
(COND
((LISTP X)
(PROG NIL
(SETQ Z (SETQ VAL (CONS (CAR X)
VAL)))
INLP(SETQ X (CDR X))
(COND
((NLISTP X)
(RETURN)))
(FRPLACD Z (SETQ Z (CONS (CAR X)
(CDR Z))))
(GO INLP)))
((NLISTP VAL) (* For compatibility, so that
(APPEND (QUOTE A)) returns A and
(APPEND (QUOTE A) (QUOTE B)) returns B)
(SETQ VAL X)))
(COND
((EQ 0 (SETQ N (SUB1 N)))
(RETURN VAL))
(T (GO LP)))))))
(ASSOC
(LAMBDA (KEY ALST) (* bvm: "20-FEB-81 14:58")
(PROG NIL
LP (COND
((NLISTP ALST)
(RETURN))
((AND (LISTP (CAR ALST))
(EQ (CAAR ALST)
KEY))
(RETURN (CAR ALST))))
(SETQ ALST (CDR ALST))
(GO LP))))
(ATTACH
(LAMBDA (X L)
(COND
((LISTP L)
(FRPLACA (FRPLACD L (CONS (CAR L)
(CDR L)))
X))
((NULL L)
(CONS X))
(T (ERRORX (LIST 4 L))))))
(CHANGEPROP
(LAMBDA (X PROP1 PROP2) (* wt: "31-MAY-79 22:28")
(PROG ((Z (COND
((LITATOM X)
(GETPROPLIST X))
(T (ERRORX (LIST 14 X))))))
LP (RETURN (COND
((NLISTP Z)
NIL)
((EQ (CAR Z)
PROP1)
(FRPLACA Z PROP2)
X)
(T (SETQ Z (CDR (LISTP (CDR Z))))
(GO LP)))))))
(CONSTANTS
(NLAMBDA VARS (* lmm "27-MAY-82 19:20")
(OR COMPVARMACROHASH (SETQ COMPVARMACROHASH (LIST (HARRAY 100))))
(for X in VARS do (COND
((LISTP X)
(PUTHASH (CAR X)
(LIST (QUOTE CONSTANT)
(CADR X))
COMPVARMACROHASH))
(T (PUTHASH X (LIST (QUOTE CONSTANT)
X)
COMPVARMACROHASH))))
VARS))
(CONSTANTEXPRESSIONP
(LAMBDA (FORM) (* lmm "23-NOV-82 09:29")
(COND
((LITATOM FORM)
(COND
((OR (NULL FORM)
(EQ FORM T))
(LIST FORM))
((AND COMPVARMACROHASH (SETQ FORM (GETHASH FORM COMPVARMACROHASH)))
(CONSTANTEXPRESSIONP FORM))))
((LISTP FORM)
(SELECTQ (CAR FORM)
(QUOTE (CDR FORM))
(COND
((FMEMB (CAR FORM)
CONSTANTFOLDFNS)
(for X in (CDR FORM) collect (CAR (OR (CONSTANTEXPRESSIONP X)
(RETURN)))
finally (RETURN (LIST (APPLY (CAR FORM)
$$VAL)))))
(T (PROG ((MAC (GETMACROPROP (CAR FORM)
COMPILERMACROPROPS)))
(RETURN (AND MAC (NOT (EQUAL FORM (SETQ FORM (MACROEXPANSION FORM MAC))))
(CONSTANTEXPRESSIONP FORM))))))))
((NUMBERP FORM)
(LIST FORM)))))
(COPY
(LAMBDA (X) (* lmm "16-FEB-82 22:07")
(COND
((NLISTP X)
X)
(T (PROG (TAIL (VAL (LIST (COPY (CAR X)))))
(SETQ TAIL VAL)
LP (COND
((NLISTP (SETQ X (CDR X)))
(AND X (FRPLACD TAIL X))
(RETURN VAL)))
(FRPLACD TAIL (SETQ TAIL (CONS (COPY (CAR X)))))
(GO LP))))))
(DEFINEQ
(NLAMBDA X
(DEFINE X)))
(DEFLIST
(LAMBDA (L PROP)
(PROG NIL
LOOP(COND
((NLISTP L)
(RETURN)))
(PUTPROP (CAAR L)
PROP
(CADAR L)) (* NOTE: this call to PUTPROP is changed to /PUTPROP
later in the loadup.)
(SETQ L (CDR L))
(GO LOOP))))
(DREMOVE
(LAMBDA (X L)
(COND
((NLISTP L)
NIL)
((EQ X (CAR L))
(COND
((CDR L)
(FRPLACA L (CADR L))
(FRPLACD L (CDDR L))
(DREMOVE X L))))
(T (PROG (Z)
(DECLARE (LOCALVARS Z))
(SETQ Z L)
LP (COND
((NLISTP (CDR L))
(RETURN Z))
((EQ X (CADR L))
(FRPLACD L (CDDR L)))
(T (SETQ L (CDR L))))
(GO LP))))))
(DREVERSE
(LAMBDA (L)
(PROG (Y Z)
(DECLARE (LOCALVARS Y Z))
R1 (COND
((NLISTP (SETQ Y L))
(RETURN Z)))
(SETQ L (CDR L))
(SETQ Z (FRPLACD Y Z))
(GO R1))))
(DSUBST
(LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:10")
(PROG (B)
(COND
((EQ OLD (SETQ B EXPR))
(RETURN (COPY NEW))))
LP (COND
((NLISTP EXPR)
(RETURN B))
((EQUAL OLD (CAR EXPR))
(FRPLACA EXPR (COPY NEW)))
(T (DSUBST NEW OLD (CAR EXPR))))
(COND
((AND OLD (EQ OLD (CDR EXPR)))
(FRPLACD EXPR (COPY NEW))
(RETURN B)))
(SETQ EXPR (CDR EXPR))
(GO LP))))
(EQLENGTH
(LAMBDA (X N)
(* Generated by paatern match. INcluded so user can load code that has been dwimified and or compiled into a
nonclisp system and run it.)
(COND
((ILESSP N 0)
NIL)
((ZEROP N)
(NLISTP X))
(T (AND (LISTP (SETQ X (NTH X N)))
(NLISTP (CDR X)))))))
(ERSETQ
(NLAMBDA (ERSETX)
(ERRORSET ERSETX T)))
(EVERY
(LAMBDA (EVERYX EVERYFN1 EVERYFN2) (* Note that EVERY does not compile open, although SOME
does.)
(PROG NIL
LOOP(COND
((NLISTP EVERYX)
(RETURN T))
((NULL (APPLY* EVERYFN1 (CAR EVERYX)
EVERYX))
(RETURN NIL)))
(SETQ EVERYX (COND
(EVERYFN2 (APPLY* EVERYFN2 EVERYX))
(T (CDR EVERYX))))
(GO LOOP))))
(GENSYM
(LAMBDA (CHAR)
(MKATOM (RPLSTRING (RPLSTRING GENSTR 1 (SETQ GENNUM (ADD1 GENNUM)))
1
(OR CHAR (QUOTE "A"))))))
(GENSYM?
(LAMBDA (X) (* lmm " 1-JUN-81 08:30")
(AND (LITATOM X)
(EQ (NTHCHARCODE X -5)
(CHARCODE A))
(FIXP (NTHCHAR X -4))
(FIXP (NTHCHAR X -3))
(FIXP (NTHCHAR X -2))
(FIXP (NTHCHAR X -1))
T)))
(GETLIS
(LAMBDA (X PROPS) (* wt: "31-MAY-79 22:25")
(PROG ((Z (COND
((LITATOM X)
(GETPROPLIST X))
(T X))))
LP (RETURN (COND
((NLISTP Z)
NIL)
((FMEMB (CAR Z)
PROPS)
Z)
(T (SETQ Z (CDR (LISTP (CDR Z))))
(GO LP)))))))
(INTERSECTION
(LAMBDA (X Y)
(PROG ((R (CONS))
S)
(DECLARE (LOCALVARS R S))
LP (COND
((NLISTP X)
(RETURN (CAR R)))
((COND
((LITATOM (SETQ S (CAR X)))
(AND (FMEMB S Y)
(NULL (FMEMB S (CAR R)))))
(T (AND (MEMBER S Y)
(NULL (MEMBER S (CAR R))))))
(TCONC R S)))
(SETQ X (CDR X))
(GO LP))))
(KWOTE
(LAMBDA (X) (* dcl: 15 SEP 75 15:25)
(COND
((OR (NULL X)
(EQ X T)
(NUMBERP X))
X)
(T (LIST (QUOTE QUOTE)
X)))))
(LAST
(LAMBDA (X)
(PROG (XX)
(DECLARE (LOCALVARS XX))
L (COND
((NLISTP X)
(RETURN XX)))
(SETQ XX X)
(SETQ X (CDR X))
(GO L))))
(LASTN
(LAMBDA (L N)
(PROG (X Y)
(DECLARE (LOCALVARS X Y))
(COND
((NLISTP L)
(RETURN NIL))
((NULL (SETQ X (FNTH L N)))
(RETURN)))
LP (COND
((NULL (SETQ X (CDR X)))
(RETURN (CONS Y L))))
(SETQ Y (NCONC1 Y (CAR L)))
(SETQ L (CDR L))
(GO LP))))
(LCONC
(LAMBDA (PTR X)
(PROG (XX)
(DECLARE (LOCALVARS XX))
(RETURN (COND
((NULL X)
PTR)
((OR (NLISTP X)
(CDR (SETQ XX (LAST X))))
(SETQ XX X)
(GO ERROR))
((NULL PTR)
(CONS X XX))
((NLISTP PTR)
(SETQ XX PTR)
(GO ERROR))
((NULL (CAR PTR))
(FRPLACA (FRPLACD PTR XX)
X))
(T (FRPLACD (CDR PTR)
X)
(FRPLACD PTR XX))))
ERROR
(ERROR (QUOTE "bad argument - LCONC")
XX))))
(LDIFF
(LAMBDA (X Y Z)
(COND
((EQ X Y)
Z)
((AND (NULL Y)
(NULL Z))
X)
(T (PROG (V)
(COND
(Z (SETQ V (CDR (FRPLACD (SETQ V (FLAST Z))
(FRPLACD (CONS (CAR X)
V))))))
(T (SETQ V (SETQ Z (CONS (CAR X))))))
LOOP(SETQ X (CDR X))
(COND
((EQ X Y)
(RETURN Z))
((NULL X)
(RETURN (ERROR (QUOTE "LDIFF: not a tail")
Y))))
(SETQ V (CDR (FRPLACD V (FRPLACD (CONS (CAR X)
V)))))
(GO LOOP))))))
(LDIFFERENCE
(LAMBDA (X Y) (* lmm "31-DEC-78 15:25")
(PROG (VAL)
LP (COND
((OR (NLISTP X)
(NLISTP Y))
(RETURN (ENDCOLLECT VAL X)))
((NOT (MEMBER (CAR Y)
X))
(SETQ Y (CDR Y)))
((MEMBER (CAR X)
Y)
(SETQ X (CDR X)))
(T (SETQ VAL (DOCOLLECT (PROG1 (CAR X)
(SETQ X (CDR X)))
VAL))))
(GO LP))))
(LENGTH
(LAMBDA (X)
(PROG ((N 0))
(DECLARE (LOCALVARS N))
LP (COND
((NLISTP X)
(RETURN N))
(T (SETN N (ADD1 N))
(SETQ X (CDR X))
(GO LP))))))
(LISTGET
(LAMBDA (LST PROP) (* like getp but works on lists, searching them two cdrs
at a time.)
(PROG NIL
LP (COND
((NLISTP LST)
(RETURN))
((EQ (CAR LST)
PROP)
(RETURN (CADR LST))))
(SETQ LST (CDR (LISTP (CDR LST))))
(GO LP))))
(LISTGET1
(LAMBDA (LST PROP) (* Used to be called GET. Like LISTGET but only searches
one cdr at a time.)
(PROG NIL
LP (COND
((NLISTP LST)
(RETURN))
((EQ (CAR LST)
PROP)
(RETURN (CADR LST))))
(SETQ LST (CDR LST))
(GO LP))))
(LISTPUT
(LAMBDA (LST PROP VAL) (* Like PUT but works on lists.
Inverse of LISTGET)
(PROG ((X (OR (LISTP LST)
(ERRORX (LIST 4 LST))))
X0)
LOOP(COND
((NLISTP (CDR X)) (* Odd parity; either (A B C) or
(A B C . D) -
drop thru and add at beginning)
)
((EQ (CAR X)
PROP) (* found it)
(FRPLACA (CDR X)
VAL)
(RETURN VAL))
((LISTP (SETQ X (CDDR (SETQ X0 X))))
(GO LOOP))
((NULL X)
(* Ran out without finding PROP on even parity. add at end If X is not NIL, means ended in a non-list following
even parity, e.g. (A B . C) so drop through and add at front.)
(FRPLACD (CDR X0)
(LIST PROP VAL))
(RETURN VAL)))
ADDFRONT
(FRPLNODE LST PROP (CONS VAL (CONS (CAR LST)
(CDR LST))))
(RETURN VAL))))
(LISTPUT1
(LAMBDA (LST PROP VAL) (* Used to be called PUTL. Like LISTPUT but only
searches one cdr at a time. Inverse of LISTGET1)
(PROG ((X (OR (LISTP LST)
(ERRORX (LIST 4 LST)))))
LP (COND
((NLISTP X) (* Note no checks for lists ending in dotted pairs.)
(RETURN (NCONC LST (LIST PROP VAL))))
((EQ (CAR X)
PROP)
(COND
((CDR X)
(FRPLACA (CDR X)
VAL))
(T (FRPLACD X (LIST VAL))))
(RETURN LST)))
(SETQ X (CDR X))
(GO LP))))
(LSUBST
(LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:11")
(* Substitutes X as a segment for Y in Z. E.g. LSUBST ((A B) Y (X Y Z)) is (X A B Z) not meaningful for Y an atom
and CDR of a list. if X is NIL, operation effectively deletes Y, i.e. produces a copy without Y in it.)
(COND
((NULL EXPR)
NIL)
((NLISTP EXPR)
(COND
((EQ OLD EXPR)
NEW)
(T EXPR)))
((EQUAL OLD (CAR EXPR))
(NCONC (COPY NEW)
(LSUBST NEW OLD (CDR EXPR))))
(T (CONS (LSUBST NEW OLD (CAR EXPR))
(LSUBST NEW OLD (CDR EXPR)))))))
(MAP
(LAMBDA (MAPX MAPFN1 MAPFN2)
(PROG NIL
LP (COND
((NLISTP MAPX)
(RETURN)))
(APPLY* MAPFN1 MAPX)
(SETQ MAPX (COND
(MAPFN2 (APPLY* MAPFN2 MAPX))
(T (CDR MAPX))))
(GO LP))))
(MAP2C
(LAMBDA (MAPX MAPY MAPFN1 MAPFN2)
(PROG NIL
LP (COND
((OR (NLISTP MAPX)
(NLISTP MAPY))
(RETURN)))
(APPLY* MAPFN1 (CAR MAPX)
(CAR MAPY))
(COND
(MAPFN2 (SETQ MAPX (APPLY* MAPFN2 MAPX))
(SETQ MAPY (APPLY* MAPFN2 MAPY)))
(T (SETQ MAPX (CDR MAPX))
(SETQ MAPY (CDR MAPY))))
(GO LP))))
(MAP2CAR
(LAMBDA (MAPX MAPY MAPFN1 MAPFN2)
(PROG (MAPL MAPE)
LP (COND
((OR (NLISTP MAPX)
(NLISTP MAPY))
(RETURN MAPL)))
(SETQ MAPE (CONS (APPLY* MAPFN1 (CAR MAPX)
(CAR MAPY))
MAPE))
(COND
(MAPL (FRPLACD (CDR MAPE)
(FRPLACD MAPE)))
(T (SETQ MAPL MAPE)))
(COND
(MAPFN2 (SETQ MAPY (APPLY* MAPFN2 MAPY))
(SETQ MAPX (APPLY* MAPFN2 MAPX)))
(T (SETQ MAPY (CDR MAPY))
(SETQ MAPX (CDR MAPX))))
(GO LP))))
(MAPC
(LAMBDA (MAPX MAPFN1 MAPFN2)
(PROG NIL
LP (COND
((NLISTP MAPX)
(RETURN)))
(APPLY* MAPFN1 (CAR MAPX))
(SETQ MAPX (COND
(MAPFN2 (APPLY* MAPFN2 MAPX))
(T (CDR MAPX))))
(GO LP))))
(MAPCAR
(LAMBDA (MAPX MAPFN1 MAPFN2)
(PROG (MAPL MAPE)
LP (COND
((NLISTP MAPX)
(RETURN MAPL)))
(SETQ MAPE (CONS (APPLY* MAPFN1 (CAR MAPX))
MAPE))
(COND
(MAPL (FRPLACD (CDR MAPE)
(FRPLACD MAPE)))
(T (SETQ MAPL MAPE)))
(SETQ MAPX (COND
(MAPFN2 (APPLY* MAPFN2 MAPX))
(T (CDR MAPX))))
(GO LP))))
(MAPCON
(LAMBDA (MAPX MAPFN1 MAPFN2)
(PROG (MAPL MAPE MAPY)
LP (COND
((NLISTP MAPX)
(RETURN MAPL))
((LISTP (SETQ MAPY (APPLY* MAPFN1 MAPX)))
(COND
(MAPE (FRPLACD MAPE MAPY))
(T (SETQ MAPL (SETQ MAPE MAPY))))
(PROG NIL
LP (COND
((SETQ MAPY (CDR MAPE))
(SETQ MAPE MAPY)
(GO LP))))))
(SETQ MAPX (COND
(MAPFN2 (APPLY* MAPFN2 MAPX))
(T (CDR MAPX))))
(GO LP))))
(MAPCONC
(LAMBDA (MAPX MAPFN1 MAPFN2)
(PROG (MAPL MAPE MAPY)
LP (COND
((NLISTP MAPX)
(RETURN MAPL))
((LISTP (SETQ MAPY (APPLY* MAPFN1 (CAR MAPX))))
(COND
(MAPE (FRPLACD MAPE MAPY))
(T (SETQ MAPL (SETQ MAPE MAPY))))
(PROG NIL
LP (COND
((SETQ MAPY (CDR MAPE))
(SETQ MAPE MAPY)
(GO LP))))))
(SETQ MAPX (COND
(MAPFN2 (APPLY* MAPFN2 MAPX))
(T (CDR MAPX))))
(GO LP))))
(MAPLIST
(LAMBDA (MAPX MAPFN1 MAPFN2)
(PROG (MAPL MAPE)
LP (COND
((NLISTP MAPX)
(RETURN MAPL)))
(SETQ MAPE (CONS (APPLY* MAPFN1 MAPX)
MAPE))
(COND
(MAPL (FRPLACD (CDR MAPE)
(FRPLACD MAPE)))
(T (SETQ MAPL MAPE)))
(SETQ MAPX (COND
(MAPFN2 (APPLY* MAPFN2 MAPX))
(T (CDR MAPX))))
(GO LP))))
(MEMBER
(LAMBDA (X Y)
(PROG NIL
LP (RETURN (COND
((NLISTP Y)
NIL)
((COND
((LITATOM X)
(EQ X (CAR Y)))
(T (EQUAL X (CAR Y))))
Y)
(T (SETQ Y (CDR Y))
(GO LP)))))))
(NLEFT
(LAMBDA (L N TAIL) (* bvm: " 1-FEB-83 17:20")
(* Returns TAIL of L containing N elements more than TAIL, e.g. if TAIL is NIL (the usual case) NLEFT
((A B C D E) 2) is (D E). If FOO is (A B C D E) and FIE is (CDDDR FOO), (NLEFT FOO 1 FIE) is
(C D E).)
(PROG ((X L)
(Y L))
LP (COND
((ZEROP N)
(GO LP1))
((OR (EQ X TAIL)
(NLISTP X))
(RETURN NIL)))
(SETQ X (CDR X))
(SUB1VAR N)
(GO LP)
LP1 (COND
((OR (EQ X TAIL)
(NLISTP X))
(RETURN Y)))
(SETQ X (CDR X))
(SETQ Y (CDR Y))
(GO LP1))))
(NLSETQ
(NLAMBDA (NLSETX)
(ERRORSET NLSETX NIL)))
(NOTANY
(LAMBDA (SOMEX SOMEFN1 SOMEFN2)
(NULL (SOME SOMEX SOMEFN1 SOMEFN2))))
(NOTEVERY
(LAMBDA (EVERYX EVERYFN1 EVERYFN2)
(NULL (EVERY EVERYX EVERYFN1 EVERYFN2))))
(NTH
(LAMBDA (X N)
(COND
((IGREATERP 1 N)
(CONS NIL X))
(T (PROG NIL
LP (COND
((NOT (IGREATERP N 1))
(RETURN X))
((NLISTP X)
(RETURN NIL)))
(SETQ X (CDR X))
(SETQ N (SUB1 N))
(GO LP))))))
(PUTASSOC
(LAMBDA (KEY VAL ALST) (* lmm: 5 SEP 75 119)
(PROG ((X (OR (LISTP ALST)
(ERRORX (LIST 4 ALST)))))
(DECLARE (LOCALVARS X))
LP (COND
((EQ (CAR (OR (LISTP (CAR X))
(GO NEXT)))
KEY)
(FRPLACD (CAR X)
VAL)
(RETURN VAL)))
NEXT(SETQ X (OR (LISTP (CDR X))
(PROGN (FRPLACD X (LIST (CONS KEY VAL)))
(RETURN VAL))))
(GO LP))))
(RATOMS
(LAMBDA (A FILE RDTBL)
(PROG (L X)
B (COND
((EQ (SETQ X (RATOM FILE RDTBL))
A)
(RETURN (CAR L)))
((SETQ L (TCONC L X))
(GO B))))))
(REMOVE
(LAMBDA (X L)
(COND
((NLISTP L)
NIL)
((EQUAL X (CAR L))
(REMOVE X (CDR L)))
(T (CONS (CAR L)
(REMOVE X (CDR L)))))))
(REVERSE
(LAMBDA (L)
(PROG (U)
(DECLARE (LOCALVARS U))
LOOP(COND
((NLISTP L)
(RETURN U)))
(SETQ U (CONS (CAR L)
U))
(SETQ L (CDR L))
(GO LOOP))))
(RPT
(LAMBDA (RPTN RPTF)
(PROG (RPTV)
(DECLARE (LOCALVARS RPTV))
LP (COND
((IGREATERP RPTN 0)
(SETQ RPTV (EVAL RPTF (QUOTE INTERNAL)))
(SETQ RPTN (SUB1 RPTN))
(GO LP))
(T (RETURN RPTV))))))
(RPTQ
(NLAMBDA RPTZ
(PROG ((RPTN (EVAL (CAR RPTZ)
(QUOTE INTERNAL)))
RPTV)
(DECLARE (SPECVARS RPTN))
RPTQLOOP
(COND
((IGREATERP RPTN 0)
(SETQ RPTV (APPLY (FUNCTION PROGN)
(CDR RPTZ)
(QUOTE INTERNAL)))
(SETQ RPTN (SUB1 RPTN))
(GO RPTQLOOP)))
(RETURN RPTV))))
(FRPTQ
(NLAMBDA RPTZ
(DECLARE (LOCALVARS . T))
(PROG ((RPTN (EVAL (CAR RPTZ)
(QUOTE INTERNAL)))
RPTV)
RPTQLOOP
(COND
((IGREATERP RPTN 0)
(SETQ RPTV (APPLY (FUNCTION PROGN)
(CDR RPTZ)
(QUOTE INTERNAL)))
(SETQ RPTN (SUB1 RPTN))
(GO RPTQLOOP)))
(RETURN RPTV))))
(SASSOC
(LAMBDA (KEY ALST)
(PROG NIL
LP (COND
((NLISTP ALST)
(RETURN NIL))
((EQUAL (CAAR ALST)
KEY)
(RETURN (CAR ALST))))
(SETQ ALST (CDR ALST))
(GO LP))))
(SAVEDEF
(LAMBDA (X)
(COND
((ATOM X)
(SAVEDEF1 X))
(T (MAPCAR X (FUNCTION SAVEDEF1))))))
(SAVEDEF1
(LAMBDA (X)
(PROG ((DF (GETD X)))
(RETURN (COND
(DF (PUTPROP X (SETQ X (SELECTQ (FNTYP X)
((SUBR SUBR* FSUBR FSUBR*)
(QUOTE SUBR))
((EXPR EXPR* FEXPR FEXPR*)
(QUOTE EXPR))
((CEXPR CEXPR* CFEXPR CFEXPR*)
(QUOTE CODE))
(COND
((EXPRP X)
(QUOTE EXPR))
(T (QUOTE LIST)))))
DF) (* NOTE: this call to PUTPROP is changed to /PUTPROP
later in the loadup.)
X))))))
(SELECT
(NLAMBDA .SELEC.
(DECLARE (LOCALVARS . T)) (* dcl: 12 Dec 78 09:08)
(APPLY (QUOTE PROGN)
(SELECT1 (EVAL (CAR .SELEC.)
(QUOTE SELECTQ))
(CDR .SELEC.))
(QUOTE SELECTQ))))
(SELECT1
(LAMBDA (M L)
(DECLARE (LOCALVARS . T)) (* edited: 8 Dec 78 13:53)
(PROG (C A)
LP (SETQ C L)
(COND
((NULL (SETQ L (CDR L)))
(RETURN C))
((NLISTP (CAR (SETQ C (CAR C))))
(AND (EQ M (EVAL (CAR C)
(QUOTE INTERNAL)))
(RETURN (CDR C)))
(GO LP)))
(SETQ A (CAR C))
L2 (COND
((EQ M (EVAL (CAR A)
(QUOTE INTERNAL)))
(RETURN (CDR C)))
((LISTP (SETQ A (CDR A)))
(GO L2))
(T (GO LP))))))
(SELECTC
(NLAMBDA SELCQ (* lmm "28-FEB-82 16:07")
(DECLARE (LOCALVARS . T))
(APPLY (QUOTE PROGN)
((LAMBDA (M L)
(PROG (C TL)
LP (SETQ C L)
(COND
((NULL (SETQ L (CDR L)))
(RETURN C))
((OR (EQ (SETQ TL (EVAL (CAR (SETQ C (CAR C)))
(QUOTE INTERNAL)))
M)
(AND (LISTP TL)
(FMEMB M TL)))
(RETURN (CDR C))))
(GO LP)))
(EVAL (CAR SELCQ)
(QUOTE SELECTQ))
(CDR SELCQ))
(QUOTE SELECTQ))))
(SETQQ
(NLAMBDA (X Y)
(SET X Y)))
(SOME
(LAMBDA (SOMEX SOMEFN1 SOMEFN2) (* SOME compiles open.)
(PROG NIL
LOOP(COND
((NLISTP SOMEX)
(RETURN NIL))
((APPLY* SOMEFN1 (CAR SOMEX)
SOMEX)
(RETURN SOMEX)))
(SETQ SOMEX (COND
(SOMEFN2 (APPLY* SOMEFN2 SOMEX))
(T (CDR SOMEX))))
(GO LOOP))))
(STRMEMB
(LAMBDA (X Y) (* rmk: " 6-JUN-82 15:08")
(PROG (C N)
(DECLARE (LOCALVARS C N))
(SETQ Y (SUBSTRING Y 1))
B (SETQ N 1)
A (COND
((NULL (SETQ C (NTHCHARCODE X N)))
(RETURN Y)))
(COND
((EQ C (NTHCHARCODE Y N))
(SETQ N (ADD1 N))
(GO A)))
(COND
((NULL (GNC Y))
(RETURN))
(T (GO B))))))
(SUB1VAR
(NLAMBDA (SUB1X)
(SET SUB1X (SUB1 (EVAL SUB1X)))))
(SUBSET
(LAMBDA (MAPX MAPFN1 MAPFN2)
(PROG (MAPL MAPE)
LP (COND
((NLISTP MAPX)
(RETURN MAPL))
((APPLY* MAPFN1 (CAR MAPX))
(COND
((NULL MAPL)
(SETQ MAPL (SETQ MAPE (CONS (CAR MAPX)))))
(T (SETQ MAPE (CDR (FRPLACD MAPE (FRPLACD (CONS (CAR MAPX)
MAPE)))))
(* Eseentially an open TCONC.)
))))
(SETQ MAPX (COND
(MAPFN2 (APPLY* MAPFN2 MAPX))
(T (CDR MAPX))))
(GO LP))))
(SUBST
(LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:11")
(COND
((NULL EXPR)
NIL)
((NLISTP EXPR)
(COND
((EQ OLD EXPR)
(COPY NEW))
(T EXPR)))
(T (CONS (COND
((EQUAL OLD (CAR EXPR))
(COPY NEW))
(T (SUBST NEW OLD (CAR EXPR))))
(SUBST NEW OLD (CDR EXPR)))))))
(TAILP
(LAMBDA (X Y) (* True if X is A tail of Y X and Y non-null.)
(* Included with editor for block compilation purposes.)
(AND X (PROG NIL
LP (COND
((NLISTP Y)
(RETURN NIL))
((EQ X Y)
(RETURN X)))
(SETQ Y (CDR Y))
(GO LP)))))
(TCONC
(LAMBDA (PTR X)
(PROG (XX)
(DECLARE (LOCALVARS XX))
(RETURN (COND
((NULL PTR)
(CONS (SETQ XX (CONS X NIL))
XX))
((NLISTP PTR)
(ERROR (QUOTE "bad argument - TCONC")
PTR))
((NULL (CDR PTR))
(FRPLACA PTR (CONS X NIL))
(FRPLACD PTR (CAR PTR)))
(T (FRPLACD PTR (CDR (FRPLACD (CDR PTR)
(FRPLACD (CONS X (CDR PTR))))))))))))
(TIME
(NLAMBDA (TIMEX TIMEN TIMETYP)
(* If TIMETYP is 0, also prints real time, i.e. (CLOCK 0) if timetype is 3, does garbage collection time.
If timetype is T does PAGEFAULTS.)
(* Calls to prin1, terpri, print, and spaces changed to
correspoding lispx printing functions later in loadup.)
(PROG (TIMEY TIMECNS TIMEM TIMECLK1 TIMECLK2 TIMEZ)
(COND
((NULL TIMEN)
(SETQ TIMEN 1))
((MINUSP TIMEN)
(RETURN (CONS TIMEN (QUOTE (- ?)))))
((NOT (SMALLP TIMEN))
(RETURN (CONS TIMEN (QUOTE (is too large))))))
(SETQ TIMEM TIMEN)
(SETQ TIMECNS (CONSCOUNT))
(SETQ TIMEZ (SELECTQ TIMETYP
(0 (CLOCK 0))
(3 (CLOCK 3))
(T (PAGEFAULTS))
NIL))
(SETQ TIMECLK1 (CLOCK 2))
T1 (COND
((NEQ TIMEM 0)
(SETQ TIMEY (EVAL TIMEX))
(SUB1VAR TIMEM)
(GO T1)))
(SETQ TIMECLK2 (CLOCK 2))
(AND TIMEZ (SETQ TIMEZ (IDIFFERENCE (SELECTQ TIMETYP
(0 (CLOCK 0))
(3 (CLOCK 3))
(T (PAGEFAULTS))
(ERROR TIMETYP))
TIMEZ)))
(SETQ TIMECNS (IDIFFERENCE (CONSCOUNT)
TIMECNS))
(COND
((NEQ TIMEN 1)
(PRIN1 TIMECNS T)
(PRIN1 (QUOTE /)
T)
(PRIN1 TIMEN T)
(PRIN1 (QUOTE " = ")
T)))
(PRIN1 (IQUOTIENT TIMECNS TIMEN)
T)
(SPACES 1 T)
(PRINT (QUOTE conses)
T)
(SETQ TIMEM (FQUOTIENT (IPLUS TIMECLK2 (IMINUS TIMECLK1))
1000))
(COND
((NEQ TIMEN 1)
(PRIN1 TIMEM T)
(PRIN1 (QUOTE /)
T)
(PRIN1 TIMEN T)
(PRIN1 (QUOTE " = ")
T)))
(PRIN1 (FQUOTIENT TIMEM TIMEN)
T)
(SPACES 1 T)
(PRINT (QUOTE seconds)
T)
(SELECTQ TIMETYP
(0 (PRIN1 (FQUOTIENT TIMEZ 1000)
T)
(PRIN1 (QUOTE " seconds, real time
")
T))
(3 (PRIN1 (FQUOTIENT TIMEZ 1000)
T)
(PRIN1 (QUOTE " seconds, garbage collection time
")
T))
(T (PRIN1 TIMEZ T)
(PRIN1 (QUOTE " page faults
")
T))
NIL)
(RETURN TIMEY))))
(UNION
(LAMBDA (X Y)
(DECLARE (LOCALVARS . T)) (* lmm "31-DEC-78 14:47")
(PROG (VAL)
LP (COND
((NLISTP X)
(RETURN (ENDCOLLECT VAL Y)))
((COND
((LITATOM (CAR X))
(NOT (FMEMB (CAR X)
Y)))
(T (NOT (MEMBER (CAR X)
Y))))
(SETQ VAL (DOCOLLECT (CAR X)
VAL))))
(SETQ X (CDR X))
(GO LP))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ? COMPVARMACROHASH NIL)
)
(ADDTOVAR CONSTANTFOLDFNS PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT OR AND)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS)
)
(DECLARE: EVAL@LOADWHEN (NOT (BOUNDP (QUOTE GENNUM))) DOCOPY
(RPAQQ GENNUM 10000)
(RPAQ GENSTR "A0001")
)
(ADDTOVAR PRETTYEQUIVLST (SELECTC . SELECTQ))
(ADDTOVAR DWIMEQUIVLST (SELECTC . SELECTQ))
[DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY
(BLOCK: COPY COPY)
(BLOCK: SUBST SUBST)
(BLOCK: DSUBST DSUBST)
(BLOCK: LSUBST LSUBST)
(BLOCK: NIL GENSYM GENSYM? (LINKFNS . T)
(GLOBALVARS GENSTR GENNUM))
(BLOCK: NIL ADD1VAR APPEND ASSOC ATTACH CHANGEPROP DREMOVE DREVERSE EVERY GETLIS INTERSECTION KWOTE
LAST LASTN LCONC LDIFF LDIFFERENCE LENGTH LISTGET LISTGET1 LISTPUT LISTPUT1 MAP MAP2C MAP2CAR
MAPC MAPCAR MAPCON MAPCONC MAPLIST MEMBER NLEFT NOTANY NOTEVERY NTH PUTASSOC RATOMS REMOVE
REVERSE RPTQ FRPTQ SASSOC SAVEDEF SAVEDEF1 SETQQ SOME STRMEMB SUB1VAR SUBSET TAILP TCONC TIME
UNION (LOCALVARS . T))
(BLOCK: NIL ADDTOVAR APPENDTOVAR (LOCALVARS . T)
(GLOBALVARS DFNFLG))
(BLOCK: SELECT SELECT SELECT1)
]
(RPAQQ DURATIONCOMS ((* DURATION and TIMER things)
(DECLARE: EVAL@COMPILE DONTCOPY (* Next few are mostly just to make the
functions TIMEREXPIRED? and SETUPTIMER are
"machine independent")
(MACROS TIMER.MAKESAFETIMER TIMER.TIMEREXPIRED? EXPAND.SETUPTIMER)
(* Next few are because MISC must be compilable in a vanilla Lisp)
(MACROS CANONICAL.TIMERUNITS.FOR.MISC \MACRO.MX.FOR.MISC)
(* Following macro needn't be installed since the function call is
fairly slow anyway)
(MACROS SETUPTIMER.DATE)
(* Following due to stupid Interlossp lissage!)
(FNS \SETUPTIMERmacrofn))
(DECLARE: EVAL@COMPILEWHEN (EQ (COMPILEMODE)
(QUOTE PDP-10))
COPYWHEN
(EQ (COMPILEMODE)
(QUOTE PDP-10))
(MACROS CLOCK IDATE)
(INITVARS (\RCLKMILLISECONDS 1)
(\RCLKSECONDS 1000)))
(COMS (* Following macros distinguish between a compile target of Interlisp-D
and other Interlisps)
(MACROS \TIMER.TIMERP \TIMER.MAKETIMER \TIMER.PLUS \TIMER.IN.SECONDS
\TIMER.IN.MILLISECONDS \TIMER.IN.TICKS)
(* Following functions are temporary, until their instances are
macro-compiled out in \DURATIONTRAN)
(FNS \TIMER.TIMERP \TIMER.MAKETIMER))
(MACROS SETUPTIMER TIMEREXPIRED?)
(FNS \SETUPTIMERmacrofn \CanonicalizeTimerUnits)
(FNS SETUPTIMER SETUPTIMER.DATE TIMEREXPIRED?)
(VARS (\TIMEREXPIRED.BOX (SETUPTIMER 0)))
(GLOBALVARS \TIMEREXPIRED.BOX)
(PROP GLOBALVAR \RCLKMILLISECOND \RCLKSECOND)))
(* DURATION and TIMER things)
(DECLARE: EVAL@COMPILE DONTCOPY
(* Next few are mostly just to make the functions TIMEREXPIRED? and SETUPTIMER are
"machine independent")
(DECLARE: EVAL@COMPILE
(PUTPROPS TIMER.MAKESAFETIMER DMACRO (OPENLAMBDA (TIMER BOX)
(\PUTBASEFIXP BOX 0 TIMER)
BOX))
(PUTPROPS TIMER.MAKESAFETIMER MACRO ((TIMER BOX)
(PROG1 TIMER BOX)))
(PUTPROPS TIMER.TIMEREXPIRED? MACRO ((OLDTIMER INTERVAL)
(IGEQ (IDIFFERENCE OLDTIMER INTERVAL)
0)))
(PUTPROPS TIMER.TIMEREXPIRED? DMACRO ((OLDTIMER INTERVAL)
(UNINTERRUPTABLY
(IGEQ (\BOXIDIFFERENCE OLDTIMER INTERVAL)
0))))
(PUTPROPS EXPAND.SETUPTIMER MACRO (L
(\SETUPTIMERmacrofn L T)))
)
(* Next few are because MISC must be compilable in a vanilla Lisp)
(DECLARE: EVAL@COMPILE
(PUTPROPS CANONICAL.TIMERUNITS.FOR.MISC MACRO (OPENLAMBDA (X)
(* Checks for common abbreviations before calling
\CanonicalizeTimerUnits)
(SELECTQ X
((TICKS MILLISECONDS SECONDS) (* These are the canonical forms)
X)
((TICS)
(QUOTE TICKS))
((NIL MS MILLISECS)
(QUOTE MILLISECONDS))
((SECS)
(QUOTE SECONDS))
(\CanonicalizeTimerUnits X))))
(PUTPROPS \MACRO.MX.FOR.MISC MACRO (Z
(PROG ((X (EXPANDMACRO (CAR Z)
T)))
(COND
((EQ X (CAR Z))
(ERROR "No macro property -- \MACRO.MX" X))
(T (RETURN X))))))
)
(* Following macro needn't be installed since the function call is fairly slow anyway)
(DECLARE: EVAL@COMPILE
(PUTPROPS SETUPTIMER.DATE MACRO ((DTS TIMER)
(SETUPTIMER (IDIFFERENCE (IDATE DTS)
(IDATE))
TIMER
(QUOTE SECONDS))))
)
(* Following due to stupid Interlossp lissage!)
(DEFINEQ
(\SETUPTIMERmacrofn
(LAMBDA (X NOERRORCHKS) (* JonL "12-JUN-83 02:43")
(PROG ((INTERVALFORM (CAR X))
(TIMERFORM (CADR X))
(TimerUnits (CONSTANTEXPRESSIONP (CADDR X)))
(IntervalUnits (CONSTANTEXPRESSIONP (CADDDR X)))
(CLOCKFNNAME))
(if (OR (NULL TimerUnits)
(NULL IntervalUnits))
then (* If either of the units are true computibles, then we
can't select clock functions at macroexpansion time.)
(RETURN (QUOTE IGNOREMACRO)))
(SETQ TimerUnits (CANONICAL.TIMERUNITS.FOR.MISC (CAR TimerUnits)))
(SETQ IntervalUnits (if (NULL (CAR IntervalUnits))
then TimerUnits
else (CANONICAL.TIMERUNITS.FOR.MISC (CAR IntervalUnits))))
(* Notice how the following SELECTQ may also modify the code expression for the INTERVALFORM to do any necessary
transformations between the specifiend timer units and the specified interval units.)
(SETQ CLOCKFNNAME (SELECTQ TimerUnits
((TICKS)
(SELECTQ IntervalUnits
((MILLISECONDS)
(SETQ INTERVALFORM (BQUOTE (ITIMES , INTERVALFORM
\RCLKMILLISECOND))))
((SECONDS)
(SETQ INTERVALFORM (BQUOTE (ITIMES , INTERVALFORM
\RCLKSECOND))))
NIL)
(QUOTE \TIMER.IN.TICKS))
((MILLISECONDS)
(SELECTQ IntervalUnits
(TICKS (SETQ INTERVALFORM
(BQUOTE (IQUOTIENT , INTERVALFORM
\RCLKMILLISECOND))))
(SECONDS (SETQ INTERVALFORM
(BQUOTE (ITIMES , INTERVALFORM 1000))))
NIL)
(QUOTE \TIMER.IN.MILLISECONDS))
((SECONDS)
(SELECTQ IntervalUnits
(MILLISECONDS (SETQ INTERVALFORM
(BQUOTE (IQUOTIENT , INTERVALFORM
1000))))
(TICKS (SETQ INTERVALFORM
(BQUOTE (IQUOTIENT , INTERVALFORM
\RCLKSECOND))))
NIL)
(QUOTE \TIMER.IN.SECONDS))
(SHOULDNT)))
(if (NOT NOERRORCHKS)
then (SETQ TIMERFORM (if (CONSTANTEXPRESSIONP TIMERFORM)
then (QUOTE (\TIMER.MAKETIMER))
else ((LAMBDA (FORM)
(if (NLISTP TIMERFORM)
then (SUBST TIMERFORM (QUOTE Timer?)
FORM)
else (BQUOTE ((LAMBDA (Timer?)
(DECLARE (LOCALVARS Timer?))
, FORM)
, TIMERFORM))))
(QUOTE (COND ((\TIMER.TIMERP Timer?)
Timer?)
(T (\TIMER.MAKETIMER))))))))
(RETURN (BQUOTE (\TIMER.PLUS (, CLOCKFNNAME , TIMERFORM)
, INTERVALFORM))))))
)
)
(DECLARE: EVAL@COMPILEWHEN (EQ (COMPILEMODE)
(QUOTE PDP-10)) COPYWHEN (EQ (COMPILEMODE)
(QUOTE PDP-10))
(DECLARE: EVAL@COMPILE
(PUTPROPS CLOCK 10MACRO (X
(SELECTQ (CAR X)
(0 (QUOTE (LOC (ASSEMBLE NIL
(JSYS 14Q)))))
(3 (QUOTE (LOC (ASSEMBLE NIL
(MOVE 1 , GCTIM)))))
(QUOTE IGNOREMACRO))))
(PUTPROPS IDATE 10MACRO (X
(COND
((NULL (CAR X))
(QUOTE (LOC (ASSEMBLE NIL
(JSYS 227Q)))))
(T (QUOTE IGNOREMACRO)))))
)
(RPAQ? \RCLKMILLISECONDS 1)
(RPAQ? \RCLKSECONDS 1000)
)
(* Following macros distinguish between a compile target of Interlisp-D and other Interlisps)
(DECLARE: EVAL@COMPILE
(PUTPROPS \TIMER.TIMERP MACRO ((X) (FIXP X)))
(PUTPROPS \TIMER.TIMERP DMACRO ((X)
(TYPENAMEP X (QUOTE FIXP))))
(PUTPROPS \TIMER.MAKETIMER MACRO (NIL
(IPLUS 1000000)))
(PUTPROPS \TIMER.MAKETIMER DMACRO (NIL
(NCREATE (QUOTE FIXP))))
(PUTPROPS \TIMER.PLUS MACRO ((OLDTIMER INTERVAL)
(IPLUS OLDTIMER INTERVAL)))
(PUTPROPS \TIMER.PLUS DMACRO ((OLDTIMER INTERVAL)
(\BOXIPLUS OLDTIMER INTERVAL)))
(PUTPROPS \TIMER.IN.SECONDS MACRO ((OLDTIMER)
(IQUOTIENT (CLOCK 0 OLDTIMER)
1000)))
(PUTPROPS \TIMER.IN.SECONDS DMACRO ((OLDTIMER)
(\DAYTIME0 OLDTIMER)))
(PUTPROPS \TIMER.IN.MILLISECONDS MACRO ((OLDTIMER)
(CLOCK 0 OLDTIMER)))
(PUTPROPS \TIMER.IN.MILLISECONDS DMACRO ((OLDTIMER)
(\CLOCK0 OLDTIMER)))
(PUTPROPS \TIMER.IN.TICKS MACRO ((OLDTIMER)
(CLOCK 0 OLDTIMER)))
(PUTPROPS \TIMER.IN.TICKS DMACRO ((OLDTIMER)
(\RCLOCK0 OLDTIMER)))
)
(* Following functions are temporary, until their instances are macro-compiled out in
\DURATIONTRAN)
(DEFINEQ
(\TIMER.TIMERP
(LAMBDA (X) (* JonL "12-JUN-83 03:37")
(\MACRO.MX.FOR.MISC (\TIMER.TIMERP X))))
(\TIMER.MAKETIMER
(LAMBDA (X) (* JonL "12-JUN-83 03:37")
(\MACRO.MX.FOR.MISC (\TIMER.MAKETIMER X))))
)
(DECLARE: EVAL@COMPILE
(PUTPROPS SETUPTIMER MACRO (X
(\SETUPTIMERmacrofn X)))
(PUTPROPS TIMEREXPIRED? MACRO (X
((LAMBDA (UNITS)
(COND
((OR (NULL UNITS)
(FMEMB (CAR UNITS)
(QUOTE (TICKS MILLISECONDS SECONDS)))
(\TIMER.TIMERP (CAR UNITS)))
(QUOTE IGNOREMACRO))
(T (BQUOTE (TIMEREXPIRED? , (CAR X)
(QUOTE , (\CanonicalizeTimerUnits (CAR UNITS))))))))
(CONSTANTEXPRESSIONP (CADR X)))))
)
(DEFINEQ
(\SETUPTIMERmacrofn
(LAMBDA (X NOERRORCHKS) (* JonL "12-JUN-83 02:43")
(PROG ((INTERVALFORM (CAR X))
(TIMERFORM (CADR X))
(TimerUnits (CONSTANTEXPRESSIONP (CADDR X)))
(IntervalUnits (CONSTANTEXPRESSIONP (CADDDR X)))
(CLOCKFNNAME))
(if (OR (NULL TimerUnits)
(NULL IntervalUnits))
then (* If either of the units are true computibles, then we
can't select clock functions at macroexpansion time.)
(RETURN (QUOTE IGNOREMACRO)))
(SETQ TimerUnits (CANONICAL.TIMERUNITS.FOR.MISC (CAR TimerUnits)))
(SETQ IntervalUnits (if (NULL (CAR IntervalUnits))
then TimerUnits
else (CANONICAL.TIMERUNITS.FOR.MISC (CAR IntervalUnits))))
(* Notice how the following SELECTQ may also modify the code expression for the INTERVALFORM to do any necessary
transformations between the specifiend timer units and the specified interval units.)
(SETQ CLOCKFNNAME (SELECTQ TimerUnits
((TICKS)
(SELECTQ IntervalUnits
((MILLISECONDS)
(SETQ INTERVALFORM (BQUOTE (ITIMES , INTERVALFORM
\RCLKMILLISECOND))))
((SECONDS)
(SETQ INTERVALFORM (BQUOTE (ITIMES , INTERVALFORM
\RCLKSECOND))))
NIL)
(QUOTE \TIMER.IN.TICKS))
((MILLISECONDS)
(SELECTQ IntervalUnits
(TICKS (SETQ INTERVALFORM
(BQUOTE (IQUOTIENT , INTERVALFORM
\RCLKMILLISECOND))))
(SECONDS (SETQ INTERVALFORM
(BQUOTE (ITIMES , INTERVALFORM 1000))))
NIL)
(QUOTE \TIMER.IN.MILLISECONDS))
((SECONDS)
(SELECTQ IntervalUnits
(MILLISECONDS (SETQ INTERVALFORM
(BQUOTE (IQUOTIENT , INTERVALFORM
1000))))
(TICKS (SETQ INTERVALFORM
(BQUOTE (IQUOTIENT , INTERVALFORM
\RCLKSECOND))))
NIL)
(QUOTE \TIMER.IN.SECONDS))
(SHOULDNT)))
(if (NOT NOERRORCHKS)
then (SETQ TIMERFORM (if (CONSTANTEXPRESSIONP TIMERFORM)
then (QUOTE (\TIMER.MAKETIMER))
else ((LAMBDA (FORM)
(if (NLISTP TIMERFORM)
then (SUBST TIMERFORM (QUOTE Timer?)
FORM)
else (BQUOTE ((LAMBDA (Timer?)
(DECLARE (LOCALVARS Timer?))
, FORM)
, TIMERFORM))))
(QUOTE (COND ((\TIMER.TIMERP Timer?)
Timer?)
(T (\TIMER.MAKETIMER))))))))
(RETURN (BQUOTE (\TIMER.PLUS (, CLOCKFNNAME , TIMERFORM)
, INTERVALFORM))))))
(\CanonicalizeTimerUnits
(LAMBDA (X) (* JonL "11-JUN-83 22:29")
(* Generally, the U-CASE versions have been "beat out" by the CANONICAL.TIMERUNITS.FOR.MISC macro;
but there are ocasional calls to this function directly such, as in \DURATIONTRAN and the TIMEREXPIRED? macro.)
(SELECTQ X
((ticks tics)
(QUOTE TICKS))
((milliseconds NIL ms millisecs)
(QUOTE MILLISECONDS))
((seconds secs)
(QUOTE SECONDS))
(PROG ((Y X)
CONVERTEDP)
A (RETURN (SELECTQ Y
((TICKS TICS)
(QUOTE TICKS))
((MILLISECONDS MS MILLISECS)
(QUOTE MILLISECONDS))
((SECONDS SECS)
(QUOTE SECONDS))
(if (NOT CONVERTEDP)
then (SETQ Y (U-CASE Y))
(SETQ CONVERTEDP T)
(GO A)
else (ERROR (QUOTE Invalid% arg% for% timer% units)
X))))))))
)
(DEFINEQ
(SETUPTIMER
(LAMBDA (INTERVAL OldTimer? timerUnits intervalUnits) (* JonL "12-JUN-83 00:32")
(SETQ INTERVAL (IPLUS INTERVAL 0)) (* If an error or coercion is to occur on this one, do
it before the call to the clock-funciton)
(if (NOT (\TIMER.TIMERP OldTimer?))
then (SETQ OldTimer? (\TIMER.MAKETIMER)))
(SETQ timerUnits (CANONICAL.TIMERUNITS.FOR.MISC timerUnits))
(SETQ intervalUnits (if (NULL intervalUnits)
then timerUnits
else (CANONICAL.TIMERUNITS.FOR.MISC intervalUnits)))
(* Notice that in each wing of the SELECTQ below, the
modification to INTERVAL is done before the
clock-function call implicit in SETUPTIMER)
(SELECTQ timerUnits
((TICKS)
(SELECTQ intervalUnits
((MILLISECONDS)
(SETQ INTERVAL (ITIMES \RCLKMILLISECOND INTERVAL)))
((SECONDS)
(SETQ INTERVAL (ITIMES \RCLKSECOND INTERVAL)))
NIL)
(EXPAND.SETUPTIMER INTERVAL OldTimer? (QUOTE TICKS)))
((MILLISECONDS)
(SELECTQ intervalUnits
((TICKS)
(SETQ INTERVAL (IQUOTIENT INTERVAL \RCLKMILLISECOND)))
((SECONDS)
(SETQ INTERVAL (ITIMES 1000 INTERVAL)))
NIL)
(EXPAND.SETUPTIMER INTERVAL OldTimer? (QUOTE MILLISECONDS)))
((SECONDS)
(SELECTQ intervalUnits
((MILLISECONDS)
(SETQ INTERVAL (IQUOTIENT INTERVAL 1000)))
((TICKS)
(SETQ INTERVAL (IQUOTIENT INTERVAL \RCLKSECOND)))
NIL)
(EXPAND.SETUPTIMER INTERVAL OldTimer? (QUOTE SECONDS)))
(SHOULDNT))))
(SETUPTIMER.DATE
(LAMBDA (DTS OldTimer?) (* JonL "11-JUN-83 21:40")
(\MACRO.MX.FOR.MISC (SETUPTIMER.DATE DTS OldTimer?))))
(TIMEREXPIRED?
(LAMBDA (TIMER ClockValue.or.timerUnits) (* JonL "11-JUN-83 22:42")
(if (NOT (\TIMER.TIMERP TIMER))
then (* Do the check out here so that an error won't happen
underneath the UNINTERRUPTABLY)
(ERRORX (LIST 27 TIMER))
elseif (\TIMER.TIMERP ClockValue.or.timerUnits)
then (* Note that in Interlisp-D the TIMER.TIMEREXPIRED?
macro will clobber its first arg.)
(TIMER.TIMEREXPIRED? (TIMER.MAKESAFETIMER ClockValue.or.timerUnits \TIMEREXPIRED.BOX)
TIMER)
else
(* Distribute thru the SELECTQ this way so that Interlisp-10 compiler can optimize out the boxing.
Leave the UNINTERRUPTABLY so that Interlisp-D won't interrupt between putting the value in \TIMEREXPIRED.BOX and
the IGEQ test.)
(SELECTQ (CANONICAL.TIMERUNITS.FOR.MISC ClockValue.or.timerUnits)
((TICKS)
(TIMER.TIMEREXPIRED? (\TIMER.IN.TICKS \TIMEREXPIRED.BOX)
TIMER))
((MILLISECONDS)
(TIMER.TIMEREXPIRED? (\TIMER.IN.MILLISECONDS \TIMEREXPIRED.BOX)
TIMER))
((SECONDS)
(TIMER.TIMEREXPIRED? (\TIMER.IN.SECONDS \TIMEREXPIRED.BOX)
TIMER))
NIL))))
)
(RPAQ \TIMEREXPIRED.BOX (SETUPTIMER 0))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \TIMEREXPIRED.BOX)
)
(PUTPROPS \RCLKMILLISECOND GLOBALVAR T)
(PUTPROPS \RCLKSECOND GLOBALVAR T)
(DECLARE: EVAL@COMPILE DONTCOPY
(ADDTOVAR BLKLIBRARY EQUAL)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA SELECTC SELECT FRPTQ RPTQ DEFINEQ CONSTANTS APPENDTOVAR ADDTOVAR)
(ADDTOVAR NLAML TIME SUB1VAR SETQQ NLSETQ ERSETQ ADD1VAR)
(ADDTOVAR LAMA APPEND)
)
(PUTPROPS MISC COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2661 30273 (ADD1VAR 2671 . 2740) (ADDTOVAR 2742 . 3235) (APPENDTOVAR 3237 . 3733) (
APPEND 3735 . 4596) (ASSOC 4598 . 4914) (ATTACH 4916 . 5088) (CHANGEPROP 5090 . 5467) (CONSTANTS 5469
. 5884) (CONSTANTEXPRESSIONP 5886 . 6740) (COPY 6742 . 7128) (DEFINEQ 7130 . 7172) (DEFLIST 7174 .
7501) (DREMOVE 7503 . 7903) (DREVERSE 7905 . 8131) (DSUBST 8133 . 8654) (EQLENGTH 8656 . 8988) (ERSETQ
8990 . 9047) (EVERY 9049 . 9475) (GENSYM 9477 . 9623) (GENSYM? 9625 . 9897) (GETLIS 9899 . 10233) (
INTERSECTION 10235 . 10630) (KWOTE 10632 . 10840) (LAST 10842 . 11042) (LASTN 11044 . 11392) (LCONC
11394 . 11932) (LDIFF 11934 . 12438) (LDIFFERENCE 12440 . 12884) (LENGTH 12886 . 13091) (LISTGET 13093
. 13445) (LISTGET1 13447 . 13794) (LISTPUT 13796 . 14810) (LISTPUT1 14812 . 15420) (LSUBST 15422 .
16059) (MAP 16061 . 16308) (MAP2C 16310 . 16685) (MAP2CAR 16687 . 17207) (MAPC 17209 . 17463) (MAPCAR
17465 . 17861) (MAPCON 17863 . 18321) (MAPCONC 18323 . 18788) (MAPLIST 18790 . 19181) (MEMBER 19183 .
19415) (NLEFT 19417 . 20113) (NLSETQ 20115 . 20174) (NOTANY 20176 . 20267) (NOTEVERY 20269 . 20369) (
NTH 20371 . 20626) (PUTASSOC 20628 . 21095) (RATOMS 21097 . 21284) (REMOVE 21286 . 21456) (REVERSE
21458 . 21678) (RPT 21680 . 21931) (RPTQ 21933 . 22287) (FRPTQ 22289 . 22638) (SASSOC 22640 . 22862) (
SAVEDEF 22864 . 22983) (SAVEDEF1 22985 . 23535) (SELECT 23537 . 23789) (SELECT1 23791 . 24341) (
SELECTC 24343 . 24891) (SETQQ 24893 . 24936) (SOME 24938 . 25296) (STRMEMB 25298 . 25752) (SUB1VAR
25754 . 25823) (SUBSET 25825 . 26349) (SUBST 26351 . 26720) (TAILP 26722 . 27125) (TCONC 27127 . 27564
) (TIME 27566 . 29853) (UNION 29855 . 30271)) (34926 37629 (\SETUPTIMERmacrofn 34936 . 37627)) (39368
39706 (\TIMER.TIMERP 39378 . 39537) (\TIMER.MAKETIMER 39539 . 39704)) (40149 43816 (\SETUPTIMERmacrofn
40159 . 42850) (\CanonicalizeTimerUnits 42852 . 43814)) (43817 46992 (SETUPTIMER 43827 . 45469) (
SETUPTIMER.DATE 45471 . 45646) (TIMEREXPIRED? 45648 . 46990)))))
STOP