(FILECREATED " 4-OCT-83 03:11:03" {PHYLUM}<LISPCORE>SOURCES>ABASIC.;9 17046
changes to: (FNS NILL TRUE ZERO DUMMYDEF)
(VARS ABASICCOMS)
previous date: "20-JUL-83 12:03:23" {PHYLUM}<LISPCORE>SOURCES>ABASIC.;8)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT ABASICCOMS)
(RPAQQ ABASICCOMS [(FNS EVALQT \SystemERROR)
(FNS NILL EVQ TRUE ZERO DUMMYDEF NOTIMP)
(P (DUMMYDEF (WINDOWWORLDP NILL)))
(FNS EQUAL)
(FNS TYPENAMEP)
(FNS NEQ NULL NOT)
(COMS (* Belong on ACODE except they would clobber 10-versions in ABC)
(FNS LAPRD DEFC CGETD))
(FNS NCONC \NCONC2 \APPEND2 PUTDQ PRINTARRAY SORT MERGE SORT1 PRETTYCOMPRINT FASSOC FLAST
FLENGTH FMEMB FNTH FGETD LIST COUNT)
(FNS CHANGENAME1 CHANGENAME1A)
(FNS CDDR CDAR CADR CAAR CDDDR CDDAR CDADR CDAAR CADDR CADAR CAADR CAAAR CDDDDR CAAAAR CDDDAR
CDDADR CDDAAR CDAAAR CADADR CDADDR CDADAR CAADDR CDAADR CAADAR CADDDR CADAAR CADDAR
CAAADR)
(FNS SYSTEMTYPE)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA DUMMYDEF)
(NLAML PRETTYCOMPRINT PUTDQ)
(LAMA LIST NCONC NOTIMP ZERO TRUE NILL])
(DEFINEQ
(EVALQT
[LAMBDA NIL (* lmm "11-MAR-80 15:57")
(PROG (EVALQTXX)
EVALQTLP
(PRIN1 (QUOTE ←)
T)
(PRINT [COND
((NULL (SETQ EVALQTXX (READ T)))
(GO EVALQTLP))
((OR (LISTP EVALQTXX)
(NULL (READP T)))
(EVAL EVALQTXX))
(T (APPLY EVALQTXX (READ T]
T)
(GO EVALQTLP])
(\SystemERROR
[LAMBDA NIL (* lmm " 6-MAY-80 20:41")
(SELECTQ (GETTOPVAL (QUOTE \SystemErrorVAL))
(0 (RAID))
(1 (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED"))
(RAID])
)
(DEFINEQ
(NILL
[LAMBDA NOBIND (* lmm " 4-OCT-83 03:05")
NIL])
(EVQ
[LAMBDA (X) (* lmm: 26 JUN 75 726)
X])
(TRUE
[LAMBDA NOBIND (* lmm " 4-OCT-83 03:05")
T])
(ZERO
[LAMBDA NOBIND (* lmm " 4-OCT-83 03:05")
0])
(DUMMYDEF
[NLAMBDA LST (* lmm " 4-OCT-83 03:08")
(for X in LST when (NOT (GETD (CAR X))) do (PUTD (CAR X)
(GETD (CADR X))
T])
(NOTIMP
[LAMBDA N (* lmm " 5-MAR-80 20:17")
(HELP "UNIMPLEMENTED FUNCTION"])
)
(DUMMYDEF (WINDOWWORLDP NILL))
(DEFINEQ
(EQUAL
[LAMBDA (X Y) (* rmk: "25-MAY-80 23:12")
(OR (EQ X Y)
(SELECTC (NTYPX X)
[\LISTP (AND (LISTP Y)
(EQUAL (CAR X)
(CAR Y))
(EQUAL (CDR X)
(CDR Y]
(\LITATOM (* EQUAL only if EQ)
NIL)
(\STRINGP (STREQUAL X Y))
(EQP X Y])
)
(DEFINEQ
(TYPENAMEP
[LAMBDA (DATUM TYPE)
(EQ (TYPENAME DATUM)
TYPE])
)
(DEFINEQ
(NEQ
[LAMBDA (X Y)
(NOT (EQ X Y])
(NULL
[LAMBDA (X)
(EQ X NIL])
(NOT
[LAMBDA (X)
(EQ X NIL])
)
(* Belong on ACODE except they would clobber 10-versions in ABC)
(DEFINEQ
(LAPRD
[LAMBDA (FN) (* wsh: "20-JUL-79 12:27")
(PROG (X Y)
(RETURN (COND
([OR (NEQ (PEEKC)
(QUOTE % ))
[NOT (LITATOM (SETQ X (SETQ Y (READ]
(NOT (LISTP (SETQ X (GETP X (QUOTE CODEREADER]
(ERROR (QUOTE "Bad compiled function")
FN))
(T (APPLY* (CAR X)
FN])
(DEFC
[LAMBDA (NM DF) (* lmm "11-FEB-82 14:44")
(PROG ((PROP (QUOTE CODE)))
(COND
((OR (NULL DFNFLG)
(EQ DFNFLG T))
[COND
((GETD NM)
(VIRGINFN NM T)
(COND
((NULL DFNFLG)
(PRINT (CONS NM (QUOTE (redefined)))
T T) (* NOTE: this call to PRINT is changed to LISPXPRINT
later in the loadup.)
(SAVEDEF NM]
(PUTD NM DF T) (* NOTE: this call to \PUTD is changed to /PUTD later in
the loadup.)
)
(T (PUTPROP NM PROP DF) (* NOTE: this call to PUTPROP is changed to /PUTPROP
later in the loadup.)
))
(RETURN DF])
(CGETD
[LAMBDA (X)
(COND
((LITATOM X)
(GETD X))
(T X])
)
(DEFINEQ
(NCONC
[LAMBDA N
(AND (NEQ N 0)
(PROG ((L (ARG N N))
(J N)
X)
LP (COND
((EQ (SETQ J (SUB1 J))
0)
(RETURN L))
((LISTP (SETQ X (ARG N J)))
(FRPLACD (LAST X)
L)
(SETQ L X)))
(GO LP])
(\NCONC2
[LAMBDA (X Y) (* lmm "15-APR-82 22:10")
(COND
((LISTP X)
(RPLACD (LAST X)
Y)
X)
(T Y])
(\APPEND2
[LAMBDA (L1 L2) (* lmm "15-APR-82 22:37")
(COND
((LISTP L1)
(PROG ((VAL (CONS (CAR L1)
L2))
TAIL)
(SETQ TAIL VAL)
LP [FRPLACD TAIL (SETQ TAIL (LIST (CAR (OR (LISTP (SETQ L1 (CDR L1)))
(PROGN (FRPLACD TAIL L2)
(RETURN VAL]
(GO LP)))
((NLISTP L2)
L1)
(T L2])
(PUTDQ
[NLAMBDA (X Y)
(PUTD X Y)
X])
(PRINTARRAY
[LAMBDA (V) (* rrb "20-JUL-83 11:49")
(* Used by prettydef. Included in ABASIC because it uses
LOC and VAG on the 10)
(PROG (A N M TYPE FLG DOUBLEFLG ORIG)
[COND
([AND (LITATOM V)
(ARRAYP (SETQ A (EVALV V (QUOTE PRINTARRAY]
(printout NIL "(SETQ " .P2 V ,)
(printout NIL "(READARRAY " (SETQ N (ARRAYSIZE A))
, "(QUOTE " (SETQ TYPE (ARRAYTYP A))
") "
(SETQ ORIG (ARRAYORIG A))
")")
(printout NIL ")" T) (* Close the SETQ)
)
((ARRAYP V) (* Just dumps the element expression--assumes that
READARRAY has already been written)
(SETQ A V)
(SETQ N (ARRAYSIZE A))
(SETQ TYPE (ARRAYTYP A))
(SETQ ORIG (ARRAYORIG A)))
(T (RETURN (HELP (CONS V (QUOTE (not array]
(PRIN1 (QUOTE %())
(SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER))
(NUMBERP TYPE))) (* note if this array has different ELTD.)
(SETQ M 1)
LP (COND
((NOT (IGREATERP M N))
(COND
[(OR (EQ TYPE (QUOTE POINTER))
DOUBLEFLG)
(PRINT (ELT A (SUB1 (IPLUS M ORIG]
(T (* changed from PRINT to PRIN2 so would look better in
file.)
[PRIN2 (ELT A (SUB1 (IPLUS M ORIG]
(SPACES 1)))
(* check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out
avoids lots of NILs.)
(AND DOUBLEFLG (COND
((NUMBERP TYPE) (* check for M being in the double pointer part of the
array)
(IGREATERP M TYPE))
(T T))
(ELTD A (SUB1 (IPLUS M ORIG)))
(SETQ FLG T))
(SETQ M (ADD1 M))
(GO LP))
((NULL (PRINT FLG)) (* if FLG is NULL, there are non-NIL double word
entries.)
(GO OUT)))
[SETQ M (COND
((EQ TYPE (QUOTE DOUBLEPOINTER)) (* all entries are double)
1)
((NUMBERP TYPE) (* first TYPE elements in the array are numbers)
(ADD1 TYPE]
LP1 (COND
((NOT (IGREATERP M N))
[PRINT (ELTD A (SUB1 (IPLUS M ORIG]
(SETQ M (ADD1 M))
(GO LP1)))
OUT (PRIN1 (QUOTE %)))
(RETURN A])
(SORT
[LAMBDA (DATA COMPAREFN)
(DECLARE (LOCALVARS . T)) (* lmm: "11-NOV-76 23:48:23")
(COND
[(NLISTP DATA)
(COND
(DATA (ERROR (QUOTE "DATA NOT LIST:")
DATA]
(T (OR COMPAREFN (SETQ COMPAREFN (FUNCTION ALPHORDER)))
(FRPLACD (LAST DATA)
NIL)
(SORT1 DATA NIL COMPAREFN])
(MERGE
[LAMBDA (A B COMPAREFN) (* lmm " 6-MAY-80 21:36")
(PROG (ATAIL BTAIL)
[COND
((NULL B) (* MERGE will work if either arg is NIL.)
(RETURN A))
((NULL A)
(RETURN B))
((NLISTP B) (* No possible meaning here; user must be in error.)
(ERRORX (LIST 4 B)))
((NLISTP A)
(ERRORX (LIST 4 A)))
([NOT (SELECTQ COMPAREFN
(T (ALPHORDER (CAAR A)
(CAAR B)))
(NIL (ALPHORDER (CAR A)
(CAR B)))
(APPLY* COMPAREFN (CAR A)
(CAR B]
(* (CAR A) must be before (CAR B) at LOOP (see comment below). If not, swap A and B. -
The SELECTQ compares the next things on A and B.)
(SETQ A (PROG1 B (SETQ B A]
(SETQ ATAIL A)
(* It is desireable to make the value of the merged list available to the user not only as the return from MERGE,
but also on both the CONSES given as arguments. To this end, the MERGE is actually performed on the lists A and
(CONS (CAR B) (CDR B)), so that when we return, the original B may be smashed with (CAR A) and
(CDR A).)
(SETQ BTAIL (CONS (CAR B)
(CDR B)))
(* Whenever we pass LOOP, we know that ATAIL is LISTP, BTAIL is LISTP, and (CAR ATAIL) belongs before
(CAR BTAIL). We therefore look to see if there is anything more on ATAIL; if not, tie on BTAIL and return.
Otherwise, compare (CADR ATAIL) to (CAR BTAIL). If ATAIL wins, just take one CDR and go around.
But if BTAIL wins, then we swap variable/structures: ATAIL is rplacd'd to the structure that was on BTAIL, and BTAIL
is bound to the old CDR of ATAIL. We then take the CDR and go around. Observe that this swapping preserves the
assumptions made at LOOP.)
LOOP[COND
[(NLISTP (CDR ATAIL))
(FRPLACD ATAIL BTAIL)
(RETURN (FRPLACA (FRPLACD B (CDR A))
(CAR A]
[(SELECTQ COMPAREFN
(NIL (ALPHORDER (CADR ATAIL)
(CAR BTAIL)))
(T (ALPHORDER (CAADR ATAIL)
(CAAR BTAIL)))
(APPLY* COMPAREFN (CADR ATAIL)
(CAR BTAIL]
(T (FRPLACD ATAIL (PROG1 BTAIL (SETQ BTAIL (CDR ATAIL]
(SETQ ATAIL (CDR ATAIL))
(GO LOOP])
(SORT1
[LAMBDA (DATA END COMPAREFN)
(DECLARE (LOCALVARS . T)) (* lmm: "11-NOV-76 23:49:27")
(COND
((OR (EQ DATA END)
(EQ (CDR DATA)
END))
DATA)
(T (PROG ((L DATA)
(A DATA)
TM) (* Split DATA by setting A to one cell before its midpoint.
DATA remains EQ to the original list.)
LP (COND
((AND (NEQ (SETQ L (CDR L))
END)
(NEQ (SETQ L (CDR L))
END))
(SETQ A (CDR A))
(GO LP)))
(SETQ TM (SORT1 DATA (CDR A)
COMPAREFN))
(SORT1 (SETQ L (CDR A))
END COMPAREFN)
(* Merge DATA thru A with L (= (CDR A)) up to END. This is a little tricky because DATA must remain EQ to its
original value.)
ALP (COND
((EQ TM L) (* Exhausted first list.)
(RETURN DATA)))
BLP (COND
((SELECTQ COMPAREFN
[T (ALPHORDER (COND
((LISTP (CAR TM))
(CAAR TM))
(T (CAR TM)))
(COND
((LISTP (CAR L))
(CAAR L))
(T (CAR L]
(APPLY* COMPAREFN (CAR TM)
(CAR L)))
(SETQ TM (CDR TM))
(GO ALP)))
(* Move first element of second list (L = (CDR A)) to before first element of first list (TM). This must be done by
exchanging the CARs and then patching up the CDRs, to retain the EQ property. This is a (QUOTE critical) section' in
that data will be lost if a hard interrupt occurs, but it cannot be interrupted by ↑H because it does no function
calls.)
[COND
[(EQ TM A) (* Special case.)
[FRPLACA TM (PROG1 (CAR L)
(FRPLACA L (CAR TM]
(SETQ L (CDR (SETQ TM (SETQ A L]
(T [FRPLACD A (PROG1 (CDR L)
(FRPLACA TM (PROG1 (CAR L)
(FRPLNODE2 L TM)
(FRPLACD TM L]
(SETQ TM L)
(SETQ L (CDR A]
(COND
((NEQ L END)
(GO BLP))) (* Exhausted second list.)
(RETURN DATA])
(PRETTYCOMPRINT
[NLAMBDA (X)
(PRINT X T T])
(FASSOC
[LAMBDA (KEY ALST) (* lmm " 5-MAR-80 20:55")
(COND
((NULL ALST)
NIL)
((EQ KEY (CAAR ALST))
(CAR ALST))
(T (FASSOC KEY (CDR ALST])
(FLAST
[LAMBDA (X) (* lmm " 5-MAR-80 20:57")
(PROG ((Y X))
(GO LP0)
LP (SETQ X Y)
(SETQ Y (CDR X))
LP0 (COND
(Y (GO LP)))
(RETURN X])
(FLENGTH
[LAMBDA (X) (* lmm: "11-NOV-76 23:53:54")
(PROG ((N 0)
Y)
(SETQ Y X)
(GO LP0)
LP (SETQ X Y)
(SETQ N (ADD1 N))
(SETQ Y (CDR X))
LP0 (COND
(Y (GO LP)))
(RETURN N])
(FMEMB
[LAMBDA (X Y) (* lmm "27-MAR-80 12:53")
(PROG NIL
LP (RETURN (COND
((NULL Y)
NIL)
((EQ (CAR Y)
X)
Y)
(T (SETQ Y (CDR Y))
(GO LP])
(FNTH
[LAMBDA (X N) (* lmm " 6-MAY-80 22:29")
(COND
((IGREATERP 1 N)
(CONS NIL X))
(T (PROG ((X0 X))
(DECLARE (LOCALVARS X0))
LP (COND
((NULL X)
(RETURN NIL))
((NOT (IGREATERP N 1))
(RETURN X)))
(SETQ N (SUB1 N))
(SETQ X (CDR X))
(GO LP])
(FGETD
[LAMBDA (FN) (* lmm: "12-NOV-76 00:13:04")
(SETQ FN (GETD FN))
(COND
((AND (LISTP FN)
(SMALLP (CAR FN))
(SMALLP (CDR FN)))
(CDR FN))
(T FN])
(LIST
[LAMBDA N
(PROG ((J N)
L)
LP (COND
((ZEROP J)
(RETURN L)))
(SETQ L (CONS (ARG N J)
L))
(SUB1VAR J)
(GO LP])
(COUNT
[LAMBDA (X) (* lmm: 24 JUN 75 32)
(PROG ((N 0))
LP (COND
((NLISTP X)
(RETURN N))
(T (SETQ N (IPLUS (COUNT (CAR X))
1 N))
(SETQ X (CDR X))
(GO LP])
)
(DEFINEQ
(CHANGENAME1
[LAMBDA (DEF X Y) (* rmk: "15-APR-80 17:29")
(* This isn't on ACODE because it would smash the 10 version in ABC)
(COND
((EXPRP DEF)
(NLSETQ (ESUBST Y X DEF)))
((CCODEP DEF)
[COND
((LITATOM DEF)
(SETQ DEF (GETD DEF]
(CHANGENAME1A DEF X Y (CHANGECCODE X X DEF])
(CHANGENAME1A
[LAMBDA (DEF OLD NEW MAP) (* lmm "20-MAY-80 09:43")
(COND
((AND MAP (find X in (CDR MAP) suchthat (find Y in (CDR X) suchthat Y)))
(CHANGECCODE NEW MAP DEF)
(UNDOSAVE (LIST (QUOTE CHANGENAME1A)
DEF NEW OLD MAP))
T])
)
(DEFINEQ
(CDDR
[LAMBDA (X)
(CDR (CDR X])
(CDAR
[LAMBDA (X)
(CDR (CAR X])
(CADR
[LAMBDA (X)
(CAR (CDR X])
(CAAR
[LAMBDA (X)
(CAR (CAR X])
(CDDDR
[LAMBDA (X)
(CDR (CDDR X])
(CDDAR
[LAMBDA (X)
(CDR (CDAR X])
(CDADR
[LAMBDA (X)
(CDR (CADR X])
(CDAAR
[LAMBDA (X)
(CDR (CAAR X])
(CADDR
[LAMBDA (X)
(CAR (CDDR X])
(CADAR
[LAMBDA (X)
(CAR (CDAR X])
(CAADR
[LAMBDA (X)
(CAR (CADR X])
(CAAAR
[LAMBDA (X)
(CAR (CAAR X])
(CDDDDR
[LAMBDA (X)
(CDDR (CDDR X])
(CAAAAR
[LAMBDA (X)
(CAAR (CAAR X])
(CDDDAR
[LAMBDA (X)
(CDDR (CDAR X])
(CDDADR
[LAMBDA (X)
(CDDR (CADR X])
(CDDAAR
[LAMBDA (X)
(CDDR (CAAR X])
(CDAAAR
[LAMBDA (X)
(CDAR (CAAR X])
(CADADR
[LAMBDA (X)
(CADR (CADR X])
(CDADDR
[LAMBDA (X)
(CDAR (CDDR X])
(CDADAR
[LAMBDA (X)
(CDAR (CDAR X])
(CAADDR
[LAMBDA (X)
(CAAR (CDDR X])
(CDAADR
[LAMBDA (X)
(CDAR (CADR X])
(CAADAR
[LAMBDA (X)
(CAAR (CDAR X])
(CADDDR
[LAMBDA (X)
(CADR (CDDR X])
(CADAAR
[LAMBDA (X)
(CADR (CAAR X])
(CADDAR
[LAMBDA (X)
(CADR (CDAR X])
(CAAADR
[LAMBDA (X)
(CAAR (CADR X])
)
(DEFINEQ
(SYSTEMTYPE
[LAMBDA NIL (* lmm "17-AUG-81 15:50")
(* let the macro decide)
(SYSTEMTYPE])
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA DUMMYDEF)
(ADDTOVAR NLAML PRETTYCOMPRINT PUTDQ)
(ADDTOVAR LAMA LIST NCONC NOTIMP ZERO TRUE NILL)
)
(PUTPROPS ABASIC COPYRIGHT ("Xerox Corporation" 1982 1983))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1157 1760 (EVALQT 1167 . 1541) (\SystemERROR 1543 . 1758)) (1761 2527 (NILL 1771 . 1881
) (EVQ 1883 . 1959) (TRUE 1961 . 2069) (ZERO 2071 . 2179) (DUMMYDEF 2181 . 2412) (NOTIMP 2414 . 2525))
(2559 2903 (EQUAL 2569 . 2901)) (2904 2984 (TYPENAMEP 2914 . 2982)) (2985 3119 (NEQ 2995 . 3040) (
NULL 3042 . 3079) (NOT 3081 . 3117)) (3193 4473 (LAPRD 3203 . 3574) (DEFC 3576 . 4390) (CGETD 4392 .
4471)) (4474 14521 (NCONC 4484 . 4734) (\NCONC2 4736 . 4880) (\APPEND2 4882 . 5258) (PUTDQ 5260 . 5308
) (PRINTARRAY 5310 . 7881) (SORT 7883 . 8216) (MERGE 8218 . 10558) (SORT1 10560 . 12556) (
PRETTYCOMPRINT 12558 . 12609) (FASSOC 12611 . 12806) (FLAST 12808 . 13022) (FLENGTH 13024 . 13299) (
FMEMB 13301 . 13526) (FNTH 13528 . 13875) (FGETD 13877 . 14095) (LIST 14097 . 14274) (COUNT 14276 .
14519)) (14522 15194 (CHANGENAME1 14532 . 14902) (CHANGENAME1A 14904 . 15192)) (15195 16593 (CDDR
15205 . 15244) (CDAR 15246 . 15285) (CADR 15287 . 15326) (CAAR 15328 . 15367) (CDDDR 15369 . 15414) (
CDDAR 15416 . 15461) (CDADR 15463 . 15508) (CDAAR 15510 . 15555) (CADDR 15557 . 15602) (CADAR 15604 .
15649) (CAADR 15651 . 15696) (CAAAR 15698 . 15743) (CDDDDR 15745 . 15796) (CAAAAR 15798 . 15849) (
CDDDAR 15851 . 15902) (CDDADR 15904 . 15955) (CDDAAR 15957 . 16008) (CDAAAR 16010 . 16061) (CADADR
16063 . 16114) (CDADDR 16116 . 16167) (CDADAR 16169 . 16220) (CAADDR 16222 . 16273) (CDAADR 16275 .
16326) (CAADAR 16328 . 16379) (CADDDR 16381 . 16432) (CADAAR 16434 . 16485) (CADDAR 16487 . 16538) (
CAAADR 16540 . 16591)) (16594 16772 (SYSTEMTYPE 16604 . 16770)))))
STOP