(FILECREATED " 8-Aug-85 13:16:29" {ERIS}<LISPCORE>SOURCES>ABASIC.;2 16949
changes to: (FNS EQUAL)
previous date: "27-Sep-84 23:14:20" {ERIS}<LISPCORE>SOURCES>ABASIC.;1)
(* Copyright (c) 1982, 1983, 1984, 1985 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 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* 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) (* lmm " 8-Aug-85 13:15") (* tortured logic to optimize performance) (OR (EQ X Y) (if (
LISTP X) then (AND (LISTP Y) (PROG NIL RETRYLISTP (RETURN (AND (EQUAL (CAR X) (CAR Y)) (if (LISTP (
SETQ X (CDR X))) then (RETURN (AND (LISTP (SETQ Y (CDR Y))) (OR (EQ X Y) (GO RETRYLISTP)))) else (
EQUAL X (CDR Y))))))) else (SELECTC (NTYPX X) (\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))))
(LIST*
(LAMBDA NARGS (* JonL "27-Sep-84 21:19")
(if (EQ 0 NARGS)
then NIL
elseif (EQ 1 NARGS)
then (ARG NARGS 1)
else (bind (VAL ←(ARG NARGS NARGS)) for I from (SUB1 NARGS) by -1 until (ILEQ I 0)
do (push VAL (ARG NARGS I)) finally (RETURN VAL)))))
(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* LIST NCONC NOTIMP ZERO TRUE NILL)
)
(PUTPROPS ABASIC COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1090 1693 (EVALQT 1100 . 1474) (\SystemERROR 1476 . 1691)) (1694 2460 (NILL 1704 . 1814
) (EVQ 1816 . 1892) (TRUE 1894 . 2002) (ZERO 2004 . 2112) (DUMMYDEF 2114 . 2345) (NOTIMP 2347 . 2458))
(2492 2939 (EQUAL 2502 . 2937)) (2940 3020 (TYPENAMEP 2950 . 3018)) (3021 3155 (NEQ 3031 . 3076) (
NULL 3078 . 3115) (NOT 3117 . 3153)) (3231 4511 (LAPRD 3241 . 3612) (DEFC 3614 . 4428) (CGETD 4430 .
4509)) (4512 14414 (NCONC 4522 . 4772) (\NCONC2 4774 . 4918) (PRINTARRAY 4920 . 7491) (SORT 7493 .
7826) (MERGE 7828 . 10168) (SORT1 10170 . 12166) (PRETTYCOMPRINT 12168 . 12219) (FASSOC 12221 . 12416)
(FLAST 12418 . 12632) (FLENGTH 12634 . 12909) (FMEMB 12911 . 13136) (FNTH 13138 . 13485) (LIST 13487
. 13753) (LIST* 13755 . 14167) (COUNT 14169 . 14412)) (14415 15087 (CHANGENAME1 14425 . 14795) (
CHANGENAME1A 14797 . 15085)) (15088 16486 (CDDR 15098 . 15137) (CDAR 15139 . 15178) (CADR 15180 .
15219) (CAAR 15221 . 15260) (CDDDR 15262 . 15307) (CDDAR 15309 . 15354) (CDADR 15356 . 15401) (CDAAR
15403 . 15448) (CADDR 15450 . 15495) (CADAR 15497 . 15542) (CAADR 15544 . 15589) (CAAAR 15591 . 15636)
(CDDDDR 15638 . 15689) (CAAAAR 15691 . 15742) (CDDDAR 15744 . 15795) (CDDADR 15797 . 15848) (CDDAAR
15850 . 15901) (CDAAAR 15903 . 15954) (CADADR 15956 . 16007) (CDADDR 16009 . 16060) (CDADAR 16062 .
16113) (CAADDR 16115 . 16166) (CDAADR 16168 . 16219) (CAADAR 16221 . 16272) (CADDDR 16274 . 16325) (
CADAAR 16327 . 16378) (CADDAR 16380 . 16431) (CAAADR 16433 . 16484)) (16487 16665 (SYSTEMTYPE 16497 .
16663)))))
STOP