(FILECREATED "30-Jun-84 00:42:42" {ERIS}<LISPCORE>SOURCES>ABASIC.;3 16468
changes to: (FNS \APPEND2)
(VARS ABASICCOMS)
previous date: "24-Apr-84 14:50:06" {ERIS}<LISPCORE>SOURCES>ABASIC.;2)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation. All rights reserved.)
(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 PRINTARRAY SORT MERGE SORT1 PRETTYCOMPRINT FASSOC FLAST FLENGTH FMEMB FNTH
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)
(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])
(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])
(LIST
(LAMBDA N (* JonL "24-Apr-84 14:49")
(PROG ((J N)
L)
LP (COND
((EQ 0 J)
(RETURN L)))
(SETQ L (CONS (ARG N J)
L))
(SETQ J (SUB1 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)
(ADDTOVAR LAMA LIST NCONC NOTIMP ZERO TRUE NILL)
)
(PUTPROPS ABASIC COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1139 1742 (EVALQT 1149 . 1523) (\SystemERROR 1525 . 1740)) (1743 2509 (NILL 1753 . 1863
) (EVQ 1865 . 1941) (TRUE 1943 . 2051) (ZERO 2053 . 2161) (DUMMYDEF 2163 . 2394) (NOTIMP 2396 . 2507))
(2541 2885 (EQUAL 2551 . 2883)) (2886 2966 (TYPENAMEP 2896 . 2964)) (2967 3101 (NEQ 2977 . 3022) (
NULL 3024 . 3061) (NOT 3063 . 3099)) (3175 4455 (LAPRD 3185 . 3556) (DEFC 3558 . 4372) (CGETD 4374 .
4453)) (4456 13944 (NCONC 4466 . 4716) (\NCONC2 4718 . 4862) (PRINTARRAY 4864 . 7435) (SORT 7437 .
7770) (MERGE 7772 . 10112) (SORT1 10114 . 12110) (PRETTYCOMPRINT 12112 . 12163) (FASSOC 12165 . 12360)
(FLAST 12362 . 12576) (FLENGTH 12578 . 12853) (FMEMB 12855 . 13080) (FNTH 13082 . 13429) (LIST 13431
. 13697) (COUNT 13699 . 13942)) (13945 14617 (CHANGENAME1 13955 . 14325) (CHANGENAME1A 14327 . 14615)
) (14618 16016 (CDDR 14628 . 14667) (CDAR 14669 . 14708) (CADR 14710 . 14749) (CAAR 14751 . 14790) (
CDDDR 14792 . 14837) (CDDAR 14839 . 14884) (CDADR 14886 . 14931) (CDAAR 14933 . 14978) (CADDR 14980 .
15025) (CADAR 15027 . 15072) (CAADR 15074 . 15119) (CAAAR 15121 . 15166) (CDDDDR 15168 . 15219) (
CAAAAR 15221 . 15272) (CDDDAR 15274 . 15325) (CDDADR 15327 . 15378) (CDDAAR 15380 . 15431) (CDAAAR
15433 . 15484) (CADADR 15486 . 15537) (CDADDR 15539 . 15590) (CDADAR 15592 . 15643) (CAADDR 15645 .
15696) (CDAADR 15698 . 15749) (CAADAR 15751 . 15802) (CADDDR 15804 . 15855) (CADAAR 15857 . 15908) (
CADDAR 15910 . 15961) (CAAADR 15963 . 16014)) (16017 16195 (SYSTEMTYPE 16027 . 16193)))))
STOP