(FILECREATED "17-Jan-85 10:31:49" {DANTE}<LISPUSERS>GLISP>GLISPA.LSP;2 83106
changes to: (FILEPKGCOMS GLISPCONSTANTS GLISPGLOBALS GLISPOBJECTS)
previous date: "11-Feb-84 14:40:07" {DANTE}<LISPUSERS>GLISP>GLISPA.LSP;1)
(* Copyright (c) 1985 by Gordon S. Novak Jr.. All rights reserved.)
(PRETTYCOMPRINT GLISPACOMS)
(RPAQQ GLISPACOMS [(* Copyright (c)
1983 by Gordon S. Novak Jr.)
(* This file, GLISPA, is one of three GLISP files. The others are GLISPB and GLISPR.)
(FNS GLABSTRACTFN? GLADDRESULTTYPE GLADDSTR GLADJ GLAMBDATRAN GLANALYZEGLISP GLANDFN
GLATOMTYPEP GLBUILDALIST GLBUILDCONS GLBUILDLIST GLBUILDNOT GLBUILDPROPLIST
GLBUILDRECORD GLBUILDSTR GLCARCDR? GLCC GLCOMP GLCOMPABSTRACT GLCOMPCOMS GLCOMPEXPR
GLCOMPILE GLCOMPILE? GLCOMPMSG GLCOMPMSGB GLCOMPMSGL GLCOMPOPEN GLCONSTANTTYPE GLCONST?
GLCONSTSTR? GLCONSTVAL GLCP GLDECL GLDECLDS GLDECLS GLDOA GLDOCASE GLDOCOND GLDOEXPR
GLDOFOR GLDOFUNCTION GLDOIF GLDOLAMBDA GLDOMAIN GLDOMAP GLDOMSG GLDOPROG GLDOPROGN
GLDOPROG1 GLDOREPEAT GLDORETURN GLDOSELECTQ GLDOSEND GLDOSETQ GLDOTHE GLDOTHOSE
GLDOVARSETQ GLDOWHILE GLEQUALFN GLEVALSTR GLEVALSTRB GLEXPANDPROGN GLFINDVARINCTX
GLFIXCOMS GLGETCONSTDEF GLGETFIELD GLGETGLOBALDEF GLGETTYPEOF GLIDNAME GLIDTYPE
GLINSTANCEFN GLINSTANCEFNNAME GLINTERLISPTRANSFM)
(FILEPKGCOMS GLISPCONSTANTS GLISPGLOBALS GLISPOBJECTS)
(ADDVARS (LAMBDASPLST GLAMBDA)
(LAMBDATRANFNS (GLAMBDA GLAMBDATRAN EXPR NIL))
(PRETTYEQUIVLST (GLAMBDA . LAMBDA)))
(GLOBALVARS GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLTYPENAMES GLBREAKONERROR
GLUSERSTRNAMES GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT
GLBASICTYPES GLOBJECTNAMES GLTYPESUSED GLNOSPLITATOMS GLGLSENDFLG
GEVUSERTYPENAMES)
(SPECVARS CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR GLTOPCTX RESULTTYPE RESULT GLNATOM
FIRST OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST ADDISATYPE GLFNSUBS
GLNRECURSIONS PAIRS NEW N)
(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
LAMBDATRAN)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* Copyright (c) 1983 by Gordon S. Novak Jr.)
(* This file, GLISPA, is one of three GLISP files. The others are GLISPB and GLISPR.)
(DEFINEQ
(GLABSTRACTFN?
[LAMBDA (FNNAME) (* GSN "17-FEB-83 11:31"
) (* Test whether FNNAME
is an abstract
function.)
(PROG (DEFN)
(RETURN (AND (SETQ DEFN (GLGETD FNNAME))
(LISTP DEFN)
(EQ (CAR DEFN)
(QUOTE MLAMBDA])
(GLADDRESULTTYPE
[LAMBDA (SDES) (* "GSN: "
"25-Jan-81 18:17")
(* Add the type SDES to
RESULTTYPE in GLCOMP)
(COND
((NULL RESULTTYPE)
(SETQ RESULTTYPE SDES))
[(AND (LISTP RESULTTYPE)
(EQ (CAR RESULTTYPE)
(QUOTE OR)))
(COND
((NOT (MEMBER SDES (CDR RESULTTYPE)))
(NCONC1 RESULTTYPE SDES]
((NOT (EQUAL SDES RESULTTYPE))
(SETQ RESULTTYPE (LIST (QUOTE OR)
RESULTTYPE SDES])
(GLADDSTR
[LAMBDA (ATM NAME STR CONTEXT) (* "GSN: "
" 2-Jan-81 13:37")
(* Add an entry to the current context for a
variable ATM, whose NAME in context is given, and
which has structure STR. The entry is pushed onto
the front of the list at the head of the context.)
(* edited:
"30-Sep-80 18:04")
(RPLACA CONTEXT (CONS (LIST ATM NAME STR)
(CAR CONTEXT])
(GLADJ
[LAMBDA (SOURCE PROPERTY ADJWD) (* GSN "10-FEB-83 12:56"
) (* edited:
"17-Sep-81 13:58")
(* Compile code to test
if SOURCE is PROPERTY.)
(PROG (ADJL TRANS TMP FETCHCODE)
(COND
[(EQ ADJWD (QUOTE ISASELF))
(COND
((SETQ ADJL (GLSTRPROP PROPERTY (QUOTE ISA)
(QUOTE self)
NIL))
(GO A))
(T (RETURN]
((SETQ ADJL (GLSTRPROP (CADR SOURCE)
ADJWD PROPERTY NIL))
(GO A))) (* See if the adjective
can be found in a
TRANSPARENT
substructure.)
(SETQ TRANS (GLTRANSPARENTTYPES (CADR SOURCE)))
B (COND
((NULL TRANS)
(RETURN))
((SETQ TMP (GLADJ (LIST (QUOTE *GL*)
(GLXTRTYPE (CAR TRANS)))
PROPERTY ADJWD))
(SETQ FETCHCODE (GLSTRFN (CAR TRANS)
(CADR SOURCE)
NIL))
(GLSTRVAL TMP (CAR FETCHCODE))
(GLSTRVAL TMP (CAR SOURCE))
(RETURN TMP))
(T (SETQ TRANS (CDR TRANS))
(GO B)))
A (COND
((AND (LISTP (CADR ADJL))
(MEMB (CAADR ADJL)
(QUOTE (NOT Not not)))
(ATOM (CADADR ADJL))
(NULL (CDDADR ADJL))
(SETQ TMP (GLSTRPROP (CADR SOURCE)
ADJWD
(CADADR ADJL)
NIL)))
(SETQ ADJL TMP)
(SETQ NOTFLG (NOT NOTFLG))
(GO A)))
(RETURN (GLCOMPMSGL SOURCE ADJWD ADJL NIL CONTEXT])
(GLAMBDATRAN
[LAMBDA (GLEXPR) (* GSN "26-JAN-83 13:54"
) (* "GSN: "
"21-Sep-81 16:19")
(* "GSN: "
"30-Dec-80 14:36")
(* This function is called when a GLAMBDA function
is found by the interpreter.
If the function definition is available on the
property GLCOMPILED, that definition is returned;
otherwise, GLCOMP is called to compile the
function.)
(PROG (NEWEXPR)
(SETQ GLLASTFNCOMPILED FAULTFN)
(SAVEDEF FAULTFN)
(PUTPROP FAULTFN (QUOTE GLCOMPILED)
(SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR NIL NIL NIL)))
(PUTHASH (GETD FAULTFN)
NEWEXPR CLISPARRAY)
(RETURN NEWEXPR])
(GLANALYZEGLISP
[LAMBDA NIL (* edited:
" 2-JUN-82 15:33")
(* Analyze GLISP itself
for use in converting to
other LISP dialects.)
(PROG (CALLEDFNS GLFNS GLALLFNS)
(SETQ GLFNS (LDIFFERENCE (SETQ GLALLFNS (CDAR GLISPCOMS))
GLSPECIALFNS))
[SETQ CALLEDFNS
(SORT (LDIFFERENCE (MASTERSCOPE (QUOTE (WHAT FNS NOT IN
GLALLFNS ARE
CALLED BY FNS
IN GLFNS)))
(QUOTE (ATOM apply RPLACD CDDR SET SOME
EQUAL NUMBERP CAR CADR CONS
RPLACA LIST DECLARE NCONC]
(MAPC CALLEDFNS
(FUNCTION (LAMBDA (X)
(TERPRI)
(PRINT X)
(PRINT (MASTERSCOPE (SUBST X (QUOTE FN)
(QUOTE (WHAT FNS IN
GLFNS CALL
FN])
(GLANDFN
[LAMBDA (LHS RHS) (* edited:
"26-DEC-82 15:40")
(* "GSN: "
" 8-Jan-81 17:04")
(* AND operator)
(COND
((NULL LHS)
RHS)
((NULL RHS)
LHS)
((AND (LISTP (CAR LHS))
(EQ (CAAR LHS)
(QUOTE AND))
(LISTP (CAR RHS))
(EQ (CAAR RHS)
(QUOTE AND)))
(LIST (APPEND (CAR LHS)
(CDAR RHS))
(CADR LHS)))
((AND (LISTP (CAR LHS))
(EQ (CAAR LHS)
(QUOTE AND)))
(LIST (APPEND (CAR LHS)
(LIST (CAR RHS)))
(CADR LHS)))
((AND (LISTP (CAR RHS))
(EQ (CAAR RHS)
(QUOTE AND)))
(LIST (CONS (QUOTE AND)
(CONS (CAR LHS)
(CDAR RHS)))
(CADR LHS)))
((AND (LISTP (CADR RHS))
(EQ (CAADR RHS)
(QUOTE LISTOF))
(EQUAL (CADR LHS)
(CADR RHS)))
(LIST (LIST (QUOTE INTERSECTION)
(CAR LHS)
(CAR RHS))
(CADR RHS)))
((GLDOMSG LHS (QUOTE AND)
(LIST RHS)))
((GLUSERSTROP LHS (QUOTE AND)
RHS))
(T (LIST (LIST (QUOTE AND)
(CAR LHS)
(CAR RHS))
(CADR RHS])
(GLATOMTYPEP
[LAMBDA (TYPE) (* edited:
"23-DEC-82 10:43")
(* Test whether TYPE is
implemented as an ATOM
structure.)
(PROG (TYPEB)
(RETURN (OR (EQ TYPE (QUOTE ATOM))
[AND (LISTP TYPE)
(MEMB (CAR TYPE)
(QUOTE (ATOM ATOMOBJECT]
(AND (NEQ (SETQ TYPEB (GLXTRTYPEB TYPE))
TYPE)
(GLATOMTYPEP TYPEB])
(GLBUILDALIST
[LAMBDA (ALIST PREVLST) (* edited:
"24-AUG-82 17:21")
(* edited:
"15-Sep-81 13:24")
(* edited:
"14-Sep-81 12:25")
(* edited:
"13-Aug-81 13:34")
(PROG (LIS TMP1 TMP2)
A [COND
((NULL ALIST)
(RETURN (AND LIS (GLBUILDLIST LIS NIL]
(SETQ TMP1 (pop ALIST))
[COND
((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST))
(SETQ LIS (NCONC1 LIS (GLBUILDCONS (KWOTE (CAR TMP1))
TMP2 T]
(GO A])
(GLBUILDCONS
[LAMBDA (X Y OPTFLG) (* edited:
" 9-DEC-82 17:14")
(* edited:
"15-Sep-81 13:09")
(* Generate code to build a CONS structure.
OPTFLG is true iff the structure does not need to be
a newly created one.)
(COND
((NULL Y)
(GLBUILDLIST (LIST X)
OPTFLG))
((AND (LISTP Y)
(EQ (CAR Y)
(QUOTE LIST)))
(GLBUILDLIST (CONS X (CDR Y))
OPTFLG))
[(AND OPTFLG (GLCONST? X)
(GLCONST? Y))
(LIST (QUOTE QUOTE)
(CONS (GLCONSTVAL X)
(GLCONSTVAL Y]
[(AND (GLCONSTSTR? X)
(GLCONSTSTR? Y))
(LIST (QUOTE COPY)
(LIST (QUOTE QUOTE)
(CONS (GLCONSTVAL X)
(GLCONSTVAL Y]
(T (LIST (QUOTE CONS)
X Y])
(GLBUILDLIST
[LAMBDA (LST OPTFLG) (* edited:
" 9-DEC-82 17:13")
(* Build a LIST structure, possibly doing
compile-time constant folding.
OPTFLG is true iff the structure does not need to be
a newly created copy.)
(COND
[(EVERY LST (FUNCTION GLCONST?))
(COND
[OPTFLG (LIST (QUOTE QUOTE)
(MAPCAR LST (FUNCTION GLCONSTVAL]
(T (GLGENCODE (LIST (QUOTE APPEND)
(LIST (QUOTE QUOTE)
(MAPCAR LST (FUNCTION GLCONSTVAL]
[(EVERY LST (FUNCTION GLCONSTSTR?))
(GLGENCODE (LIST (QUOTE COPY)
(LIST (QUOTE QUOTE)
(MAPCAR LST (FUNCTION GLCONSTVAL]
(T (CONS (QUOTE LIST)
LST])
(GLBUILDNOT
[LAMBDA (CODE) (* edited:
"19-OCT-82 15:05")
(* Build code to do (NOT CODE), doing compile-time
folding if possible.)
(PROG (TMP)
(COND
[(GLCONST? CODE)
(RETURN (NOT (GLCONSTVAL CODE]
((NLISTP CODE)
(RETURN (LIST (QUOTE NOT)
CODE)))
((EQ (CAR CODE)
(QUOTE NOT))
(RETURN (CADR CODE)))
((NOT (ATOM (CAR CODE)))
(RETURN))
[(SETQ TMP (FASSOC (CAR CODE)
(SELECTQ GLLISPDIALECT
[INTERLISP
(QUOTE ((LISTP NLISTP)
(EQ NEQ)
(NEQ EQ)
(IGREATERP ILEQ)
(ILEQ IGREATERP)
(ILESSP IGEQ)
(IGEQ ILESSP)
(GREATERP LEQ)
(LEQ GREATERP)
(LESSP GEQ)
(GEQ LESSP]
[(MACLISP FRANZLISP)
(QUOTE ((> <=)
(< >=)
(<= >)
(>= <]
[PSL (QUOTE ((EQ NE)
(NE EQ)
(LEQ GREATERP)
(GEQ LESSP]
NIL)))
(RETURN (CONS (CADR TMP)
(CDR CODE]
(T (RETURN (LIST (QUOTE NOT)
CODE])
(GLBUILDPROPLIST
[LAMBDA (PLIST PREVLST) (* edited:
"26-OCT-82 16:02")
(PROG (LIS TMP1 TMP2)
A [COND
((NULL PLIST)
(RETURN (AND LIS (GLBUILDLIST LIS NIL]
(SETQ TMP1 (pop PLIST))
[COND
((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST))
(SETQ LIS (NCONC LIS (LIST (KWOTE (CAR TMP1))
TMP2]
(GO A])
(GLBUILDRECORD
[LAMBDA (STR PAIRLIST PREVLST) (* edited:
"12-NOV-82 11:26")
(* Build a RECORD
structure.)
(PROG (TEMP ITEMS RECORDNAME)
[COND
((ATOM (CADR STR))
(SETQ RECORDNAME (CADR STR))
(SETQ ITEMS (CDDR STR)))
(T (SETQ ITEMS (CDR STR]
[COND
((EQ (CAR STR)
(QUOTE OBJECT))
(SETQ ITEMS (CONS (QUOTE (CLASS ATOM))
ITEMS]
(RETURN
(SELECTQ
GLLISPDIALECT
[INTERLISP
(COND
[RECORDNAME
(CONS (QUOTE create)
(CONS RECORDNAME
(MAPCONC
ITEMS
(FUNCTION (LAMBDA (X)
(AND (SETQ TEMP
(GLBUILDSTR X PAIRLIST
PREVLST))
(LIST (CAR X)
(QUOTE ←)
TEMP]
(T (GLBUILDLIST [MAPCAR ITEMS
(FUNCTION (LAMBDA (X)
(GLBUILDSTR X PAIRLIST
PREVLST]
NIL]
(FRANZLISP (LIST (QUOTE MAKHUNK)
(GLBUILDLIST
[MAPCAR ITEMS
(FUNCTION (LAMBDA (X)
(GLBUILDSTR X PAIRLIST
PREVLST]
T)))
(MACLISP [SETQ TEMP (MAPCAR ITEMS
(FUNCTION (LAMBDA (X)
(GLBUILDSTR X PAIRLIST
PREVLST]
(LIST (QUOTE MAKHUNK)
(GLBUILDLIST (NCONC1 (CDR TEMP)
(CAR TEMP))
T)))
[PSL (CONS (QUOTE Vector)
(MAPCAR ITEMS (FUNCTION (LAMBDA (X)
(GLBUILDSTR X PAIRLIST PREVLST]
(GLBUILDLIST [MAPCAR ITEMS (FUNCTION (LAMBDA (X)
(GLBUILDSTR X PAIRLIST PREVLST]
NIL])
(GLBUILDSTR
[LAMBDA (STR PAIRLIST PREVLST) (* GSN "26-JUL-83 14:19"
) (* edited:
"13-Aug-81 14:06")
(* Generate code to build a structure according to
the structure description STR.
PAIRLIST is a list of elements of the form
(SLOTNAME CODE TYPE) for each named slot to be
filled in in the structure.
(PREVLST is a list of structures of which this is a
substructure, to prevent loops.))
(DECLARE (SPECVARS PAIRLIST PROGG))
(PROG (PROPLIS TEMP PROGG TMPCODE ATMSTR)
(COND
((NULL STR)
(RETURN))
[(ATOM STR)
(COND
((FMEMB STR GLBASICTYPES)
(RETURN (GLDEFAULTVALUE STR)))
((MEMB STR PREVLST)
(RETURN))
[(SETQ TEMP (GLGETSTR STR))
(RETURN (GLBUILDSTR TEMP NIL (CONS STR PREVLST]
(T (RETURN]
((NLISTP STR)
(GLERROR (QUOTE GLBUILDSTR)
(LIST "Illegal structure type encountered:" STR))
(RETURN)))
(RETURN
(SELECTQ
(CAR STR)
(CONS (GLBUILDCONS (GLBUILDSTR (CADR STR)
PAIRLIST PREVLST)
(GLBUILDSTR (CADDR STR)
PAIRLIST PREVLST)
NIL))
(LIST (GLBUILDLIST [MAPCAR (CDR STR)
(FUNCTION (LAMBDA (X)
(GLBUILDSTR X PAIRLIST
PREVLST]
NIL))
(LISTOBJECT (GLBUILDLIST
[CONS (KWOTE (CAR PREVLST))
(MAPCAR (CDR STR)
(FUNCTION (LAMBDA (X)
(GLBUILDSTR X PAIRLIST
PREVLST]
NIL))
(ALIST (GLBUILDALIST (CDR STR)
PREVLST))
(PROPLIST (GLBUILDPROPLIST (CDR STR)
PREVLST))
(ATOM [SETQ PROGG
(LIST (QUOTE PROG)
(LIST (QUOTE ATOMNAME))
(LIST (QUOTE SETQ)
(QUOTE ATOMNAME)
(COND
[(AND PREVLST (ATOM (CAR PREVLST)))
(LIST (QUOTE GLMKATOM)
(KWOTE (CAR PREVLST]
(T (LIST (QUOTE GENSYM]
[COND
((SETQ TEMP (ASSOC (QUOTE BINDING)
(CDR STR)))
(SETQ TMPCODE (GLBUILDSTR (CADR TEMP)
PAIRLIST PREVLST))
(NCONC1 PROGG (LIST (QUOTE SET)
(QUOTE ATOMNAME)
TMPCODE]
(COND
((SETQ TEMP (ASSOC (QUOTE PROPLIST)
(CDR STR)))
(SETQ PROPLIS (CDR TEMP))
(GLPUTPROPS PROPLIS PREVLST)))
[NCONC1 PROGG (COPY (QUOTE (RETURN ATOMNAME]
PROGG)
[ATOMOBJECT
[SETQ PROGG
(LIST (QUOTE PROG)
(LIST (QUOTE ATOMNAME))
(LIST (QUOTE SETQ)
(QUOTE ATOMNAME)
(COND
[(AND PREVLST (ATOM (CAR PREVLST)))
(LIST (QUOTE GLMKATOM)
(KWOTE (CAR PREVLST]
(T (LIST (QUOTE GENSYM]
[NCONC1 PROGG (GLGENCODE (LIST (QUOTE PUTPROP)
(QUOTE ATOMNAME)
(LIST (QUOTE QUOTE)
(QUOTE CLASS))
(KWOTE (CAR PREVLST]
(GLPUTPROPS (CDR STR)
PREVLST)
(NCONC1 PROGG (COPY (QUOTE (RETURN ATOMNAME]
[TRANSPARENT (AND (NOT (MEMB (CADR STR)
PREVLST))
(SETQ TEMP (GLGETSTR (CADR STR)))
(GLBUILDSTR TEMP PAIRLIST
(CONS (CADR STR)
PREVLST]
(LISTOF NIL)
(RECORD (GLBUILDRECORD STR PAIRLIST PREVLST))
(OBJECT (GLBUILDRECORD STR
(CONS (LIST (QUOTE CLASS)
(KWOTE (CAR PREVLST))
(QUOTE ATOM))
PAIRLIST)
PREVLST))
(COND
[(ATOM (CAR STR))
(COND
((SETQ TEMP (ASSOC (CAR STR)
PAIRLIST))
(CADR TEMP))
((SETQ TEMP (ASSOC (CAR STR)
GLUSERSTRNAMES))
(APPLY* (CAR (NTH TEMP 6))
STR PAIRLIST PREVLST))
((AND (ATOM (CADR STR))
(NOT (FMEMB (CADR STR)
GLBASICTYPES)))
(GLBUILDSTR (CADR STR)
NIL PREVLST))
(T (GLBUILDSTR (CADR STR)
PAIRLIST PREVLST]
(T NIL])
(GLCARCDR?
[LAMBDA (X) (* edited:
"13-JAN-82 13:45")
(* Test if X is a CAR or CDR combination up to 3
long.)
(FMEMB X
(QUOTE (CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR
CADDR CDADR CDDAR CDDDR])
(GLCC
[LAMBDA (FN) (* edited:
" 5-OCT-82 15:24")
(SETQ FN (OR FN GLLASTFNCOMPILED))
(COND
((NOT (GLGETD FN))
(PRIN1 FN)
(PRIN1 " ?")
(TERPRI))
(T (GLCOMPILE FN])
(GLCOMP
[LAMBDA (GLAMBDAFN GLEXPR GLTYPESUBS GLFNSUBS ARGTYPES)
(* GSN "10-FEB-83 15:09"
)
(* GLISP compiler function. GLAMBDAFN is the atom
whose function definition is being compiled;
GLEXPR is the GLAMBDA expression to be compiled.
The compiled function is saved on the property list
of GLAMBDAFN under the indicator GLCOMPILED.
The property GLRESULTTYPE is the RESULT declaration,
if specified; GLGLOBALS is a list of global
variables referenced and their types.)
(DECLARE (SPECVARS GLAMBDAFN GLGLOBALVARS))
(PROG (NEWARGS NEWEXPR GLNATOM GLTOPCTX RESULTTYPE GLGLOBALVARS
RESULT GLSEPATOM GLSEPPTR VALBUSY EXPRSTACK GLTU
GLNRECURSIONS)
(SETQ GLSEPPTR 0)
(SETQ GLNRECURSIONS 0)
[COND
((NOT GLQUIETFLG)
(PRINT (LIST (QUOTE GLCOMP)
GLAMBDAFN]
(SETQ EXPRSTACK (LIST GLEXPR))
(SETQ GLNATOM 0)
(SETQ GLTOPCTX (LIST NIL))
(SETQ GLTU GLTYPESUSED)
(SETQ GLTYPESUSED NIL) (* Process the argument
list of the GLAMBDA.)
(SETQ NEWARGS (GLDECL (CADR GLEXPR)
(QUOTE (T NIL))
GLTOPCTX GLAMBDAFN ARGTYPES))
(* See if there is a
RESULT declaration.)
(SETQ GLEXPR (CDDR GLEXPR))
(GLSKIPCOMMENTS)
(GLRESGLOBAL)
(GLSKIPCOMMENTS)
(GLRESGLOBAL)
(SETQ VALBUSY (NULL (CDR GLEXPR)))
(SETQ NEWEXPR (GLPROGN GLEXPR (CONS NIL GLTOPCTX)))
(PUTPROP GLAMBDAFN (QUOTE GLRESULTTYPE)
(OR RESULTTYPE (CADR NEWEXPR)))
(PUTPROP GLAMBDAFN (QUOTE GLTYPESUSED)
GLTYPESUSED)
(GLSAVEFNTYPES GLAMBDAFN GLTYPESUSED)
(SETQ RESULT (GLUNWRAP (CONS (QUOTE LAMBDA)
(CONS NEWARGS (CAR NEWEXPR)))
T))
(SETQ GLTYPESUSED GLTU)
(RETURN RESULT])
(GLCOMPABSTRACT
[LAMBDA (FN INSTFN TYPESUBS FNSUBS ARGTYPES)
(* GSN " 2-FEB-83 14:52"
)
(* Compile an abstract function into an instance
function given the specified set of type
substitutions and function substitutions.)
(PROG (TMP)
[COND
(INSTFN)
((SETQ TMP (ASSOC FN FNSUBS))
(SETQ INSTFN (CDR TMP)))
(T (SETQ INSTFN (GLINSTANCEFNNAME FN]
(SETQ FNSUBS (CONS (CONS FN INSTFN)
FNSUBS)) (* Now compile the
abstract function with
the specified type
substitutions.)
(PUTD INSTFN (GLCOMP INSTFN (GLGETD FN)
TYPESUBS FNSUBS ARGTYPES))
(RETURN INSTFN])
(GLCOMPCOMS
[LAMBDA (COMSLIST PRINTFLG) (* edited:
"11-OCT-82 09:54")
(* Compile all the
GLAMBDA funtions on a
COMS list.)
(PROG (FNS)
LP [COND
((NULL COMSLIST)
(RETURN))
((NLISTP (CAR COMSLIST)))
((EQ (CAAR COMSLIST)
(QUOTE FNS))
[SETQ FNS (COND
((EQ (CADAR COMSLIST)
(QUOTE *))
(EVAL (CADDAR COMSLIST)))
(T (CDAR COMSLIST]
(MAPC FNS (FUNCTION (LAMBDA (X)
(COND
((EQ (CAR (GLGETD X))
(QUOTE GLAMBDA))
(GLCOMPILE X)
(COND
(PRINTFLG (TERPRI)
(TERPRI)
(TERPRI)
(PRINT X)
(PRINTDEF (GLGETD X))
(TERPRI)
(PRINTDEF (GETPROP
X
(QUOTE GLCOMPILED]
(SETQ COMSLIST (CDR COMSLIST))
(GO LP])
(GLCOMPEXPR
[LAMBDA (CODE VARLST) (* GSN "10-FEB-83 15:09"
)
(* Compile a GLISP expression.
CODE is a GLISP expression. VARLST is a list of
lists (VAR TYPE). The result is a list
(OBJCODE TYPE) where OBJCODE is the Lisp code
corresponding to CODE and TYPE is the type returned
by OBJCODE.)
(PROG (OBJCODE GLNATOM CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK
GLTOPCTX GLGLOBALVARS GLTYPESUBS FAULTFN
GLNRECURSIONS)
(SETQ FAULTFN (QUOTE GLCOMPEXPR))
(SETQ GLNRECURSIONS 0)
(SETQ GLNATOM 0)
(SETQ VALBUSY T)
(SETQ GLSEPPTR 0)
(SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL)))
[MAPC VARLST (FUNCTION (LAMBDA (X)
(GLADDSTR (CAR X)
NIL
(CADR X)
CONTEXT]
(COND
((SETQ OBJCODE (GLPUSHEXPR CODE T CONTEXT T))
(RETURN (LIST (GLUNWRAP (CAR OBJCODE)
T)
(CADR OBJCODE])
(GLCOMPILE
[LAMBDA (FAULTFN) (* edited:
"27-MAY-82 12:58")
(* "GSN: "
"26-Jun-81 11:00")
(* Compile the function definition stored for the
atom FAULTFN using the GLISP compiler.)
(GLAMBDATRAN (GLGETD FAULTFN))
FAULTFN])
(GLCOMPILE?
[LAMBDA (FN) (* edited:
" 4-MAY-82 11:13")
(* Compile FN if not
already compiled.)
(OR (GETPROP FN (QUOTE GLCOMPILED))
(GLCOMPILE FN])
(GLCOMPMSG
[LAMBDA (OBJECT MSGLST ARGLIST CONTEXT) (* GSN "10-FEB-83 15:33"
)
(* Compile a Message. MSGLST is the Message list,
consisting of message selector, code, and properties
defined with the message.)
(PROG (RESULT)
[COND
((IGREATERP (SETQ GLNRECURSIONS (ADD1 GLNRECURSIONS))
9)
(RETURN (GLERROR (QUOTE GLCOMPMSG)
(LIST
"Infinite loop detected in compiling"
(CAR MSGLST)
"for object of type"
(CADR OBJECT]
(SETQ RESULT (GLCOMPMSGB OBJECT MSGLST ARGLIST CONTEXT))
(SETQ GLNRECURSIONS (SUB1 GLNRECURSIONS))
(RETURN RESULT])
(GLCOMPMSGB
[LAMBDA (OBJECT MSGLST ARGLIST CONTEXT) (* GSN "10-FEB-83 15:13"
)
(* Compile a Message. MSGLST is the Message list,
consisting of message selector, code, and properties
defined with the message.)
(DECLARE (SPECVARS GLPROGLST))
(PROG (GLPROGLST RESULTTYPE METHOD RESULT VTYPE)
(SETQ RESULTTYPE (LISTGET (CDDR MSGLST)
(QUOTE RESULT)))
(SETQ METHOD (CADR MSGLST))
[COND
[(ATOM METHOD) (* Function name is
specified.)
(COND
[(LISTGET (CDDR MSGLST)
(QUOTE OPEN))
(RETURN (GLCOMPOPEN METHOD (CONS OBJECT ARGLIST)
(CONS (CADR OBJECT)
(LISTGET (CDDR MSGLST)
(QUOTE ARGTYPES)))
RESULTTYPE
(LISTGET (CDDR MSGLST)
(QUOTE SPECVARS]
(T
(RETURN
(LIST
[CONS METHOD
(CONS (CAR OBJECT)
(MAPCAR ARGLIST
(FUNCTION CAR]
(OR [GLRESULTTYPE
METHOD
(CONS (CADR OBJECT)
(MAPCAR ARGLIST
(FUNCTION CADR]
(LISTGET (CDDR MSGLST)
(QUOTE RESULT]
[(NLISTP METHOD)
(RETURN (GLERROR (QUOTE GLCOMPMSG)
(LIST
"The form of Response is illegal for message"
(CAR MSGLST]
([AND (LISTP (CAR METHOD))
(MEMB (CAAR METHOD)
(QUOTE (virtual Virtual VIRTUAL]
[OR (SETQ VTYPE (LISTGET (CDDR MSGLST)
(QUOTE VTYPE)))
(PROGN (SETQ VTYPE (GLMAKEVTYPE (CADR OBJECT)
(CAR METHOD)))
(NCONC MSGLST (LIST (QUOTE VTYPE)
VTYPE]
(RETURN (LIST (CAR OBJECT)
VTYPE] (* The Method is a list
of stuff to be compiled
open.)
(SETQ CONTEXT (LIST NIL))
(COND
((ATOM (CAR OBJECT))
(GLADDSTR (LIST (QUOTE PROG1)
(CAR OBJECT))
(QUOTE self)
(CADR OBJECT)
CONTEXT))
((AND (LISTP (CAR OBJECT))
(EQ (CAAR OBJECT)
(QUOTE PROG1))
(ATOM (CADAR OBJECT))
(NULL (CDDAR OBJECT)))
(GLADDSTR (CAR OBJECT)
(QUOTE self)
(CADR OBJECT)
CONTEXT))
(T (SETQ GLPROGLST (CONS (LIST (QUOTE self)
(CAR OBJECT))
GLPROGLST))
(GLADDSTR (QUOTE self)
NIL
(CADR OBJECT)
CONTEXT)))
(SETQ RESULT (GLPROGN METHOD CONTEXT))
(* If more than one
expression resulted,
embed in a PROGN.)
[RPLACA RESULT (COND
((CDAR RESULT)
(CONS (QUOTE PROGN)
(CAR RESULT)))
(T (CAAR RESULT]
(RETURN (LIST (COND
[GLPROGLST (GLGENCODE
(LIST (QUOTE PROG)
GLPROGLST
(LIST (QUOTE RETURN)
(CAR RESULT]
(T (CAR RESULT)))
(OR RESULTTYPE (CADR RESULT])
(GLCOMPMSGL
[LAMBDA (OBJECT PROPTYPE MSGLST ARGS CONTEXT)
(* GSN "16-FEB-83 17:37"
)
(* Attempt to compile code for a message list for an
object. OBJECT is the destination, in the form
(<code> <type>), PROPTYPE is the property type
(ADJ etc.), MSGLST is the message list, and ARGS is
a list of arguments of the form
(<code> <type>). The result is of the form
(<code> <type>), or NIL if failure.)
(PROG (TYPE SELECTOR NEWFN NEWMSGLST)
(SETQ TYPE (GLXTRTYPE (CADR OBJECT)))
(SETQ SELECTOR (CAR MSGLST))
(RETURN
(COND
((LISTGET (CDDR MSGLST)
(QUOTE MESSAGE))
(SETQ CONTEXT (LIST NIL))
(GLADDSTR (CAR OBJECT)
(QUOTE self)
TYPE CONTEXT)
(LIST
[COND
[(EQ PROPTYPE (QUOTE MSG))
(CONS
(QUOTE SEND)
(CONS (CAR OBJECT)
(CONS SELECTOR
(MAPCAR ARGS
(FUNCTION CAR]
(T
(CONS
(QUOTE SENDPROP)
(CONS
(CAR OBJECT)
(CONS SELECTOR
(CONS PROPTYPE
(MAPCAR ARGS
(FUNCTION CAR]
(GLEVALSTR (LISTGET (CDDR MSGLST)
(QUOTE RESULT))
CONTEXT)))
((LISTGET (CDDR MSGLST)
(QUOTE SPECIALIZE))
(SETQ NEWFN (GLINSTANCEFNNAME (CADR MSGLST)))
(SETQ NEWMSGLST (LIST (CAR MSGLST)
NEWFN
(QUOTE SPECIALIZATION)
T))
(GLADDPROP (CADR OBJECT)
PROPTYPE NEWMSGLST)
[GLCOMPABSTRACT (CADR MSGLST)
NEWFN NIL NIL
(CONS (CADR OBJECT)
(MAPCAR ARGS
(FUNCTION CADR]
[PUTPROP NEWFN (QUOTE GLSPECIALIZATION)
(CONS (LIST (CADR MSGLST)
(CADR OBJECT)
PROPTYPE SELECTOR)
(GETPROP NEWFN (QUOTE GLSPECIALIZATION]
[NCONC NEWMSGLST (LIST (QUOTE RESULT)
(GETPROP NEWFN (QUOTE
GLRESULTTYPE]
(GLCOMPMSG OBJECT NEWMSGLST ARGS CONTEXT))
(T (GLCOMPMSG OBJECT MSGLST ARGS CONTEXT])
(GLCOMPOPEN
[LAMBDA (FN ARGS ARGTYPES RESULTTYPE SPCVARS)
(* GSN " 1-JUN-83 17:23"
)
(* Compile the function FN Open, given as arguments
ARGS with argument types ARGTYPES.
Types may be defined in the definition of function
FN (which may be either a GLAMBDA or LAMBDA
function) or by ARGTYPES; ARGTYPES takes
precedence.)
(DECLARE (SPECVARS GLPROGLST))
(PROG (PTR FNDEF GLPROGLST NEWEXPR CONTEXT NEWARGS)
(* Put a new level on
top of CONTEXT.)
(SETQ CONTEXT (LIST NIL))
(SETQ FNDEF (GLGETD FN)) (* Get the parameter
declarations and add to
CONTEXT.)
(GLDECL (CADR FNDEF)
(QUOTE (T NIL))
CONTEXT NIL NIL)
(* Make the function parameters into "names" and put
in the values, hiding any which are simple
variables.)
(SETQ PTR (DREVERSE (CAR CONTEXT)))
(RPLACA CONTEXT NIL)
LP [COND
((NULL PTR)
(GO B))
((NULL ARGTYPES)
(SETQ ARGTYPES (QUOTE (NIL]
(COND
((EQ ARGS T)
(GLADDSTR (CAAR PTR)
NIL
(OR (CAR ARGTYPES)
(CADDAR PTR))
CONTEXT)
(SETQ NEWARGS (CONS (CAAR PTR)
NEWARGS)))
((AND (ATOM (CAAR ARGS))
(NEQ SPCVARS T)
(NOT (MEMB (CAAR PTR)
SPCVARS)))
(* Wrap the atom in a PROG1 so it won't match as a
name; the PROG1 will generally be stripped later.)
(GLADDSTR (LIST (QUOTE PROG1)
(CAAR ARGS))
(CAAR PTR)
(OR (CADAR ARGS)
(CAR ARGTYPES)
(CADDAR PTR))
CONTEXT))
((AND (NEQ SPCVARS T)
(NOT (MEMB (CAAR PTR)
SPCVARS))
(LISTP (CAAR ARGS))
(EQ (CAAAR ARGS)
(QUOTE PROG1))
(ATOM (CADAAR ARGS))
(NULL (CDDAAR ARGS)))
(GLADDSTR (CAAR ARGS)
(CAAR PTR)
(OR (CADAR ARGS)
(CAR ARGTYPES)
(CADDAR PTR))
CONTEXT))
(T
(* Since the actual argument is not atomic, make a
PROG variable for it.)
(SETQ GLPROGLST (CONS (LIST (CAAR PTR)
(CAAR ARGS))
GLPROGLST))
(GLADDSTR (CAAR PTR)
(CADAR PTR)
(OR (CADAR ARGS)
(CAR ARGTYPES)
(CADDAR PTR))
CONTEXT)))
(SETQ PTR (CDR PTR))
[COND
((LISTP ARGS)
(SETQ ARGS (CDR ARGS]
(SETQ ARGTYPES (CDR ARGTYPES))
(GO LP)
B (SETQ FNDEF (CDDR FNDEF)) (* Get rid of comments
at start of function.)
C (COND
([AND FNDEF (LISTP (CAR FNDEF))
(MEMB (CAAR FNDEF)
(QUOTE (RESULT * GLOBAL]
(SETQ FNDEF (CDR FNDEF))
(GO C)))
(SETQ NEWEXPR (GLPROGN FNDEF CONTEXT))
(* Get rid of atomic
result if it isnt busy
outside.)
(COND
([AND (NOT VALBUSY)
(CDAR EXPR)
(OR [ATOM (CADR (SETQ PTR (NLEFT (CAR NEWEXPR)
2]
(AND (LISTP (CADR PTR))
(EQ (CAADR PTR)
(QUOTE PROG1))
(ATOM (CADADR PTR))
(NULL (CDDADR PTR]
(RPLACD PTR NIL)))
[SETQ RESULT
(LIST (COND
[GLPROGLST (SETQ PTR (LAST (CAR NEWEXPR)))
(RPLACA PTR (LIST (QUOTE RETURN)
(CAR PTR)))
(GLGENCODE (CONS (QUOTE PROG)
(CONS (DREVERSE
GLPROGLST)
(CAR NEWEXPR]
((CDAR NEWEXPR)
(CONS (QUOTE PROGN)
(CAR NEWEXPR)))
(T (CAAR NEWEXPR)))
(OR RESULTTYPE (GLRESULTTYPE FN NIL)
(CADR NEWEXPR]
[COND
((EQ ARGS T)
(RPLACA RESULT (LIST (QUOTE LAMBDA)
(DREVERSE NEWARGS)
(CAR RESULT]
(RETURN RESULT])
(GLCONSTANTTYPE
[LAMBDA (EXPR) (* edited:
"14-MAR-83 17:07")
(* Attempt to infer the
type of a constant
expression.)
(PROG (TMP TYPES)
(COND
([SETQ TMP (COND
((FIXP EXPR)
(QUOTE INTEGER))
((NUMBERP EXPR)
(QUOTE NUMBER))
((ATOM EXPR)
(QUOTE ATOM))
((STRINGP EXPR)
(QUOTE STRING))
((NLISTP EXPR)
(QUOTE ANYTHING))
([NOT (OR (NULL (CDR EXPR))
(LISTP (CDR EXPR]
(QUOTE ANYTHING))
((EVERY EXPR (FUNCTION FIXP))
(QUOTE (LISTOF INTEGER)))
((EVERY EXPR (FUNCTION NUMBERP))
(QUOTE (LISTOF NUMBER)))
((EVERY EXPR (FUNCTION ATOM))
(QUOTE (LISTOF ATOM)))
((EVERY EXPR (FUNCTION STRINGP))
(QUOTE (LISTOF STRING]
(RETURN TMP)))
(SETQ TYPES (MAPCAR EXPR (FUNCTION GLCONSTANTTYPE)))
(COND
[[EVERY (CDR TYPES)
(FUNCTION (LAMBDA (Y)
(EQUAL Y (CAR TYPES]
(RETURN (LIST (QUOTE LISTOF)
(CAR TYPES]
(T (RETURN (CONS (QUOTE LIST)
TYPES])
(GLCONST?
[LAMBDA (X) (* edited:
"31-AUG-82 15:38")
(* Test X to see if it
represents a
compile-time constant
value.)
(OR (NULL X)
(EQ X T)
(NUMBERP X)
(AND (LISTP X)
(EQ (CAR X)
(QUOTE QUOTE))
(ATOM (CADR X)))
(AND (ATOM X)
(GETPROP X (QUOTE GLISPCONSTANTFLG])
(GLCONSTSTR?
[LAMBDA (X) (* edited:
" 9-DEC-82 17:02")
(* Test to see if X is a
constant structure.)
(OR (GLCONST? X)
(AND (LISTP X)
(OR (EQ (CAR X)
(QUOTE QUOTE))
[AND (MEMB (CAR X)
(QUOTE (COPY APPEND)))
(LISTP (CADR X))
(EQ (CAADR X)
(QUOTE QUOTE))
(OR (NEQ (CAR X)
(QUOTE APPEND))
(NULL (CDDR X))
(NULL (CADDR X]
(AND (EQ (CAR X)
(QUOTE LIST))
(EVERY (CDR X)
(FUNCTION GLCONSTSTR?)))
(AND (EQ (CAR X)
(QUOTE CONS))
(GLCONSTSTR? (CADR X))
(GLCONSTSTR? (CADDR X])
(GLCONSTVAL
[LAMBDA (X) (* edited:
" 9-DEC-82 17:07")
(*
"Get the value of a compile-time constant")
(COND
((OR (NULL X)
(EQ X T)
(NUMBERP X))
X)
((AND (LISTP X)
(EQ (CAR X)
(QUOTE QUOTE)))
(CADR X))
[(LISTP X)
(COND
([AND (MEMB (CAR X)
(QUOTE (COPY APPEND)))
(LISTP (CADR X))
(EQ (CAADR X)
(QUOTE QUOTE))
(OR (NULL (CDDR X))
(NULL (CADDR X]
(CADADR X))
((EQ (CAR X)
(QUOTE LIST))
(MAPCAR (CDR X)
(FUNCTION GLCONSTVAL)))
[(EQ (CAR X)
(QUOTE CONS))
(CONS (GLCONSTVAL (CADR X))
(GLCONSTVAL (CADDR X]
(T (ERROR]
((AND (ATOM X)
(GETPROP X (QUOTE GLISPCONSTANTFLG)))
(GETPROP X (QUOTE GLISPCONSTANTVAL)))
(T (ERROR])
(GLCP
[LAMBDA (FN) (* edited:
" 5-OCT-82 15:23")
(SETQ FN (OR FN GLLASTFNCOMPILED))
(COND
((NOT (GLGETD FN))
(PRIN1 FN)
(PRIN1 " ?")
(TERPRI))
(T (GLCOMPILE FN)
(GLP FN])
(GLDECL
[LAMBDA (LST FLGS GLTOPCTX FN ARGTYPES) (* GSN "28-JAN-83 09:29"
) (* edited:
" 1-Jun-81 16:02")
(* edited:
"24-Apr-81 12:02")
(* edited:
"21-Apr-81 11:24")
(* Process a declaration list from a GLAMBDA
expression. Each element of the list is of the form
<var>, <var>:<str-descr>, :<str-descr>, or <var>:
(A <str-descr>) or (A <str-descr>). Forms without a
variable are accepted only if NOVAROK is true.
If VALOK is true, a PROG form
(variable value) is allowed.
The result is a list of variable names.)
(DECLARE (SPECVARS ARGTYPES RESULT))
(PROG (RESULT FIRST SECOND THIRD TOP TMP EXPR VARS STR NOVAROK
VALOK)
(SETQ NOVAROK (CAR FLGS))
(SETQ VALOK (CADR FLGS))
(COND
((NULL GLTOPCTX)
(ERROR)))
A (* Get the next
variable/description
from LST)
(COND
((NULL LST)
(SETQ ARGTYPES NIL)
(SETQ CONTEXT GLTOPCTX)
[MAPC (CAR GLTOPCTX)
(FUNCTION (LAMBDA (S)
(SETQ ARGTYPES (CONS (GLEVALSTR (CADDR S)
GLTOPCTX)
ARGTYPES))
(RPLACA (CDDR S)
(CAR ARGTYPES]
(SETQ RESULT (DREVERSE RESULT))
(COND
(FN (PUTPROP FN (QUOTE GLARGUMENTTYPES)
ARGTYPES)))
(RETURN RESULT)))
(SETQ TOP (pop LST))
(COND
((NOT (ATOM TOP))
(GO B)))
(SETQ VARS NIL)
(SETQ STR NIL)
(GLSEPINIT TOP)
(SETQ FIRST (GLSEPNXT))
(SETQ SECOND (GLSEPNXT))
[COND
((EQ FIRST (QUOTE :))
(COND
[(NULL SECOND)
(COND
((AND NOVAROK LST (GLOKSTR? (CAR LST)))
(GLDECLDS (GLMKVAR)
(pop LST))
(GO A))
(T (GO E]
((AND NOVAROK (GLOKSTR? SECOND)
(NULL (GLSEPNXT)))
(GLDECLDS (GLMKVAR)
SECOND)
(GO A))
(T (GO E]
D
(* At least one variable name has been found.
Collect other variable names until a <type> is
found.)
(SETQ VARS (NCONC1 VARS FIRST))
(COND
((NULL SECOND)
(GO C))
[(EQ SECOND (QUOTE :))
(COND
((AND (SETQ THIRD (GLSEPNXT))
(GLOKSTR? THIRD)
(NULL (GLSEPNXT)))
(SETQ STR THIRD)
(GO C))
((AND (NULL THIRD)
(GLOKSTR? (CAR LST)))
(SETQ STR (pop LST))
(GO C))
(T (GO E]
[(EQ SECOND (QUOTE ,))
(COND
((SETQ FIRST (GLSEPNXT))
(SETQ SECOND (GLSEPNXT))
(GO D))
((ATOM (CAR LST))
(GLSEPINIT (pop LST))
(SETQ FIRST (GLSEPNXT))
(SETQ SECOND (GLSEPNXT))
(GO D]
(T (GO E)))
C (* Define the <type> for
each variable on VARS.)
[MAPC VARS (FUNCTION (LAMBDA (X)
(GLDECLDS X STR]
(GO A)
B
(* The top of LST is non-atomic.
Must be either (A <type>) or
(<var> <value>).)
(COND
((AND (GL-A-AN? (CAR TOP))
NOVAROK
(GLOKSTR? TOP))
(GLDECLDS (GLMKVAR)
TOP))
((AND VALOK (NOT (GL-A-AN? (CAR TOP)))
(ATOM (CAR TOP))
(CDR TOP))
(SETQ EXPR (CDR TOP))
(SETQ TMP (GLDOEXPR NIL GLTOPCTX T))
(COND
(EXPR (GO E)))
(GLADDSTR (CAR TOP)
NIL
(CADR TMP)
GLTOPCTX)
(SETQ RESULT (CONS (LIST (CAR TOP)
(CAR TMP))
RESULT)))
((AND NOVAROK (GLOKSTR? TOP))
(GLDECLDS (GLMKVAR)
TOP))
(T (GO E)))
(GO A)
E (GLERROR (QUOTE GLDECL)
(LIST "Bad argument structure" LST))
(RETURN])
(GLDECLDS
[LAMBDA (ATM STR) (* GSN "26-JAN-83 13:17"
) (* "GSN: "
" 2-Jan-81 13:39")
(* Add ATM to the RESULT
list of GLDECL, and
declare its structure.)
(PROG NIL (* If a substitution
exists for this type,
use it.)
[COND
(ARGTYPES (SETQ STR (pop ARGTYPES)))
(GLTYPESUBS (SETQ STR (GLSUBSTTYPE STR GLTYPESUBS]
(SETQ RESULT (CONS ATM RESULT))
(GLADDSTR ATM NIL STR GLTOPCTX])
(GLDECLS
[LAMBDA (VARS TYPES CONTEXT) (* GSN "26-JAN-83 10:28"
) (* Declare variables and
types in top of
CONTEXT.)
(PROG NIL
A (COND
((NULL VARS)
(RETURN)))
(GLADDSTR (CAR VARS)
NIL
(CAR TYPES)
CONTEXT)
(SETQ VARS (CDR VARS))
(SETQ TYPES (CDR TYPES))
(GO A])
(GLDOA
[LAMBDA (EXPR) (* GSN "25-FEB-83 16:41"
) (* edited:
"25-Jun-81 15:26")
(* Function to compile
an expression of the
form (A <type> ...))
(PROG (TYPE UNITREC TMP)
(SETQ TYPE (CADR EXPR))
(COND
[(AND (LISTP TYPE)
(EQ (CAR TYPE)
(QUOTE TYPEOF)))
(SETQ TYPE (GLGETTYPEOF TYPE))
(GLNOTICETYPE TYPE)
(RETURN (GLMAKESTR TYPE (CDDR EXPR]
[(GLGETSTR TYPE)
(GLNOTICETYPE TYPE)
(RETURN (GLMAKESTR TYPE (CDDR EXPR]
([AND (SETQ UNITREC (GLUNIT? TYPE))
(SETQ TMP (ASSOC (QUOTE A)
(CADDR UNITREC]
(RETURN (APPLY* (CDR TMP)
EXPR)))
(T (GLERROR (QUOTE GLDOA)
(LIST "The type" TYPE "is not defined."])
(GLDOCASE
[LAMBDA (EXPR) (* GSN " 6-JUN-83 16:43"
) (* Compile code for Case
statement.)
(* Modified 6 June 83 to allow GLISP constants as
CASE selectors as suggested by Jed Marti of Rand.)
(PROG (SELECTOR SELECTORTYPE RESULT TMP RESULTTYPE TYPEOK
ELSECLAUSE TMPB)
(SETQ TYPEOK T)
(SETQ TMP (GLPUSHEXPR (LIST (CADR EXPR))
NIL CONTEXT T))
(SETQ SELECTOR (CAR TMP))
(SETQ SELECTORTYPE (CADR TMP))
(SETQ EXPR (CDDR EXPR)) (* Get rid of "of" if
present)
[COND
((MEMB (CAR EXPR)
(QUOTE (OF Of of)))
(SETQ EXPR (CDR EXPR]
A [COND
((NULL EXPR)
(RETURN (LIST [GLGENCODE (CONS (QUOTE SELECTQ)
(CONS SELECTOR
(NCONC1 RESULT
ELSECLAUSE]
RESULTTYPE)))
((MEMB (CAR EXPR)
(QUOTE (ELSE Else else)))
(SETQ TMP (GLPROGN (CDR EXPR)
CONTEXT))
[SETQ ELSECLAUSE (COND
((CDAR TMP)
(CONS (QUOTE PROGN)
(CAR TMP)))
(T (CAAR TMP]
(SETQ EXPR NIL))
(T
(SETQ TMP (GLPROGN (CDAR EXPR)
CONTEXT))
(SETQ RESULT
(NCONC1
RESULT
(CONS
[COND
((ATOM (CAAR EXPR))
(OR (AND (SETQ TMPB (GLSTRPROP SELECTORTYPE
(QUOTE VALUES)
(CAAR EXPR)
NIL))
(CADR TMPB))
(AND (GLCONST? (CAAR EXPR))
(GLCONSTVAL (CAAR EXPR)))
(CAAR EXPR)))
(T
(MAPCAR
(CAAR EXPR)
(FUNCTION (LAMBDA (X)
(OR (AND (SETQ TMPB (GLSTRPROP
SELECTORTYPE
(QUOTE VALUES)
X NIL))
(CADR TMPB))
(AND (GLCONST? X)
(GLCONSTVAL X))
X]
(CAR TMP]
(* If all the result types are the same, then we
know the result of the Case statement.)
[COND
(TYPEOK (COND
((NULL RESULTTYPE)
(SETQ RESULTTYPE (CADR TMP)))
((EQUAL RESULTTYPE (CADR TMP)))
(T (SETQ TYPEOK NIL)
(SETQ RESULTTYPE NIL]
[COND
(EXPR (SETQ EXPR (CDR EXPR]
(GO A])
(GLDOCOND
[LAMBDA (CONDEXPR) (* edited:
"23-APR-82 14:38")
(* "GSN: "
"21-Apr-81 11:24")
(* Compile a COND
expression.)
(PROG (RESULT TMP TYPEOK RESULTTYPE)
(SETQ TYPEOK T)
A (COND
((NULL (SETQ CONDEXPR (CDR CONDEXPR)))
(GO B)))
(SETQ TMP (GLPROGN (CAR CONDEXPR)
CONTEXT))
[COND
((NEQ (CAAR TMP)
NIL)
(SETQ RESULT (NCONC1 RESULT (CAR TMP)))
(COND
(TYPEOK (COND
((NULL RESULTTYPE)
(SETQ RESULTTYPE (CADR TMP)))
((EQUAL RESULTTYPE (CADR TMP)))
(T (SETQ RESULTTYPE NIL)
(SETQ TYPEOK NIL]
(COND
((NEQ (CAAR TMP)
T)
(GO A)))
B (RETURN (LIST (COND
((AND (NULL (CDR RESULT))
(EQ (CAAR RESULT)
T))
(CONS (QUOTE PROGN)
(CDAR RESULT)))
(T (CONS (QUOTE COND)
RESULT)))
(AND TYPEOK RESULTTYPE])
(GLDOEXPR
[LAMBDA (START CONTEXT VALBUSY) (* GSN "22-JUL-83 14:10"
) (* "GSN: "
"23-Sep-81 17:08")
(* "GSN: "
"24-Aug-81 13:25")
(* "GSN: "
"19-Jun-81 17:03")
(* "GSN: "
"23-Apr-81 10:53")
(* Compile a single expression.
START is set if EXPR is the start of a new
expression, i.e., if EXPR might be a function call.
The global variable EXPR is the expression, CONTEXT
the context in which it is compiled.
VALBUSY is T if the value of the expression is
needed outside the expression.
The value is a list of the new expression and its
value-description.)
(PROG (FIRST TMP RESULT)
(SETQ EXPRSTACK (CONS EXPR EXPRSTACK))
(COND
((NLISTP EXPR)
(GLERROR (QUOTE GLDOEXPR)
(LIST "Expression is not a list."))
(GO OUT))
((AND (NOT START)
(STRINGP (CAR EXPR)))
(GO A))
((OR (NOT (LITATOM (CAR EXPR)))
(NOT START))
(GO A)))
(* Test the initial atom to see if it is a function
name. It is assumed to be a function name if it
doesnt contain any GLISP operators and the following
atom doesnt start with a GLISP binary operator.)
(COND
((AND (EQ GLLISPDIALECT (QUOTE INTERLISP))
(EQ (CAR EXPR)
(QUOTE *)))
(SETQ RESULT (LIST EXPR NIL))
(GO OUT))
((MEMB (CAR EXPR)
(QUOTE (QUOTE Quote quote)))
(SETQ FIRST (CAR EXPR))
(GO B)))
(GLSEPINIT (CAR EXPR)) (* See if the initial
atom contains an
expression operator.)
(COND
[(NEQ (SETQ FIRST (GLSEPNXT))
(CAR EXPR))
(COND
((OR (MEMB (CAR EXPR)
(QUOTE (APPLY* BLKAPPLY* PACK* PP*)))
(GETD (CAR EXPR))
(GETPROP (CAR EXPR)
(QUOTE MACRO))
(AND (NEQ FIRST (QUOTE ~))
(GLOPERATOR? FIRST)))
(GLSEPCLR)
(SETQ FIRST (CAR EXPR))
(GO B))
(T (GLSEPCLR)
(GO A]
((OR (EQ FIRST (QUOTE ~))
(EQ FIRST (QUOTE -)))
(GLSEPCLR)
(GO A))
([OR (NLISTP (CDR EXPR))
(NOT (LITATOM (CADR EXPR]
(GO B))) (* See if the initial
atom is followed by an
expression operator.)
(GLSEPINIT (CADR EXPR))
(SETQ TMP (GLSEPNXT))
(GLSEPCLR)
(COND
((GLOPERATOR? TMP)
(GO A))) (* The EXPR is a
function reference.
Test for system
functions.)
B (SETQ RESULT (SELECTQ FIRST
[(QUOTE Quote quote)
(LIST EXPR (GLCONSTANTTYPE
(CADR EXPR]
((GO Go go)
(LIST EXPR NIL))
((PROG Prog
prog
RESETVARS)
(GLDOPROG EXPR CONTEXT))
((FUNCTION Function function)
(GLDOFUNCTION EXPR NIL CONTEXT T))
((SETQ Setq setq)
(GLDOSETQ EXPR))
((COND
Cond cond)
(GLDOCOND EXPR))
((RETURN Return return)
(GLDORETURN EXPR))
((FOR For for)
(GLDOFOR EXPR))
((THE The the)
(GLDOTHE EXPR))
((THOSE Those those)
(GLDOTHOSE EXPR))
((IF If if)
(GLDOIF EXPR CONTEXT))
((A a AN An an)
(GLDOA EXPR))
((← SEND Send send GLSEND glsend)
(GLDOSEND EXPR))
((PROGN PROG2)
(GLDOPROGN EXPR))
(PROG1 (GLDOPROG1 EXPR CONTEXT))
((SELECTQ CASEQ)
(GLDOSELECTQ EXPR CONTEXT))
((WHILE While while)
(GLDOWHILE EXPR CONTEXT))
((REPEAT Repeat repeat)
(GLDOREPEAT EXPR))
((CASE Case case)
(GLDOCASE EXPR))
((MAP MAPLIST MAPCON MAPC MAPCAR
MAPCONC MAPCAN)
(GLDOMAP EXPR))
(GLUSERFN EXPR)))
(GO OUT)
A
(* The current EXPR is possibly a GLISP expression.
Parse the next subexpression using GLPARSEXPR.)
(SETQ RESULT (GLPARSEXPR))
OUT (SETQ EXPRSTACK (CDR EXPRSTACK))
(RETURN RESULT])
(GLDOFOR
[LAMBDA (EXPR) (* GSN " 2-MAR-83 17:03"
) (* edited:
"21-Apr-81 11:25")
(* Compile code for a
FOR loop.)
(DECLARE (SPECVARS DOMAINNAME))
(PROG (DOMAIN DOMAINNAME DTYPE ORIGEXPR LOOPVAR NEWCONTEXT
LOOPCONTENTS SINGFLAG LOOPCOND COLLECTCODE)
(SETQ ORIGEXPR EXPR)
(pop EXPR)
(* Parse the forms (FOR EACH <set> ...) and
(FOR <var> IN <set> ...))
(COND
((MEMB (CAR EXPR)
(QUOTE (EACH Each each)))
(SETQ SINGFLAG T)
(pop EXPR))
([AND (ATOM (CAR EXPR))
(MEMB (CADR EXPR)
(QUOTE (IN In in]
(SETQ LOOPVAR (pop EXPR))
(pop EXPR))
(T (GO X))) (* Now get the <set>)
(COND
((NULL (SETQ DOMAIN (GLDOMAIN SINGFLAG)))
(GO X)))
(SETQ DTYPE (GLXTRTYPE (CADR DOMAIN)))
[COND
[(OR (NULL DTYPE)
(EQ DTYPE (QUOTE ANYTHING)))
(SETQ DTYPE (QUOTE (LISTOF ANYTHING]
((OR (NLISTP DTYPE)
(NEQ (CAR DTYPE)
(QUOTE LISTOF)))
(COND
((OR (AND [LISTP (SETQ DTYPE (GLXTRTYPE (GLGETSTR
DTYPE]
(EQ (CAR DTYPE)
(QUOTE LISTOF)))
(NULL DTYPE)))
(T (GLERROR (QUOTE GLDOFOR)
(LIST
"Warning: The domain of a FOR loop is of type"
DTYPE "which is not a LISTOF type."))
(SETQ DTYPE (QUOTE (LISTOF ANYTHING]
(* Add a level onto the
context for the inside
of the loop.)
(SETQ NEWCONTEXT (CONS NIL CONTEXT))
(* If a loop variable
wasnt specified, make
one.)
(OR LOOPVAR (SETQ LOOPVAR (GLMKVAR)))
(GLADDSTR LOOPVAR (AND SINGFLAG DOMAINNAME)
(CADR DTYPE)
NEWCONTEXT) (* See if a condition is
specified. If so, add it
to LOOPCOND.)
[COND
((MEMB (CAR EXPR)
(QUOTE (WITH With with)))
(pop EXPR)
(SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE))
NEWCONTEXT NIL NIL)))
((MEMB (CAR EXPR)
(QUOTE (WHICH Which which WHO Who who THAT That that)
))
(pop EXPR)
(SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE))
NEWCONTEXT T T]
[COND
([AND EXPR (MEMB (CAR EXPR)
(QUOTE (when When WHEN]
(pop EXPR)
(SETQ LOOPCOND (GLANDFN LOOPCOND (GLDOEXPR NIL NEWCONTEXT
T]
[COND
((MEMB (CAR EXPR)
(QUOTE (collect Collect COLLECT)))
(pop EXPR)
(SETQ COLLECTCODE (GLDOEXPR NIL NEWCONTEXT T)))
(T (COND
((MEMB (CAR EXPR)
(QUOTE (DO Do do)))
(pop EXPR)))
(SETQ LOOPCONTENTS (CAR (GLPROGN EXPR NEWCONTEXT]
(RETURN (GLMAKEFORLOOP LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND
COLLECTCODE))
X (RETURN (GLUSERFN ORIGEXPR])
(GLDOFUNCTION
[LAMBDA (EXPR ARGTYPES CONTEXT VALBUSY) (* GSN "26-JAN-83 10:14"
)
(* Compile a functional expression.
TYPES is a list of argument types which is sent in
from outside, e.g. when a mapping function is
compiled.)
(PROG (NEWCODE RESULTTYPE PTR ARGS)
[COND
([NOT (AND (LISTP EXPR)
(MEMB (CAR EXPR)
(QUOTE (QUOTE FUNCTION]
(RETURN (GLPUSHEXPR EXPR T CONTEXT T)))
[(ATOM (CADR EXPR))
(RETURN (LIST EXPR (GLRESULTTYPE (CADR EXPR)
ARGTYPES]
([NOT (MEMB (CAADR EXPR)
(QUOTE (GLAMBDA LAMBDA]
(GLERROR (QUOTE GLDOFUNCTION)
(LIST "Bad functional form."]
(SETQ CONTEXT (CONS NIL CONTEXT))
(SETQ ARGS (GLDECL (CADADR EXPR)
(QUOTE (T NIL))
CONTEXT NIL NIL))
(SETQ PTR (DREVERSE (CAR CONTEXT)))
(RPLACA CONTEXT NIL)
LP (COND
((NULL PTR)
(GO B)))
(GLADDSTR (CAAR PTR)
NIL
(OR (CADDAR PTR)
(CAR ARGTYPES))
CONTEXT)
(SETQ PTR (CDR PTR))
(SETQ ARGTYPES (CDR ARGTYPES))
(GO LP)
B (SETQ NEWCODE (GLPROGN (CDDADR EXPR)
CONTEXT))
(RETURN (LIST [LIST (QUOTE FUNCTION)
(CONS (QUOTE LAMBDA)
(CONS ARGS (CAR NEWCODE]
(CADR NEWCODE])
(GLDOIF
[LAMBDA (EXPR CONTEXT) (* "GSN: "
"11-Feb-84 14:39")
(* "GSN: "
"14-Aug-81 16:47")
(* "GSN: "
"20-Apr-81 11:07")
(* Process an IF ...
THEN expression.)
(PROG (PRED ACTIONS CONDLIST TYPE TMP OLDCONTEXT)
(SETQ OLDCONTEXT CONTEXT)
(pop EXPR)
A [COND
((NULL EXPR)
(RETURN (LIST (CONS (QUOTE COND)
CONDLIST)
TYPE]
(SETQ CONTEXT (CONS NIL OLDCONTEXT))
(SETQ PRED (GLPREDICATE NIL CONTEXT NIL T))
(COND
((MEMB (CAR EXPR)
(QUOTE (THEN Then then)))
(pop EXPR)))
(SETQ ACTIONS (CONS (CAR PRED)
NIL))
(SETQ TYPE (CADR PRED))
C (SETQ CONDLIST (NCONC1 CONDLIST ACTIONS))
B (COND
((NULL EXPR)
(GO A))
((MEMB (CAR EXPR)
(QUOTE (ELSEIF ElseIf Elseif elseIf elseif)))
(pop EXPR)
(GO A))
((MEMB (CAR EXPR)
(QUOTE (ELSE Else else)))
(pop EXPR)
(SETQ ACTIONS (CONS T NIL))
(SETQ TYPE (QUOTE BOOLEAN))
(SETQ CONTEXT (CONS NIL OLDCONTEXT)) |
(GO C))
((SETQ TMP (GLDOEXPR NIL CONTEXT T))
(NCONC1 ACTIONS (CAR TMP))
(SETQ TYPE (CADR TMP))
(GO B))
(T (GLERROR (QUOTE GLDOIF)
(LIST "IF statement contains bad code."])
(GLDOLAMBDA
[LAMBDA (EXPR ARGTYPES CONTEXT) (* edited:
"16-DEC-81 15:47")
(* Compile a LAMBDA
expression for which the
ARGTYPES are given.)
(PROG (ARGS NEWEXPR VALBUSY)
(SETQ ARGS (CADR EXPR))
(SETQ CONTEXT (CONS NIL CONTEXT))
LP (COND
(ARGS (GLADDSTR (CAR ARGS)
NIL
(CAR ARGTYPES)
CONTEXT)
(SETQ ARGS (CDR ARGS))
(SETQ ARGTYPES (CDR ARGTYPES))
(GO LP)))
(SETQ VALBUSY T)
(SETQ NEWEXPR (GLPROGN (CDDR EXPR)
CONTEXT))
(RETURN (LIST (CONS (QUOTE LAMBDA)
(CONS (CADR EXPR)
(CAR NEWEXPR)))
(CADR NEWEXPR])
(GLDOMAIN
[LAMBDA (SINGFLAG) (* edited:
"30-MAY-82 16:12")
(* edited:
"17-Apr-81 16:51")
(* Get a domain specification from the EXPR.
If SINGFLAG is set and the top of EXPR is a simple
atom, the atom is made plural and used as a variable
or field name.)
(PROG (NAME FIRST)
(COND
((FMEMB (CAR EXPR)
(QUOTE (THE The the)))
(SETQ FIRST (CAR EXPR))
(RETURN (GLPARSFLD NIL)))
[(ATOM (CAR EXPR))
(GLSEPINIT (CAR EXPR))
(COND
[(EQ (SETQ NAME (GLSEPNXT))
(CAR EXPR))
(pop EXPR)
(SETQ DOMAINNAME NAME)
(RETURN (COND
[SINGFLAG (COND
((FMEMB (CAR EXPR)
(QUOTE (OF Of of)))
(SETQ FIRST (QUOTE THE))
(SETQ EXPR
(CONS (GLPLURAL NAME)
EXPR))
(GLPARSFLD NIL))
(T (GLIDNAME (GLPLURAL NAME)
NIL]
(T (GLIDNAME NAME NIL]
(T (GLSEPCLR)
(RETURN (GLDOEXPR NIL CONTEXT T]
(T (RETURN (GLDOEXPR NIL CONTEXT T])
(GLDOMAP
[LAMBDA (EXPR) (* edited:
"29-DEC-82 14:50")
(* Fast fix by GSN on 8 June 83 to include CDR
function for maps.)
(* Compile code for MAP functions.
MAPs are treated specially so that types can be
propagated.)
(PROG (MAPFN MAPSET SETTYPE MAPCODE NEWCODE RESULTTYPE ITEMTYPE
CDRFN CDRCODE)
(SETQ MAPFN (CAR EXPR))
(SETQ EXPR (CDR EXPR))
(SELECTQ GLLISPDIALECT
((INTERLISP PSL)
(SETQ MAPSET (GLDOEXPR NIL CONTEXT T))
[COND
((NULL EXPR)
(GLERROR (QUOTE GLDOMAP)
(LIST "Bad form of mapping function.")
))
((CDR EXPR)
(SETQ CDRFN (CADR EXPR]
(SETQ MAPCODE (CAR EXPR)))
[(MACLISP FRANZLISP UCILISP)
(SETQ MAPCODE (CAR EXPR))
(SETQ EXPR (CDR EXPR))
(SETQ MAPSET (GLDOEXPR NIL CONTEXT T))
(COND
(EXPR (GLERROR (QUOTE GLDOMAP)
(LIST
"Bad form of mapping function."]
(ERROR))
(SETQ SETTYPE (GLXTRTYPEB (CADR MAPSET)))
[COND
((AND (LISTP SETTYPE)
(EQ (CAR SETTYPE)
(QUOTE LISTOF)))
(SETQ ITEMTYPE (SELECTQ MAPFN
((MAP MAPLIST MAPCON)
SETTYPE)
((MAPC MAPCAR MAPCONC MAPCAN)
(CADR SETTYPE))
(ERROR]
[SETQ NEWCODE
(GLDOFUNCTION MAPCODE (LIST ITEMTYPE)
CONTEXT
(MEMB MAPFN
(QUOTE (MAPLIST MAPCON MAPCAR MAPCONC
MAPCAN]
[COND
(CDRFN (SETQ CDRCODE (GLDOFUNCTION CDRFN (LIST SETTYPE)
CONTEXT T]
(SETQ RESULTTYPE (SELECTQ MAPFN
((MAP MAPC)
NIL)
((MAPLIST MAPCON MAPCAR MAPCONC
MAPCAN)
(LIST (QUOTE LISTOF)
(CADR NEWCODE)))
(ERROR)))
(RETURN
(LIST
[GLGENCODE
(CONS MAPFN (CONS (CAR MAPSET)
(CONS (CAR NEWCODE)
(COND
(CDRFN (LIST (CAR CDRCODE)))
(T NIL]
RESULTTYPE])
(GLDOMSG
[LAMBDA (OBJECT SELECTOR ARGS) (* GSN "10-FEB-83 12:56"
)
(* Attempt to compile code for the sending of a
message to an object. OBJECT is the destination, in
the form (<code> <type>), SELECTOR is the message
selector, and ARGS is a list of arguments of the
form (<code> <type>). The result is of this form, or
NIL if failure.)
(PROG (UNITREC TYPE TMP METHOD TRANS FETCHCODE)
(SETQ TYPE (GLXTRTYPE (CADR OBJECT)))
(COND
((SETQ METHOD (GLSTRPROP TYPE (QUOTE MSG)
SELECTOR ARGS))
(RETURN (GLCOMPMSGL OBJECT (QUOTE MSG)
METHOD ARGS CONTEXT)))
([AND (SETQ UNITREC (GLUNIT? TYPE))
(SETQ TMP (ASSOC (QUOTE MSG)
(CADDR UNITREC]
(RETURN (APPLY* (CDR TMP)
OBJECT SELECTOR ARGS)))
[(SETQ TRANS (GLTRANSPARENTTYPES (CADR OBJECT]
[[AND (FMEMB TYPE (QUOTE (NUMBER REAL INTEGER)))
(FMEMB SELECTOR
(QUOTE (+ - * / ↑ > < >= <=)))
ARGS
(NULL (CDR ARGS))
(FMEMB (GLXTRTYPE (CADAR ARGS))
(QUOTE (NUMBER REAL INTEGER]
(RETURN (GLREDUCEARITH SELECTOR OBJECT (CAR ARGS]
(T (RETURN))) (* See if the message
can be handled by a
TRANSPARENT subobject.)
B (COND
((NULL TRANS)
(RETURN))
((SETQ TMP (GLDOMSG (LIST (QUOTE *GL*)
(GLXTRTYPE (CAR TRANS)))
SELECTOR ARGS))
(SETQ FETCHCODE (GLSTRFN (CAR TRANS)
(CADR OBJECT)
NIL))
(GLSTRVAL TMP (CAR FETCHCODE))
(GLSTRVAL TMP (CAR OBJECT))
(RETURN TMP))
((SETQ TMP (CDR TMP))
(GO B])
(GLDOPROG
[LAMBDA (EXPR CONTEXT) (* GSN "22-JUL-83 14:06"
) (* "GSN: "
"21-Apr-81 11:23")
(* Compile a PROG
expression.)
(PROG (PROGLST NEWEXPR RESULT NEXTEXPR TMP RESULTTYPE PROGWD)
(SETQ PROGWD (pop EXPR))
(SETQ CONTEXT (CONS NIL CONTEXT))
(SETQ PROGLST (GLDECL (pop EXPR)
(QUOTE (NIL T))
CONTEXT NIL NIL))
(SETQ CONTEXT (CONS NIL CONTEXT)) (* Compile the contents
of the PROG onto
NEWEXPR)
(* Compile the next
expression in a PROG.)
L (COND
((NULL EXPR)
(GO X)))
(SETQ NEXTEXPR (pop EXPR))
(COND
((ATOM NEXTEXPR)
(SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR))
(* *****)
(* Set up the context
for the label we just
found.)
(GO L))
((NLISTP NEXTEXPR)
(GLERROR (QUOTE GLDOPROG)
(LIST "PROG contains bad stuff:" NEXTEXPR))
(GO L))
((EQ (CAR NEXTEXPR)
(QUOTE *))
(SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR))
(GO L)))
[COND
((SETQ TMP (GLPUSHEXPR NEXTEXPR T CONTEXT NIL))
(SETQ NEWEXPR (CONS (CAR TMP)
NEWEXPR]
(GO L)
X [SETQ RESULT (CONS PROGWD (CONS PROGLST (DREVERSE NEWEXPR]
(RETURN (LIST RESULT RESULTTYPE])
(GLDOPROGN
[LAMBDA (EXPR) (* edited:
" 5-NOV-81 14:31")
(* Compile a PROGN in
the source program.)
(PROG (RES)
(SETQ RES (GLPROGN (CDR EXPR)
CONTEXT))
(RETURN (LIST (CONS (CAR EXPR)
(CAR RES))
(CADR RES])
(GLDOPROG1
[LAMBDA (EXPR CONTEXT) (* edited:
"25-JAN-82 17:34")
(* "GSN: "
"13-Aug-81 14:23")
(* "GSN: "
"21-Apr-81 11:28")
(* Compile a PROG1,
whose result is the
value of its first
argument.)
(PROG (RESULT TMP TYPE TYPEFLG)
(SETQ EXPR (CDR EXPR))
A (COND
((NULL EXPR)
(RETURN (LIST (CONS (QUOTE PROG1)
(DREVERSE RESULT))
TYPE)))
((SETQ TMP (GLDOEXPR NIL CONTEXT (NOT TYPEFLG)))
(SETQ RESULT (CONS (CAR TMP)
RESULT)) (* Get the result type
from the first item of
the PROG1.)
(COND
((NOT TYPEFLG)
(SETQ TYPE (CADR TMP))
(SETQ TYPEFLG T)))
(GO A))
(T (GLERROR (QUOTE GLDOPROG1)
(LIST "PROG1 contains bad subexpression."))
(pop EXPR)
(GO A])
(GLDOREPEAT
[LAMBDA (EXPR) (* edited:
"26-MAY-82 15:12")
(PROG (ACTIONS TMP LABEL)
(pop EXPR)
A [COND
((MEMB (CAR EXPR)
(QUOTE (UNTIL Until until)))
(pop EXPR))
((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T)))
(SETQ ACTIONS (NCONC1 ACTIONS (CAR TMP)))
(GO A))
(EXPR (RETURN (GLERROR (QUOTE GLDOREPEAT)
(LIST
"REPEAT contains bad subexpression."]
[COND
((OR (NULL EXPR)
(NULL (SETQ TMP (GLPREDICATE NIL CONTEXT NIL NIL)))
EXPR)
(GLERROR (QUOTE GLDOREPEAT)
(LIST
"REPEAT contains no UNTIL or bad UNTIL clause"))
(SETQ TMP (LIST T (QUOTE BOOLEAN]
(SETQ LABEL (GLMKLABEL))
(RETURN
(LIST
[CONS
(QUOTE PROG)
(CONS NIL
(CONS LABEL
(NCONC1 ACTIONS
(LIST (QUOTE COND)
(LIST (GLBUILDNOT
(CAR TMP))
(LIST (QUOTE GO)
LABEL]
NIL])
(GLDORETURN
[LAMBDA (EXPR) (* "GSN: "
" 7-Apr-81 11:49")
(* "GSN: "
"25-Jan-81 20:29")
(* Compile a RETURN, capturing the type of the
result as a type of the function result.)
(PROG (TMP)
(pop EXPR)
(COND
[(NULL EXPR)
(GLADDRESULTTYPE NIL)
(RETURN (QUOTE ((RETURN)
NIL]
(T (SETQ TMP (GLDOEXPR NIL CONTEXT T))
(GLADDRESULTTYPE (CADR TMP))
(RETURN (LIST (LIST (QUOTE RETURN)
(CAR TMP))
(CADR TMP])
(GLDOSELECTQ
[LAMBDA (EXPR CONTEXT) (* edited:
"26-AUG-82 09:30")
(* Compile a SELECTQ. Special treatment is necessary
in order to quote the selectors implicitly.)
(PROG (RESULT RESULTTYPE TYPEOK KEY TMP TMPB FN)
(SETQ FN (CAR EXPR))
[SETQ RESULT (LIST (CAR (GLPUSHEXPR (LIST (CADR EXPR))
NIL CONTEXT T]
(SETQ TYPEOK T)
(SETQ EXPR (CDDR EXPR)) (* If the selection
criterion is constant,
do it directly.)
[COND
([OR (SETQ KEY (NUMBERP (CAR RESULT)))
(AND (LISTP (CAR RESULT))
(EQ (CAAR RESULT)
(QUOTE QUOTE))
(SETQ KEY (CADAR RESULT]
[SETQ TMP (SOME EXPR (FUNCTION (LAMBDA (X)
(COND
((ATOM (CAR X))
(EQUAL KEY (CAR X)))
((LISTP (CAR X))
(MEMBER KEY (CAR X)))
(T NIL]
[COND
((OR (NULL TMP)
(NULL (CDR TMP)))
(SETQ TMPB (GLPROGN (LAST EXPR)
CONTEXT)))
(T (SETQ TMPB (GLPROGN (CDAR TMP)
CONTEXT]
(RETURN (LIST (CONS (QUOTE PROGN)
(CAR TMPB))
(CADR TMPB]
A [COND
((NULL EXPR)
(RETURN (LIST (GLGENCODE (CONS FN RESULT))
RESULTTYPE]
[SETQ RESULT (NCONC1 RESULT (COND
((OR (CDR EXPR)
(EQ FN (QUOTE CASEQ)))
(SETQ TMP (GLPROGN (CDAR EXPR)
CONTEXT))
(CONS (CAAR EXPR)
(CAR TMP)))
(T (SETQ TMP (GLDOEXPR NIL CONTEXT T))
(CAR TMP]
[COND
(TYPEOK (COND
((NULL RESULTTYPE)
(SETQ RESULTTYPE (CADR TMP)))
((EQUAL RESULTTYPE (CADR TMP)))
(T (SETQ TYPEOK NIL)
(SETQ RESULTTYPE NIL]
(SETQ EXPR (CDR EXPR))
(GO A])
(GLDOSEND
[LAMBDA (EXPRR) (* GSN "22-JUL-83 14:25"
)
(* Compile code for the sending of a message to an
object. The syntax of the message expression is
(← <object> <selector> <arg1>...<argn>), where the ←
may optionally be SEND, Send, or send.)
(PROG (EXPR OBJECT SELECTOR ARGS TMP FNNAME)
[SETQ FNNAME (COND
(GLGLSENDFLG (QUOTE GLSEND))
(T (CAR EXPRR]
(SETQ EXPR (CDR EXPRR))
(SETQ OBJECT (GLPUSHEXPR (LIST (pop EXPR))
NIL CONTEXT T))
(SETQ SELECTOR (pop EXPR))
[COND
((OR (NULL SELECTOR)
(NOT (LITATOM SELECTOR)))
(RETURN (GLERROR (QUOTE GLDOSEND)
(LIST SELECTOR
"is an illegal message Selector."]
(* Collect arguments of
the message, if any.)
A (COND
[(NULL EXPR)
(COND
((SETQ TMP (GLDOMSG OBJECT SELECTOR ARGS))
(RETURN TMP))
(T
(* No message was defined, so just pass it through
and hope one will be defined by runtime.)
(RETURN
(LIST
[GLGENCODE
(CONS
FNNAME
(CONS (CAR OBJECT)
(CONS SELECTOR
(MAPCAR ARGS
(FUNCTION CAR]
(CADR OBJECT]
((SETQ TMP (GLDOEXPR NIL CONTEXT T))
(SETQ ARGS (NCONC1 ARGS TMP))
(GO A))
(T (GLERROR (QUOTE GLDOSEND)
(LIST "A message argument is bad."])
(GLDOSETQ
[LAMBDA (EXPR) (* "GSN: "
" 7-Apr-81 11:52")
(* "GSN: "
"25-Jan-81 17:50")
(* Compile a SETQ
expression)
(PROG NIL
(pop EXPR)
(GLSEPINIT (pop EXPR))
(RETURN (GLDOVARSETQ (GLSEPNXT)
(GLDOEXPR NIL CONTEXT T])
(GLDOTHE
[LAMBDA (EXPR) (* edited:
"20-MAY-82 15:13")
(* "GSN: "
"17-Apr-81 14:53")
(* Process a THE
expression in a list.)
(PROG (RESULT)
(SETQ RESULT (GLTHE NIL))
[COND
(EXPR (GLERROR (QUOTE GLDOTHE)
(LIST
"Stuff left over at end of The expression."
EXPR]
(RETURN RESULT])
(GLDOTHOSE
[LAMBDA (EXPR) (* edited:
"20-MAY-82 15:16")
(* "GSN: "
"17-Apr-81 14:53")
(* Process a THE
expression in a list.)
(PROG (RESULT)
(SETQ EXPR (CDR EXPR))
(SETQ RESULT (GLTHE T))
[COND
(EXPR (GLERROR (QUOTE GLDOTHOSE)
(LIST
"Stuff left over at end of The expression."
EXPR]
(RETURN RESULT])
(GLDOVARSETQ
[LAMBDA (VAR RHS) (* edited:
" 5-MAY-82 15:51")
(* "GSN: "
"25-Jan-81 18:00")
(* Compile code to do a SETQ of VAR to the RHS.
If the type of VAR is unknown, it is set to the type
of RHS.)
(PROG NIL
(GLUPDATEVARTYPE VAR (CADR RHS))
(RETURN (LIST (LIST (QUOTE SETQ)
VAR
(CAR RHS))
(CADR RHS])
(GLDOWHILE
[LAMBDA (EXPR CONTEXT) (* edited:
" 4-MAY-82 10:46")
(PROG (ACTIONS TMP LABEL)
(SETQ CONTEXT (CONS NIL CONTEXT))
(pop EXPR)
[SETQ ACTIONS (LIST (CAR (GLPREDICATE NIL CONTEXT NIL T]
(COND
((MEMB (CAR EXPR)
(QUOTE (DO Do do)))
(pop EXPR)))
A (COND
((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T)))
(SETQ ACTIONS (NCONC1 ACTIONS (CAR TMP)))
(GO A))
(EXPR (GLERROR (QUOTE GLDOWHILE)
(LIST "Bad stuff in While statement:" EXPR))
(pop EXPR)
(GO A)))
(SETQ LABEL (GLMKLABEL))
(RETURN (LIST [LIST (QUOTE PROG)
NIL LABEL
(LIST (QUOTE COND)
(NCONC1 ACTIONS
(LIST (QUOTE GO)
LABEL]
NIL])
(GLEQUALFN
[LAMBDA (LHS RHS) (* edited:
"23-DEC-82 10:47")
(* edited:
" 6-Jan-81 16:11")
(* Produce code to test
the two sides for
equality.)
(PROG (TMP LHSTP RHSTP)
(RETURN
(COND
((SETQ TMP (GLDOMSG LHS (QUOTE =)
(LIST RHS)))
TMP)
((SETQ TMP (GLUSERSTROP LHS (QUOTE =)
RHS))
TMP)
(T
(SETQ LHSTP (CADR LHS))
(SETQ RHSTP (CADR RHS))
(LIST
[COND
((NULL (CAR RHS))
(LIST (QUOTE NULL)
(CAR LHS)))
((NULL (CAR LHS))
(LIST (QUOTE NULL)
(CAR RHS)))
(T (GLGENCODE (LIST (COND
((OR (EQ LHSTP (QUOTE INTEGER)
)
(EQ RHSTP (QUOTE INTEGER)
))
(QUOTE EQP))
((OR (GLATOMTYPEP LHSTP)
(GLATOMTYPEP RHSTP))
(QUOTE EQ))
((AND (EQ LHSTP (QUOTE STRING)
)
(EQ RHSTP (QUOTE STRING)
))
(QUOTE STREQUAL))
(T (QUOTE EQUAL)))
(CAR LHS)
(CAR RHS]
(QUOTE BOOLEAN])
(GLEVALSTR
[LAMBDA (STR CONTEXT) (* GSN "26-JAN-83 13:42"
)
(* Look through a structure to see if it involves
evaluating other structures to produce a concrete
type.)
(DECLARE (SPECVARS GLEVALSUBS))
(PROG (GLEVALSUBS)
(GLEVALSTRB STR)
(RETURN (COND
(GLEVALSUBS (GLSUBLIS GLEVALSUBS STR))
(T STR])
(GLEVALSTRB
[LAMBDA (STR) (* GSN "30-JAN-83 15:34"
)
(* Find places where substructures need to be
evaluated and collect substitutions for them.)
(PROG (TMP EXPR)
(COND
((ATOM STR)
(RETURN))
((NLISTP STR)
(ERROR))
((EQ (CAR STR)
(QUOTE TYPEOF))
(SETQ EXPR (CDR STR))
(SETQ TMP (GLDOEXPR NIL CONTEXT T))
[COND
((CADR TMP)
(SETQ GLEVALSUBS (CONS (CONS STR (CADR TMP))
GLEVALSUBS)))
(T (GLERROR (QUOTE GLEVALSTRB)
(LIST "The evaluated type" STR
"was not found."]
(RETURN))
(T (MAPC (CDR STR)
(FUNCTION GLEVALSTRB])
(GLEXPANDPROGN
[LAMBDA (LST BUSY PROGFLG) (* GSN "27-JAN-83 13:56"
)
(* If a PROGN occurs within a PROGN, expand it by
splicing its contents into the top-level list.)
(PROG (X Y)
(SETQ Y LST)
LP (SETQ X (CDR Y))
[COND
((NULL X)
(RETURN LST))
[(NLISTP (CAR X)) (* Eliminate non-busy
atomic items.)
(COND
((AND (NOT PROGFLG)
(OR (CDR X)
(NOT BUSY)))
(RPLACD Y (CDR X))
(GO LP]
((FMEMB (CAAR X)
(QUOTE (PROGN PROG2))) (* Expand contained
PROGNs in-line.)
[COND
((CDDAR X)
(RPLACD (LAST (CAR X))
(CDR X))
(RPLACD X (CDDAR X]
(RPLACA X (CADAR X)))
([AND (EQ (CAAR X)
(QUOTE PROG))
(NULL (CADAR X))
[EVERY (CDDAR X)
(FUNCTION (LAMBDA (Y)
(NOT (ATOM Y]
(NOT (GLOCCURS (QUOTE RETURN)
(CDDAR X] (* Expand contained
simple PROGs.)
[COND
((CDDDAR X)
(RPLACD (LAST (CAR X))
(CDR X))
(RPLACD X (CDDDAR X]
(RPLACA X (CADDAR X]
(SETQ Y (CDR Y))
(GO LP])
(GLFINDVARINCTX
[LAMBDA (VAR CONTEXT) (* "GSN: "
" 2-Jan-81 14:26")
(* Find the first entry
for variable VAR in the
CONTEXT structure.)
(AND CONTEXT (OR (ASSOC VAR (CAR CONTEXT))
(GLFINDVARINCTX VAR (CDR CONTEXT])
(GLFIXCOMS
[LAMBDA (COMS IND NEW) (* GSN "26-JUL-83 15:43"
) (* Fix a COMS list by
replacing the IND
indicator with value
NEW.)
(PROG (TMP)
(COND
((SETQ TMP (ASSOC IND COMS))
(RPLACD TMP NEW)))
(RETURN COMS])
(GLGETCONSTDEF
[LAMBDA (ATM) (* edited:
"30-AUG-82 10:25")
(COND
[(GETPROP ATM (QUOTE GLISPCONSTANTFLG))
(LIST (KWOTE (GETPROP ATM (QUOTE GLISPCONSTANTVAL)))
(GETPROP ATM (QUOTE GLISPCONSTANTTYPE]
(T NIL])
(GLGETFIELD
[LAMBDA (SOURCE FIELD CONTEXT) (* edited:
" 5-OCT-82 15:06")
(* edited:
"18-Sep-81 13:48")
(* edited:
"13-Aug-81 16:40")
(* edited:
"21-Apr-81 11:26")
(* Find a way to retrieve the FIELD from the
structure pointed to by SOURCE
(which may be a variable name, NIL, or a list
(CODE DESCR)) relative to CONTEXT.
The result is a list of code to get the field and
the structure description of the resulting field.)
(PROG (TMP CTXENTRY CTXLIST)
[COND
((NULL SOURCE)
(GO B))
((ATOM SOURCE)
(COND
[(SETQ CTXENTRY (GLFINDVARINCTX SOURCE CONTEXT))
(COND
((SETQ TMP (GLVALUE SOURCE FIELD (CADDR CTXENTRY)
NIL))
(RETURN TMP))
(T (GLERROR (QUOTE GLGETFIELD)
(LIST "The property" FIELD
"cannot be found for"
SOURCE "whose type is"
(CADDR CTXENTRY]
((SETQ TMP (GLGETFIELD NIL SOURCE CONTEXT))
(SETQ SOURCE TMP))
((SETQ TMP (GLGETGLOBALDEF SOURCE))
(RETURN (GLGETFIELD TMP FIELD NIL)))
((SETQ TMP (GLGETCONSTDEF SOURCE))
(RETURN (GLGETFIELD TMP FIELD NIL)))
(T (RETURN (GLERROR (QUOTE GLGETFIELD)
(LIST "The name" SOURCE
"cannot be found."]
[COND
((LISTP SOURCE)
(COND
((SETQ TMP (GLVALUE (CAR SOURCE)
FIELD
(CADR SOURCE)
NIL))
(RETURN TMP))
(T (RETURN (GLERROR (QUOTE GLGETFIELD)
(LIST "The property" FIELD
"cannot be found for type"
(CADR SOURCE)
"in"
(CAR SOURCE]
B (* No source is
specified. Look for a
source in the context.)
(COND
((NULL CONTEXT)
(RETURN)))
(SETQ CTXLIST (pop CONTEXT))
C (COND
((NULL CTXLIST)
(GO B)))
(SETQ CTXENTRY (pop CTXLIST))
(COND
[(EQ FIELD (CADR CTXENTRY))
(RETURN (LIST (CAR CTXENTRY)
(CADDR CTXENTRY]
((NULL (SETQ TMP (GLVALUE (CAR CTXENTRY)
FIELD
(CADDR CTXENTRY)
NIL)))
(GO C)))
(RETURN TMP])
(GLGETGLOBALDEF
[LAMBDA (ATM) (* edited:
"23-APR-82 16:58")
(COND
[(GETPROP ATM (QUOTE GLISPGLOBALVAR))
(LIST ATM (GETPROP ATM (QUOTE GLISPGLOBALVARTYPE]
(T NIL])
(GLGETTYPEOF
[LAMBDA (TYPE) (* GSN " 9-FEB-83 15:28"
) (* Get the type of an
expression.)
(PROG (TMP)
(COND
((SETQ TMP (GLPUSHEXPR (CDR TYPE)
NIL CONTEXT T))
(RETURN (CADR TMP])
(GLIDNAME
[LAMBDA (NAME DEFAULTFLG) (* edited:
"21-MAY-82 17:01")
(* "GSN: "
"13-Aug-81 15:00")
(* "GSN: "
"14-Apr-81 17:04")
(* Identify a given name as either a known variable
name of as an implicit field reference.)
(PROG (TMP)
(RETURN (COND
[(ATOM NAME)
(COND
((NULL NAME)
(LIST NIL NIL))
[(LITATOM NAME)
(COND
((EQ NAME T)
(LIST NAME (QUOTE BOOLEAN)))
[(SETQ TMP (GLVARTYPE NAME CONTEXT))
(LIST NAME (COND
((EQ TMP (QUOTE *NIL*))
NIL)
(T TMP]
((GLGETFIELD NIL NAME CONTEXT))
((SETQ TMP (GLIDTYPE NAME CONTEXT))
(LIST (CAR TMP)
(CADDR TMP)))
((GLGETCONSTDEF NAME))
((GLGETGLOBALDEF NAME))
(T [COND
((OR (NOT DEFAULTFLG)
GLCAUTIOUSFLG)
(GLERROR (QUOTE GLIDNAME)
(LIST "The name" NAME
"cannot be found in this context."]
(LIST NAME NIL]
((FIXP NAME)
(LIST NAME (QUOTE INTEGER)))
((FLOATP NAME)
(LIST NAME (QUOTE REAL)))
(T (GLERROR (QUOTE GLIDNAME)
(LIST NAME "is an illegal name."]
(T NAME])
(GLIDTYPE
[LAMBDA (NAME CONTEXT) (* edited:
"27-MAY-82 13:02")
(* Try to identify a name by either its referenced
name or its type.)
(PROG (CTXLEVELS CTXLEVEL CTXENTRY)
(SETQ CTXLEVELS CONTEXT)
LPA (COND
((NULL CTXLEVELS)
(RETURN)))
(SETQ CTXLEVEL (pop CTXLEVELS))
LPB (COND
((NULL CTXLEVEL)
(GO LPA)))
(SETQ CTXENTRY (CAR CTXLEVEL))
(SETQ CTXLEVEL (CDR CTXLEVEL))
(COND
([OR (EQ (CADR CTXENTRY)
NAME)
(EQ (CADDR CTXENTRY)
NAME)
(AND (LISTP (CADDR CTXENTRY))
(GL-A-AN? (CAADDR CTXENTRY))
(EQ NAME (CADR (CADDR CTXENTRY]
(RETURN CTXENTRY)))
(GO LPB])
(GLINSTANCEFN
[LAMBDA (FNNAME ARGTYPES) (* edited:
"26-JUL-82 17:07")
(* Look up an instance function of an abstract
function name which takes arguments of the specified
types.)
(PROG (INSTANCES IARGS TMP)
(OR (SETQ INSTANCES (GETPROP FNNAME (QUOTE GLINSTANCEFNS)))
(RETURN)) (* Get ultimate data
types for arguments.)
LP (COND
((NULL INSTANCES)
(RETURN)))
(SETQ IARGS (GETPROP (CAAR INSTANCES)
(QUOTE GLARGUMENTTYPES)))
(SETQ TMP ARGTYPES) (* Match the ultimate
types of each argument.)
LPB (COND
((NULL IARGS)
(RETURN (CAR INSTANCES)))
((EQUAL (GLXTRTYPEB (CAR IARGS))
(GLXTRTYPEB (CAR TMP)))
(SETQ IARGS (CDR IARGS))
(SETQ TMP (CDR TMP))
(GO LPB)))
(SETQ INSTANCES (CDR INSTANCES))
(GO LP])
(GLINSTANCEFNNAME
[LAMBDA (FN) (* GSN " 3-FEB-83 14:13"
) (* Make a new name for
an instance of a generic
function.)
(PROG (INSTFN N)
(SETQ N (ADD1 (OR (GETPROP FN (QUOTE GLINSTANCEFNNO))
0)))
(PUTPROP FN (QUOTE GLINSTANCEFNNO)
N)
[SETQ INSTFN (PACK (NCONC (UNPACK FN)
(CONS (QUOTE -)
(UNPACK N]
[PUTPROP FN (QUOTE GLINSTANCEFNS)
(CONS INSTFN (GETPROP FN (QUOTE GLINSTANCEFNS]
(RETURN INSTFN])
(GLINTERLISPTRANSFM
[LAMBDA (X) (* edited:
"12-NOV-82 11:46")
(* Transform an
expression X for
INTERLISP dialect.)
(PROG (TMP NOTFLG) (* First do argument
reversals.)
[COND
((NLISTP X)
(RETURN X))
((FMEMB (CAR X)
(QUOTE (GLSTRLESSP GLSTRGEP)))
(SETQ X (LIST (CAR X)
(CADDR X)
(CADR X] (* Now see if the result
should be negated.)
[SETQ NOTFLG (FMEMB (CAR X)
(QUOTE (GLSTRGREATERP GLSTRLESSP]
[COND
[[SETQ TMP (FASSOC (CAR X)
(QUOTE ((GLSTRLESSP ALPHORDER)
(GLSTRGREATERP ALPHORDER)
(GLSTRGEP ALPHORDER]
(SETQ X (CONS (CADR TMP)
(CDR X]
((AND (EQ (CAR X)
(QUOTE NTH))
(NUMBERP (CADDR X)))
(COND
((ZEROP (CADDR X))
(SETQ X (CADR X)))
((ILESSP (CADDR X)
5)
(SETQ X
(LIST [CAR (NTH (QUOTE (CDR CDDR CDDDR CDDDDR))
(SUB1 (CADDR X]
(CADR X]
(RETURN (COND
(NOTFLG (LIST (QUOTE NOT)
X))
(T X])
)
(PUTDEF (QUOTE GLISPCONSTANTS) (QUOTE FILEPKGCOMS) (QUOTE ([COM MACRO
(GLISPCONSTANTS
(E (GLPRETTYPRINTCONST
(QUOTE GLISPCONSTANTS]
(TYPE DESCRIPTION
"GLISP compile-time constants"
GETDEF GLGETCONSTDEF))))
(PUTDEF (QUOTE GLISPGLOBALS) (QUOTE FILEPKGCOMS) (QUOTE ([COM MACRO
(GLISPGLOBALS
(E (GLPRETTYPRINTGLOBALS
(QUOTE GLISPGLOBALS]
(TYPE DESCRIPTION "GLISP global variables"
GETDEF GLGETGLOBALDEF))))
(PUTDEF (QUOTE GLISPOBJECTS) (QUOTE FILEPKGCOMS) (QUOTE ([COM MACRO
(GLISPOBJECTS
(E (GLPRETTYPRINTSTRS (QUOTE
GLISPOBJECTS]
(TYPE DESCRIPTION "GLISP Object Definitions"
GETDEF GLGETDEF DELDEF GLDELDEF))))
(ADDTOVAR LAMBDASPLST GLAMBDA)
(ADDTOVAR LAMBDATRANFNS (GLAMBDA GLAMBDATRAN EXPR NIL))
(ADDTOVAR PRETTYEQUIVLST (GLAMBDA . LAMBDA))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES
GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES GLOBJECTNAMES
GLTYPESUSED GLNOSPLITATOMS GLGLSENDFLG GEVUSERTYPENAMES)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(SPECVARS CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST
OPNDS OPERS GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST ADDISATYPE GLFNSUBS GLNRECURSIONS
PAIRS NEW N)
)
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
LAMBDATRAN)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS GLISPA.LSP COPYRIGHT ("Gordon S. Novak Jr." 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2366 81343 (GLABSTRACTFN? 2376 . 2711) (GLADDRESULTTYPE 2713 . 3225) (GLADDSTR 3227 .
3692) (GLADJ 3694 . 5195) (GLAMBDATRAN 5197 . 5994) (GLANALYZEGLISP 5996 . 6832) (GLANDFN 6834 . 7993)
(GLATOMTYPEP 7995 . 8441) (GLBUILDALIST 8443 . 9100) (GLBUILDCONS 9102 . 9897) (GLBUILDLIST 9899 .
10584) (GLBUILDNOT 10586 . 11687) (GLBUILDPROPLIST 11689 . 12083) (GLBUILDRECORD 12085 . 13629) (
GLBUILDSTR 13631 . 17331) (GLCARCDR? 17333 . 17614) (GLCC 17616 . 17842) (GLCOMP 17844 . 19793) (
GLCOMPABSTRACT 19795 . 20527) (GLCOMPCOMS 20529 . 21381) (GLCOMPEXPR 21383 . 22347) (GLCOMPILE 22349
. 22685) (GLCOMPILE? 22687 . 22935) (GLCOMPMSG 22937 . 23599) (GLCOMPMSGB 23601 . 26348) (GLCOMPMSGL
26350 . 28291) (GLCOMPOPEN 28293 . 32002) (GLCONSTANTTYPE 32004 . 33114) (GLCONST? 33116 . 33518) (
GLCONSTSTR? 33520 . 34207) (GLCONSTVAL 34209 . 35056) (GLCP 35058 . 35295) (GLDECL 35297 . 39000) (
GLDECLDS 39002 . 39612) (GLDECLS 39614 . 40033) (GLDOA 40035 . 40894) (GLDOCASE 40896 . 43047) (
GLDOCOND 43049 . 44073) (GLDOEXPR 44075 . 48130) (GLDOFOR 48132 . 51099) (GLDOFUNCTION 51101 . 52421)
(GLDOIF 52423 . 53890) (GLDOLAMBDA 53892 . 54601) (GLDOMAIN 54603 . 55671) (GLDOMAP 55673 . 57648) (
GLDOMSG 57650 . 59272) (GLDOPROG 59274 . 60802) (GLDOPROGN 60804 . 61147) (GLDOPROG1 61149 . 62131) (
GLDOREPEAT 62133 . 63121) (GLDORETURN 63123 . 63719) (GLDOSELECTQ 63721 . 65467) (GLDOSEND 65469 .
66903) (GLDOSETQ 66905 . 67315) (GLDOTHE 67317 . 67795) (GLDOTHOSE 67797 . 68310) (GLDOVARSETQ 68312
. 68771) (GLDOWHILE 68773 . 69563) (GLEQUALFN 69565 . 70709) (GLEVALSTR 70711 . 71094) (GLEVALSTRB
71096 . 71772) (GLEXPANDPROGN 71774 . 72908) (GLFINDVARINCTX 72910 . 73229) (GLFIXCOMS 73231 . 73567)
(GLGETCONSTDEF 73569 . 73839) (GLGETFIELD 73841 . 76119) (GLGETGLOBALDEF 76121 . 76341) (GLGETTYPEOF
76343 . 76639) (GLIDNAME 76641 . 77924) (GLIDTYPE 77926 . 78672) (GLINSTANCEFN 78674 . 79612) (
GLINSTANCEFNNAME 79614 . 80187) (GLINTERLISPTRANSFM 80189 . 81341)))))
STOP