(FILECREATED "22-Dec-83 10:44:11" <CS.NOVAK>GLISPR.LSP.4 80158
changes to: GLOKSTR?
previous date: "12-Dec-83 11:37:32" <CS.NOVAK>GLISPR.LSP.3)
(PRETTYCOMPRINT GLISPRCOMS)
(RPAQQ GLISPRCOMS [(* Copyright (c)
1983 by Gordon S. Novak Jr.)
(* This is the runtime subset of GLISP, GLISPR. The other two
GLISP files, GLISPA and GLISPB, are added to this file to
form the complete compiler.)
(FNS A AN GL-A-AN? GLADDPROP GLADDTOOBJECT GLADDTOOBJECTS
GLAINTERPRETER GLANYCARCDR? GLAPPLY GLAQR GLAQRB
GLAQRLISTOF GLAQRRD GLAQRSTR GLATMSTR? GLATOMSTRFN
GLCARCDRRESULTTYPE GLCARCDRRESULTTYPEB GLCLASS GLCLASSMEMP
GLCLASSP GLCLASSSEND GLCOMPPROP GLCOMPPROPL GLDEFAULTVALUE
GLDEFFNRESULTTYPES GLDEFFNRESULTTYPEFNS GLDEFPROP GLDEFSTR
GLDEFSTRNAMES GLDEFSTRQ GLDEFSYSSTRQ GLDEFUNITPKG GLDELDEF
GLDESCENDANTP GLDOEXPRC GLED GLEDS GLERR GLERROR
GLEXPENSIVE? GLGENCODE GLGETASSOC GLGETD GLGETDB GLGETDEF
GLGETFROMUNIT GLGETPAIRS GLGETSTR GLGETSUPERS
GLIFSTRCHANGED GLINIT GLISPCONSTANTS GLISPCP GLISPGLOBALS
GLISPOBJECTS GLLISTRESULTTYPEFN GLLISTSTRFN GLMKATOM
GLMKRECORD GLMKSTR GLMKVAR GLNOTICETYPE GLNTHRESULTTYPEFN
GLOKSTR? GLP GLPROPSTRFN GLPUTARITH GLPUTFN GLRESULTTYPE
GLSEND GLSENDB GLSENDC GLSENDPROP GLSENDPROPC GLSTRCHANGED
GLSTRFN GLSTRPROP GLSTRPROPB GLSTRVAL GLSTRVALB GLSUPERS
GLTRANSPARENTTYPES GLTRANSPB GLTYPEMATCH GLUNIT? GLUNITOP
GLUNWRAPC GLUSERSTROP GLXTRTYPE GLYESP SEND SENDC SENDPROP
SENDPROPC)
(VARS GLBASICTYPES GLLISPDIALECT GLSPECIALFNS GLTYPENAMES
(GLOBJECTNAMES NIL))
(PROP GLSTRUCTURE GLTYPE GLPROPENTRY GLPROPFNENTRY GLFUNCTION)
(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)
(P (GLINIT))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA SENDPROPC SENDPROP SENDC SEND
GLSENDPROPC GLSENDPROP GLSENDC GLSEND
GLISPOBJECTS GLISPGLOBALS
GLISPCONSTANTS GLERR GLDEFSYSSTRQ
GLDEFSTRQ GLDEFSTRNAMES
GLADDTOOBJECTS AN A)
(NLAML)
(LAMA])
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Copyright (c)
1983 by Gordon S. Novak Jr.) ]
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* This is the runtime subset of GLISP, GLISPR. The other two GLISP
files, GLISPA and GLISPB, are added to this file to form the
complete compiler.) ]
(DEFINEQ
(A
[NLAMBDA L (* edited:
"18-NOV-82 11:47")
(GLAINTERPRETER L])
(AN
[NLAMBDA L (* edited:
"18-NOV-82 11:47")
(GLAINTERPRETER L])
(GL-A-AN?
[LAMBDA (X) (* edited:
"29-OCT-81 14:25")
(* "GSN: "
"20-Mar-81 10:34")
(FMEMB X (QUOTE (A AN a an An])
(GLADDPROP
[LAMBDA (STRNAME PROPTYPE LST) (* GSN "16-FEB-83 12:39"
) (* Add a PROPerty entry
of type PROPTYPE to
structure STRNAME.)
(PROG (PL SUBPL)
(COND
([NOT (AND (ATOM STRNAME)
(SETQ PL (GETPROP STRNAME (QUOTE GLSTRUCTURE]
(ERROR (LIST STRNAME " has no structure definition.")))
((SETQ SUBPL (LISTGET (CDR PL)
PROPTYPE))
(NCONC SUBPL (LIST LST)))
(T (NCONC PL (LIST PROPTYPE (LIST LST])
(GLADDTOOBJECT
[LAMBDA (LST) (* GSN "30-APR-83 15:43"
) (* Add properties to an
object description which
already exists.)
(PROG (OBJNAME PROPNAME PROPL TMP OBJDES PROPS)
(SETQ OBJNAME (CAR LST))
(SETQ LST (CDR LST))
LP (COND
((NULL LST)
(RETURN))
([OR [NOT (ATOM (SETQ PROPNAME (CAR LST]
(NOT (MEMB PROPNAME (QUOTE (PROP ADJ ISA MSG]
(ERROR "Improper args to GLADDTOOBJECT" OBJNAME))
([NULL (SETQ OBJDES (GETPROP OBJNAME (QUOTE GLSTRUCTURE]
(ERROR "No object description exists for " OBJNAME)))
(* Find or make a list
for this property name.)
(COND
((NULL (SETQ PROPL (LISTGET (CDR OBJDES)
PROPNAME)))
(NCONC OBJDES (LIST PROPNAME (CADR LST)))
(SETQ LST (CDDR LST))
(GO LP)))
(SETQ PROPS (CADR LST))
(SETQ LST (CDDR LST))
LPB [COND
((NULL PROPS)
(GO LP))
((SETQ TMP (ASSOC (CAAR PROPS)
PROPL))
(RPLACD TMP (CDAR PROPS)))
(T (NCONC1 PROPL (CAR PROPS]
(SETQ PROPS (CDR PROPS))
(GO LPB])
(GLADDTOOBJECTS
[NLAMBDA ARGS (* GSN "30-APR-83 15:19"
) (* Add properties to an
already-existing object
description.)
(MAPC ARGS (FUNCTION GLADDTOOBJECT])
(GLAINTERPRETER
[LAMBDA (EXPR) (* GSN "26-JUL-83 13:58"
)
(PROG (GLNATOM FAULTFN CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK
GLTOPCTX GLGLOBALVARS GLNRECURSIONS TYPE STR PAIRS
UNITREC TMP)
(SETQ GLNATOM 0)
(SETQ GLNRECURSIONS 0)
(SETQ FAULTFN (QUOTE GLAINTERPRETER))
(SETQ VALBUSY T)
(SETQ GLSEPPTR 0)
(SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL)))
(SETQ TYPE (CAR EXPR))
[COND
((SETQ STR (GLGETSTR TYPE))
(SETQ EXPR (CDR EXPR)))
[[AND (SETQ UNITREC (GLUNIT? TYPE))
(SETQ TMP (ASSOC (QUOTE A)
(CADDR UNITREC]
(RETURN (APPLY* (CDR TMP)
(CONS (QUOTE A)
EXPR]
(T (GLERROR (QUOTE GLAINTERPRETER)
(LIST "The type" TYPE "is not defined."]
(COND
((FMEMB (CAR EXPR)
(QUOTE (WITH With with)))
(pop EXPR)))
(SETQ PAIRS (GLGETPAIRS EXPR))
(RETURN (GLMKSTR STR TYPE PAIRS NIL])
(GLANYCARCDR?
[LAMBDA (ATM) (* edited:
"19-MAY-82 13:54")
(* Test if ATM is the name of any CAR/CDR
combination. If so, the value is a list of the
intervening letters in reverse order.)
(PROG (RES N NMAX TMP)
(OR (AND (EQ (NTHCHAR ATM 1)
(QUOTE C))
(EQ (NTHCHAR ATM -1)
(QUOTE R)))
(RETURN))
(SETQ NMAX (SUB1 (NCHARS ATM)))
(SETQ N 2)
A (COND
((IGREATERP N NMAX)
(RETURN RES))
((OR (EQ (SETQ TMP (NTHCHAR ATM N))
(QUOTE D))
(EQ TMP (QUOTE A)))
(SETQ RES (CONS TMP RES))
(SETQ N (ADD1 N))
(GO A))
(T (RETURN])
(GLAPPLY
[LAMBDA (FN ARGS) (* GSN " 6-JUN-83 15:42"
)
(APPLY FN ARGS])
(GLAQR
[LAMBDA (STR) (* Acquire an instance
of a data type based on
its description.)
(GLAQRB STR NIL 0 NIL])
(GLAQRB
[LAMBDA (STR NAME LEVEL PREV) (* GSN "25-JUL-83 14:08"
)
(* Acquire an instance of a data type based on its
descripttion. str is the structure description of
the data, name is the name of the structure, or nil,
level is the depth level in the structure tree.)
(PROG (RES NEW N)
(COND
((FMEMB STR PREV)
(RETURN NIL)))
(SETQ PREV (CONS STR PREV))
(RETURN
(COND
((NULL STR)
NIL)
[(ATOM STR)
(PRIN1 "(")
(PRIN1 STR)
(PRIN1 ")")
(COND
((FMEMB STR GLBASICTYPES)
(GLAQRRD STR))
(T (GLAQRSTR STR LEVEL PREV]
((NLISTP STR)
(ERROR (LIST "Invalid structure:" STR)))
[(FMEMB (CAR STR)
GLTYPENAMES)
(COND
((EQ (CAR STR)
(QUOTE ATOM))
[SETQ NEW (GLMKATOM (OR NAME (QUOTE GLAQR]
[MAPC
(CDR STR)
(FUNCTION (LAMBDA (Y)
(COND
[(EQ (CAR Y)
(QUOTE PROPLIST))
(MAPC (CDR Y)
(FUNCTION (LAMBDA (X)
(PUTPROP NEW (CAR X)
(GLAQRB X NIL
(ADD1 LEVEL)
PREV]
((EQ (CAR Y)
(QUOTE BINDING))
(SET NEW (GLAQRB (CADR Y)
NIL
(ADD1 LEVEL)
PREV]
NEW)
((EQ (CAR STR)
(QUOTE LISTOF))
(GLAQRLISTOF (CADR STR)
PREV))
(T
[MAPC (COND
((AND (EQ (CAR STR)
(QUOTE RECORD))
(ATOM (CADR STR)))
(CDDR STR))
(T (CDR STR)))
(FUNCTION (LAMBDA (X)
(SETQ RES
(CONS (CONS (AND (LISTP X)
(CAR X))
(GLAQRB X NIL (ADD1 LEVEL)
PREV))
RES]
(SETQ RES (DREVERSE RES))
(SELECTQ
(CAR STR)
(CONS (CONS (CDAR RES)
(CDADR RES)))
(LIST (MAPCAR RES (FUNCTION CDR)))
(ALIST RES)
[PROPLIST (MAPCONC RES (FUNCTION (LAMBDA (X)
(LIST (CAR X)
(CDR X]
(ATOMOBJECT [SETQ NEW (GLMKATOM
(OR NAME (QUOTE GLAQR]
(PUTPROP NEW (QUOTE CLASS)
NAME)
[MAPC RES (FUNCTION (LAMBDA (X)
(PUTPROP NEW (CAR X)
(CDR X]
NEW)
((OBJECT RECORD)
[SETQ NEW
(GLMKRECORD [COND
[(EQ (CAR STR)
(QUOTE OBJECT))
(ADD1 (LENGTH (CDR STR]
((ATOM (CADR STR))
(LENGTH (CDDR STR)))
(T (LENGTH (CDR STR]
(AND (ATOM (CADR STR))
(CADR STR]
(SETQ N 0)
[COND
((EQ (CAR STR)
(QUOTE OBJECT))
[SELECTQ GLLISPDIALECT
[INTERLISP (COND
((LISTP NEW)
(RPLACA NEW NAME]
(PSL (PUTV NEW 0 NAME))
((MACLISP FRANZLISP)
(RPLACX 0 NEW NAME))
(COND
((LISTP NEW)
(RPLACA NEW NAME]
(SETQ N (ADD1 N]
[MAPC
RES
(FUNCTION (LAMBDA (X)
[SELECTQ
GLLISPDIALECT
[INTERLISP
(COND
((LISTP NEW)
(RPLACA (NTH NEW (ADD1 N))
(CDR X]
(PSL (PUTV NEW N (CDR X)))
((MACLISP FRANZLISP)
(RPLACX N NEW (CDR X)))
(COND
((LISTP NEW)
(RPLACA (NTH NEW (ADD1 N))
(CDR X]
(SETQ N (ADD1 N]
NEW)
[LISTOBJECT (CONS NAME
(MAPCAR RES
(FUNCTION CDR]
NIL]
((EQ (CAR STR)
(QUOTE TRANSPARENT))
(GLAQRB (CADR STR)
NIL
(ADD1 LEVEL)
PREV))
(T (SPACES (PLUS LEVEL LEVEL))
(PRIN1 (CAR STR))
(PRIN1 ":")
(SPACES 1)
(GLAQRB (CADR STR)
(CAR STR)
(ADD1 LEVEL)
PREV])
(GLAQRLISTOF
[LAMBDA (STR PREV) (* GSN "25-JUL-83 14:08"
) (* Acquire a list of
items.)
(PROG (RES)
(PRIN1 "(")
(PRIN1 (QUOTE LISTOF))
(PRIN1 " ")
(PRIN1 STR)
(PRIN1 ")")
(TERPRI)
LP (COND
((GLYESP "MORE?")
(SETQ RES (CONS (GLAQRB STR NIL 0 PREV)
RES))
(GO LP))
(T (RETURN (DREVERSE RES])
(GLAQRRD
[LAMBDA (STR) (* Read in a single
item)
(PROG (INP)
(SETQ INP (READ))
(RETURN INP])
(GLAQRSTR
[LAMBDA (STR LEVEL PREV) (* GSN "26-JUL-83 13:50"
)
(TERPRI)
(COND
((OR (EQUAL LEVEL 0)
(GLYESP "Acquire a new value"))
(GLAQRB (CAR (GETPROP STR (QUOTE GLSTRUCTURE)))
STR
(ADD1 LEVEL)
PREV))
(T (SELECTQ GLLISPDIALECT
(INTERLISP (PRIN1 "Enter existing value:"))
(PRINC "Enter existing value:"))
(EVAL (READ])
(GLATMSTR?
[LAMBDA (STR) (* GSN " 1-FEB-83 16:35"
) (* "GSN: "
"14-Sep-81 12:45")
(* Test whether STR is a
legal ATOM structure.)
(PROG (TMP)
(COND
([OR (AND (CDR STR)
(OR (NLISTP (CADR STR))
(AND (CDDR STR)
(OR (NLISTP (CADDR STR))
(CDDDR STR]
(RETURN)))
[COND
((SETQ TMP (ASSOC (QUOTE BINDING)
(CDR STR)))
(COND
([OR (CDDR TMP)
(NULL (GLOKSTR? (CADR TMP]
(RETURN]
[COND
((SETQ TMP (ASSOC (QUOTE PROPLIST)
(CDR STR)))
(RETURN (EVERY (CDR TMP)
(FUNCTION (LAMBDA (X)
(AND (ATOM (CAR X))
(GLOKSTR? (CADR X]
(RETURN T])
(GLATOMSTRFN
[LAMBDA (IND DES DESLIST) (* edited:
"26-OCT-82 15:26")
(* Try to get indicator
IND from an ATOM
structure.)
(PROG (TMP)
(RETURN (OR (AND (SETQ TMP (ASSOC (QUOTE PROPLIST)
(CDR DES)))
(GLPROPSTRFN IND TMP DESLIST T))
(AND (SETQ TMP (ASSOC (QUOTE BINDING)
(CDR DES)))
(GLSTRVALB IND (CADR TMP)
(QUOTE (EVAL *GL*])
(GLCARCDRRESULTTYPE
[LAMBDA (LST STR) (* edited:
"14-MAR-83 16:59")
(* Find the result type for a CAR/CDR function
applied to a structure whose description is STR.
LST is a list of A and D in application order.)
(COND
((NULL LST)
STR)
((NULL STR)
NIL)
((MEMB STR GLBASICTYPES)
NIL)
((ATOM STR)
(GLCARCDRRESULTTYPE LST (GLGETSTR STR)))
((NLISTP STR)
(ERROR))
(T (GLCARCDRRESULTTYPEB LST (GLXTRTYPE STR])
(GLCARCDRRESULTTYPEB
[LAMBDA (LST STR) (* edited:
"19-MAY-82 14:41")
(* Find the result type for a CAR/CDR function
applied to a structure whose description is STR.
LST is a list of A and D in application order.)
(COND
((NULL STR)
NIL)
((ATOM STR)
(GLCARCDRRESULTTYPE LST STR))
((NLISTP STR)
(ERROR))
((AND (ATOM (CAR STR))
(NOT (MEMB (CAR STR)
GLTYPENAMES))
(CDR STR)
(NULL (CDDR STR)))
(GLCARCDRRESULTTYPE LST (CADR STR)))
((EQ (CAR LST)
(QUOTE A))
(COND
((OR (EQ (CAR STR)
(QUOTE LISTOF))
(EQ (CAR STR)
(QUOTE CONS))
(EQ (CAR STR)
(QUOTE LIST)))
(GLCARCDRRESULTTYPE (CDR LST)
(CADR STR)))
(T NIL)))
[(EQ (CAR LST)
(QUOTE D))
(COND
((EQ (CAR STR)
(QUOTE CONS))
(GLCARCDRRESULTTYPE (CDR LST)
(CADDR STR)))
((EQ (CAR STR)
(QUOTE LIST))
(COND
[(CDDR STR)
(GLCARCDRRESULTTYPE (CDR LST)
(CONS (QUOTE LIST)
(CDDR STR]
(T NIL)))
((EQ (CAR STR)
(QUOTE LISTOF))
(GLCARCDRRESULTTYPE (CDR LST)
STR]
(T (ERROR])
(GLCLASS
[LAMBDA (OBJ) (* GSN "22-JUL-83 13:45"
) (* Get the Class of
object OBJ.)
(PROG (CLASS)
(RETURN (AND (SETQ CLASS (COND
((SELECTQ GLLISPDIALECT
((MACLISP FRANZLISP)
(HUNKP OBJ))
(PSL (VectorP OBJ))
NIL)
(SELECTQ GLLISPDIALECT
((MACLISP FRANZLISP)
(CXR 0 OBJ))
(PSL (GetV OBJ 0))
NIL))
((ATOM OBJ)
(GETPROP OBJ (QUOTE CLASS)))
((LISTP OBJ)
(CAR OBJ))
((AND (GETD (QUOTE GLUSERGETCLASS))
(GLUSERGETCLASS OBJ)))
(T NIL)))
(GLCLASSP CLASS)
CLASS])
(GLCLASSMEMP
[LAMBDA (OBJ CLASS) (* edited:
"11-NOV-82 11:23")
(* Test whether the
object OBJ is a member
of class CLASS.)
(GLDESCENDANTP (GLCLASS OBJ)
CLASS])
(GLCLASSP
[LAMBDA (CLASS) (* GSN "22-JUL-83 13:48"
) (* See if CLASS is a
Class name.)
(AND (ATOM CLASS)
(GETPROP CLASS (QUOTE GLSTRUCTURE])
(GLCLASSSEND
[LAMBDA (CLASS SELECTOR ARGS PROPNAME) (* GSN " 9-FEB-83 16:58"
)
(* Execute a message to CLASS with selector SELECTOR
and arguments ARGS. PROPNAME is one of MSG, ADJ,
ISA, PROP.)
(PROG (FNCODE)
[COND
((SETQ FNCODE (GLCOMPPROP CLASS SELECTOR PROPNAME))
(RETURN
(SELECTQ
GLLISPDIALECT
((INTERLISP FRANZLISP)
(APPLY FNCODE ARGS))
(COND
[(ATOM FNCODE)
(EVAL (CONS FNCODE (MAPCAR
ARGS
(FUNCTION KWOTE]
(T (APPLY FNCODE ARGS]
(RETURN (QUOTE GLSENDFAILURE])
(GLCOMPPROP
[LAMBDA (STR PROPNAME PROPTYPE) (* edited:
" 3-Dec-83 13:27")
(* Compile a LAMBDA expression to compute the
property PROPNAME of type PROPTYPE for structure
STR. The property type STR is allowed for structure
access.)
(PROG (CODE PL SUBPL PROPENT) (* See if the property
has already been
compiled.)
[COND
((NOT (ATOM STR))
(RETURN))
([AND (SETQ PL (GETPROP STR (QUOTE GLPROPFNS)))
(SETQ SUBPL (ASSOC PROPTYPE PL))
(SETQ PROPENT (ASSOC PROPNAME (CDR SUBPL]
(RETURN (CADR PROPENT] (* Compile code for this
property and save it.)
(COND
([NOT (MEMB PROPTYPE (QUOTE (STR ADJ ISA PROP MSG]
(ERROR)))
(OR (SETQ CODE (GLCOMPPROPL STR PROPNAME PROPTYPE))
(RETURN))
[COND
((NOT PL)
[PUTPROP STR (QUOTE GLPROPFNS)
(SETQ PL (COPY (QUOTE ((STR)
(PROP)
(ADJ)
(ISA)
(MSG]
(SETQ SUBPL (ASSOC PROPTYPE PL]
(RPLACD SUBPL (CONS (CONS PROPNAME CODE)
(CDR SUBPL)))
(RETURN (CAR CODE])
(GLCOMPPROPL
[LAMBDA (STR PROPNAME PROPTYPE) (* GSN "25-JUL-83 11:12"
)
(* Compile a message as a closed form, i.e.,
function name or LAMBDA form.)
(PROG (CODE MSGL TRANS TMP FETCHCODE NEWVAR GLNATOM CONTEXT VALBUSY
GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS
GLTYPESUBS FAULTFN GLNRECURSIONS)
(SETQ FAULTFN (QUOTE GLCOMPPROPL))
(SETQ GLNRECURSIONS 0)
(SETQ GLNATOM 0)
(SETQ VALBUSY T)
(SETQ GLSEPPTR 0)
(SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL)))
(COND
[(EQ PROPTYPE (QUOTE STR))
(COND
[(SETQ CODE (GLSTRFN PROPNAME STR NIL))
(RETURN (LIST (LIST (QUOTE LAMBDA)
(LIST (QUOTE self))
(GLUNWRAPC (DSUBST (QUOTE self)
(QUOTE *GL*)
(CAR CODE))
T))
(CADR CODE]
(T (RETURN]
[(SETQ MSGL (GLSTRPROP STR PROPTYPE PROPNAME NIL))
(COND
[(ATOM (CADR MSGL))
(COND
((AND (GLISPCP)
(LISTGET (CDDR MSGL)
(QUOTE OPEN)))
(SETQ CODE (GLCOMPOPEN (CADR MSGL)
T
(LIST STR)
NIL NIL)))
(T (SETQ CODE (LIST (CADR MSGL)
(GLRESULTTYPE (CADR MSGL)
NIL]
((AND (GLISPCP)
(SETQ CODE (GLADJ (LIST (QUOTE self)
STR)
PROPNAME PROPTYPE)))
(SETQ CODE (LIST (LIST (QUOTE LAMBDA)
(LIST (QUOTE self))
(GLUNWRAPC (CAR CODE)
T))
(CADR CODE]
((SETQ TRANS (GLTRANSPARENTTYPES STR))
(GO B))
(T (RETURN)))
[RETURN (LIST (GLUNWRAPC (CAR CODE)
T)
(OR (CADR CODE)
(LISTGET (CDDR MSGL)
(QUOTE RESULT]
(* Look for the message
in a contained
TRANSPARENT type.)
B (COND
((NULL TRANS)
(RETURN))
[(SETQ TMP (GLCOMPPROPL (GLXTRTYPE (CAR TRANS))
PROPNAME PROPTYPE))
(COND
((ATOM (CAR TMP))
(GLERROR (QUOTE GLCOMPPROPL)
(LIST "GLISP cannot currently"
"handle inheritance of the property"
PROPNAME
"which is specified as a function name"
"in a TRANSPARENT subtype. Sorry."))
(RETURN)))
(SETQ FETCHCODE (GLSTRFN (CAR TRANS)
STR NIL))
(SETQ NEWVAR (GLMKVAR))
(GLSTRVAL FETCHCODE NEWVAR)
(RETURN
(LIST (GLUNWRAPC
[LIST (QUOTE LAMBDA)
(CONS NEWVAR (CDADAR TMP))
(LIST (QUOTE PROG)
(LIST (LIST (CAADAR TMP)
(CAR FETCHCODE)))
(LIST (QUOTE RETURN)
(CADDAR TMP]
T)
(CADR TMP]
(T (SETQ TRANS (CDR TRANS))
(GO B])
(GLDEFAULTVALUE
[LAMBDA (STR) (* GSN "25-JUL-83 13:02"
) (* Find the default
value to use for an item
of type STR.)
(COND
((ATOM STR)
(SELECTQ STR
((INTEGER NUMBER)
0)
(REAL 0.0)
(STRING "")
NIL))
(T NIL])
(GLDEFFNRESULTTYPES
[LAMBDA (LST) (* edited:
"19-MAY-82 13:33")
(* Define the result types for a list of functions.
The format of the argument is a list of dotted
pairs, (FN . TYPE))
(MAPC LST (FUNCTION (LAMBDA (X)
(MAPC (CADR X)
(FUNCTION (LAMBDA (Y)
(PUTPROP Y (QUOTE GLRESULTTYPE)
(CAR X])
(GLDEFFNRESULTTYPEFNS
[LAMBDA (LST) (* edited:
"19-MAY-82 13:05")
(* Define the result type functions for a list of
functions. The format of the argument is a list of
dotted pairs, (FN . TYPEFN))
(MAPC LST (FUNCTION (LAMBDA (X)
(PUTPROP (CAR X)
(QUOTE GLRESULTTYPEFN)
(CDR X])
(GLDEFPROP
[LAMBDA (OBJECT PROP LST) (* GSN " 2-MAR-83 10:14"
)
(* Define properties for an object type.
Each property is of the form
(<propname> (<definition>) <properties>))
(PROG (LSTP)
[MAPC LST (FUNCTION (LAMBDA (X)
(COND
([NOT (OR (EQ PROP (QUOTE DOC))
(AND (EQ PROP (QUOTE SUPERS))
(ATOM X))
(AND (LISTP X)
(ATOM (CAR X))
(CDR X]
(PRIN1 "GLDEFPROP: For object ")
(PRIN1 OBJECT)
(PRIN1 " the ")
(PRIN1 PROP)
(PRIN1 " property ")
(PRIN1 X)
(PRIN1 " has bad form.")
(TERPRI)
(PRIN1 "This property was ignored.")
(TERPRI))
(T (SETQ LSTP (CONS X LSTP]
(NCONC (GETPROP OBJECT (QUOTE GLSTRUCTURE))
(LIST PROP (DREVERSE LSTP])
(GLDEFSTR
[LAMBDA (LST SYSTEMFLG) (* GSN " 1-JUN-83 17:28"
) (* "GSN: "
"17-Sep-81 12:21")
(* Process a Structure Description.
The format of the argument is the name of the
structure followed by its structure description,
followed by other optional arguments.)
(PROG (STRNAME STR OLDSTR)
(SETQ STRNAME (pop LST))
[COND
((AND (NOT SYSTEMFLG)
(MEMB STRNAME GLBASICTYPES))
(PRIN1 "The GLISP type ")
(PRIN1 STRNAME)
(PRIN1 " may not be redefined by the user.")
(TERPRI)
(RETURN))
((SETQ OLDSTR (GETPROP STRNAME (QUOTE GLSTRUCTURE)))
(COND
((EQUAL OLDSTR LST)
(RETURN))
((NOT GLQUIETFLG)
(PRIN1 STRNAME)
(PRIN1 " structure redefined.")
(TERPRI)))
(GLSTRCHANGED STRNAME))
((NOT SYSTEMFLG)
(SELECTQ GLLISPDIALECT
(INTERLISP (MARKASCHANGED STRNAME (QUOTE
GLISPOBJECTS)
T))
(SETQ STR T] (* The preceding
(SETQ STR T) avoids PSL
compiler bug.)
(SETQ STR (pop LST))
(PUTPROP STRNAME (QUOTE GLSTRUCTURE)
(LIST STR))
(COND
((NOT (GLOKSTR? STR))
(PRIN1 STRNAME)
(PRIN1 " has faulty structure specification.")
(TERPRI)))
[COND
((NOT (MEMB STRNAME GLOBJECTNAMES))
(SETQ GLOBJECTNAMES (CONS STRNAME GLOBJECTNAMES]
(* Process the remaining specifications, if any.
Each additional specification is a list beginning
with a keyword.)
LP (COND
((NULL LST)
(RETURN)))
(SELECTQ (CAR LST)
((ADJ Adj adj)
(GLDEFPROP STRNAME (QUOTE ADJ)
(CADR LST)))
((PROP Prop prop)
(GLDEFPROP STRNAME (QUOTE PROP)
(CADR LST)))
((ISA Isa IsA isA isa)
(GLDEFPROP STRNAME (QUOTE ISA)
(CADR LST)))
((MSG Msg msg)
(GLDEFPROP STRNAME (QUOTE MSG)
(CADR LST)))
(GLDEFPROP STRNAME (CAR LST)
(CADR LST)))
(SETQ LST (CDDR LST))
(GO LP])
(GLDEFSTRNAMES
[NLAMBDA LST (* edited:
"27-APR-82 11:01")
(MAPC LST (FUNCTION (LAMBDA (X)
(PROG (TMP)
(COND
((SETQ TMP (ASSOC (CAR X)
GLUSERSTRNAMES))
(RPLACD TMP (CDR X)))
(T (SETQ GLUSERSTRNAMES (NCONC1 GLUSERSTRNAMES X])
(GLDEFSTRQ
[NLAMBDA ARGS (* GSN "10-FEB-83 11:50"
)
(* Define named structure descriptions.
The descriptions are of the form
(<name> <description>). Each description is put on
the property list of <name> as GLSTRUCTURE)
(MAPC ARGS (FUNCTION (LAMBDA (ARG)
(GLDEFSTR ARG NIL])
(GLDEFSYSSTRQ
[NLAMBDA ARGS (* GSN "10-FEB-83 12:13"
)
(* Define named structure descriptions.
The descriptions are of the form
(<name> <description>). Each description is put on
the property list of <name> as GLSTRUCTURE)
(MAPC ARGS (FUNCTION (LAMBDA (ARG)
(GLDEFSTR ARG T])
(GLDEFUNITPKG
[LAMBDA (UNITREC) (* edited:
"27-MAY-82 13:00")
(* "GSN: "
" 2-Jun-81 13:31")
(* This function is called by the user to define a
unit package to the GLISP system.
The argument, a unit record, is a list consisting of
the name of a function to test an entity to see if
it is a unit of the units package, the name of the
unit package's runtime GET function, and an ALIST of
operations on units and the functions to perform
those operations. Operations include GET, PUT, ISA,
ISADJ, NCONC, REMOVE, PUSH, and POP.)
(PROG (LST)
(SETQ LST GLUNITPKGS)
A (COND
((NULL LST)
(SETQ GLUNITPKGS (NCONC1 GLUNITPKGS UNITREC))
(RETURN))
((EQ (CAAR LST)
(CAR UNITREC))
(RPLACA LST UNITREC)))
(SETQ LST (CDR LST))
(GO A])
(GLDELDEF
[LAMBDA (NAME TYPE) (* GSN "23-JAN-83 15:39"
) (* Remove the GLISP
structure definition for
NAME.)
(PUTPROP NAME (QUOTE GLSTRUCTURE)
NIL])
(GLDESCENDANTP
[LAMBDA (SUBCLASS CLASS) (* edited:
"28-NOV-82 15:18")
(PROG (SUPERS)
(COND
((EQ SUBCLASS CLASS)
(RETURN T)))
(SETQ SUPERS (GLGETSUPERS SUBCLASS))
LP (COND
((NULL SUPERS)
(RETURN))
((GLDESCENDANTP (CAR SUPERS)
CLASS)
(RETURN T)))
(SETQ SUPERS (CDR SUPERS))
(GO LP])
(GLDOEXPRC
[LAMBDA (START CONTEXT VALBUSY) (* GSN "22-JUL-83 14:34"
) (* Parse an expression
if the compiler is
present, else just
return it.)
(COND
((GLISPCP)
(GLDOEXPR START CONTEXT VALBUSY))
(START (LIST EXPR (QUOTE ANYTHING)))
(T (LIST (pop EXPR)
(QUOTE ANYTHING])
(GLED
[LAMBDA (FN) (* edited:
"20-MAY-82 12:48")
(* "GSN: "
"15-Apr-81 16:51")
(* Edit the compiled
version of a GLISP
function.)
(EDITV (GETPROPLIST (OR FN GLLASTFNCOMPILED)))
FN])
(GLEDS
[LAMBDA (STR) (* GSN "28-JAN-83 11:28"
) (* "GSN: "
"15-Apr-81 16:51")
(* Edit a GLISP
structure description.)
(EDITE (GETPROP (SETQ GLLASTSTREDITED (OR STR GLLASTSTREDITED))
(QUOTE GLSTRUCTURE))
NIL STR (QUOTE GLISPOBJECTS)
(QUOTE GLIFSTRCHANGED))
STR])
(GLERR
[NLAMBDA ERREXP (* edited:
"23-SEP-82 11:52")
(PRIN1 "Execution of GLISP error expression: ")
(PRINT ERREXP)
(ERROR])
(GLERROR
[LAMBDA (FN MSGLST) (* edited:
"23-SEP-82 11:44")
(* Print a GLISP error message.
The global stack EXPRSTACK is used to help the user
locate the error.)
(PROG NIL
(PRIN1 "GLISP error detected by ")
(PRIN1 FN)
(PRIN1 " in function ")
(PRINT FAULTFN)
[MAPC MSGLST (FUNCTION (LAMBDA (X)
(PRIN1 X)
(SPACES 1]
(TERPRI)
(PRIN1 "in expression: ")
(RESETFORM (PRINTLEVEL (QUOTE (2 . 20)))
(PRINTDEF (CAR EXPRSTACK)
15 T T)
(TERPRI)
(PRIN1 "within expr. ")
(PRINTDEF (CADR EXPRSTACK)
15 T NIL))
(TERPRI)
(COND
(GLBREAKONERROR (ERROR)))
(RETURN (LIST (LIST (QUOTE GLERR)
(LIST (QUOTE QUOTE)
(CAR EXPRSTACK)))
NIL])
(GLEXPENSIVE?
[LAMBDA (EXPR) (* edited:
" 9-JUN-82 12:55")
(* Test if EXPR is
expensive to compute.)
(COND
((ATOM EXPR)
NIL)
((NLISTP EXPR)
(ERROR))
((FMEMB (CAR EXPR)
(QUOTE (CDR CDDR CDDDR CDDDDR CAR CAAR CADR CAADR CADDR
CADDDR)))
(GLEXPENSIVE? (CADR EXPR)))
((AND (EQ (CAR EXPR)
(QUOTE PROG1))
(NULL (CDDR EXPR)))
(GLEXPENSIVE? (CADR EXPR)))
(T T])
(GLGENCODE
[LAMBDA (X) (* edited:
"19-OCT-82 15:19")
(* Generate code of the form X.
The code generated by the compiler is transformed,
if necessary, for the output dialect.)
(SELECTQ GLLISPDIALECT
(INTERLISP (GLINTERLISPTRANSFM X))
(MACLISP (GLMACLISPTRANSFM X))
(FRANZLISP (GLFRANZLISPTRANSFM X))
(UCILISP (GLUCILISPTRANSFM X))
(PSL (GLPSLTRANSFM X))
(ERROR])
(GLGETASSOC
[LAMBDA (KEY ALST) (* "GSN: "
"20-Mar-81 15:52")
(* Get the value for the entry KEY from the a-list
ALST. GETASSOC is used so that the corresponding
PUTASSOC can be generated by GLPUTFN.)
(PROG (TMP)
(RETURN (AND (SETQ TMP (ASSOC KEY ALST))
(CDR TMP])
(GLGETD
[LAMBDA (FN) (* GSN "22-JUL-83 13:54"
) (* Get the EXPR
definition of FN, if
available.)
(COND
((AND (CCODEP FN)
(OR (EQ (UNSAVEDEF FN (QUOTE EXPR))
(QUOTE EXPR))
(LOADDEF FN)))
(PRIN1 FN)
(SPACES 1)
(PRIN1 "unsaved.")
(TERPRI)))
(GETD FN])
(GLGETDB
[LAMBDA (FN) (* edited:
"19-MAY-82 16:11")
(* Get the function definition of FN, if easily
available, so it can be examined.)
(OR (AND (EQ (FNTYP FN)
(QUOTE EXPR))
(GETD FN))
(GETPROP FN (QUOTE EXPR])
(GLGETDEF
[LAMBDA (NAME TYPE) (* edited:
"30-OCT-81 12:20")
(* Get the GLISP object
description for NAME for
the file package.)
(LIST (QUOTE GLDEFSTRQ)
(CONS NAME (GETPROP NAME (QUOTE GLSTRUCTURE])
(GLGETFROMUNIT
[LAMBDA (UNITREC IND DES) (* edited:
"27-MAY-82 13:01")
(* "GSN: "
" 2-Jun-81 13:46")
(* Call the appropriate function to compile code to
get the indicator (QUOTE IND') from the item whose
description is DES, where DES describes a unit in a
unit package whose record is UNITREC.)
(PROG (TMP)
(COND
((SETQ TMP (ASSOC (QUOTE GET)
(CADDR UNITREC)))
(RETURN (APPLY* (CDR TMP)
IND DES)))
(T (RETURN])
(GLGETPAIRS
[LAMBDA (EXPR) (* GSN "25-JUL-83 11:21"
) (* edited:
"13-Aug-81 12:36")
(* Get pairs of <field> = <value>, where the = and ,
are optional.)
(PROG (PROP VAL PAIRLIST)
A (COND
((NULL EXPR)
(RETURN (DREVERSE PAIRLIST)))
([NOT (ATOM (SETQ PROP (pop EXPR]
(GLERROR (QUOTE GLGETPAIRS)
(LIST PROP "is not a legal property name.")))
((EQ PROP (QUOTE ,))
(GO A)))
(COND
((MEMB (CAR EXPR)
(QUOTE (= ← :=)))
(pop EXPR)))
(SETQ VAL (GLDOEXPRC NIL CONTEXT T))
(SETQ PAIRLIST (CONS (CONS PROP VAL)
PAIRLIST))
(GO A])
(GLGETSTR
[LAMBDA (DES) (* edited:
"23-DEC-81 12:52")
(* "GSN: "
" 5-Oct-81 13:27")
(* "GSN: "
"24-Apr-81 12:07")
(* "GSN: "
" 7-Jan-81 16:38")
(PROG (TYPE TMP)
(RETURN (AND (SETQ TYPE (GLXTRTYPE DES))
(ATOM TYPE)
(SETQ TMP (GETPROP TYPE (QUOTE GLSTRUCTURE)))
(CAR TMP])
(GLGETSUPERS
[LAMBDA (CLASS) (* edited:
"28-NOV-82 15:10")
(* Get the superclasses
of CLASS.)
(LISTGET (CDR (GETPROP CLASS (QUOTE GLSTRUCTURE)))
(QUOTE SUPERS])
(GLIFSTRCHANGED
[LAMBDA (ATM EXPR TYPE FLG) (* GSN "28-JAN-83 11:30"
) (* This function is
called by the editor if
a structure is changed.)
(COND
(FLG (GLSTRCHANGED ATM])
(GLINIT
[LAMBDA NIL (* "GSN: "
"12-Dec-83 11:37")
(* Initialize things for
GLISP)
(PROG NIL
(SETQ GLNOSPLITATOMS NIL)
[SETQ GLSEPBITTBL
(MAKEBITTABLE (QUOTE (: ← + - ' = ~ < > * / , ↑]
(SETQ GLUNITPKGS NIL)
(SETQ GLSEPMINUS NIL)
(SETQ GLQUIETFLG NIL)
(SETQ GLSEPATOM NIL)
(SETQ GLSEPPTR 0)
(SETQ GLBREAKONERROR NIL)
(SETQ GLUSERSTRNAMES NIL)
(SETQ GLTYPESUSED NIL)
(SETQ GLLASTFNCOMPILED NIL)
(SETQ GLLASTSTREDITED NIL)
(SETQ GLCAUTIOUSFLG NIL)
(SETQ GLGLSENDFLG NIL)
[MAPC (SELECTQ GLLISPDIALECT
(INTERLISP (QUOTE (EQ EQP NEQ EQUAL MEMB AND
OR NOT ZEROP NULL
NUMBERP FIXP FLOATP ATOM
LITATOM LISTP MINUSP
STRINGP FASSOC ASSOC
IGREATERP IGEQ ILESSP
ILEQ IPLUS ITIMES
IDIFFERENCE IQUOTIENT
ADD1 SUB1 PLUS MINUS
IMINUS TIMES SQRT EXPT
DIFFERENCE QUOTIENT
GREATERP GEQ LESSP LEQ
CAR CDR CAAR CADR)))
(MACLISP (QUOTE (EQ EQP AND OR NOT EQUAL ZEROP
NULL NULL NUMBERP FIXP
FLOATP ATOM SYMBOLP PAIRP
BIGP HUNKP ASCII PLUSP
MINUSP ODDP GREATERP LESSP
MEMQ ASSQ > = MAX MIN ABS
FIX FLOAT REMAINDER GCD \
\\ ↑ LOG EXP SIN COS ATAN
BOOLE ASH LSH ROT < + * /
- 1+ 1- ADD1 SUB1 PLUS
MINUS TIMES SQRT EXPT
DIFFERENCE QUOTIENT CAR
CDR CAAR CADR)))
(FRANZLISP (QUOTE (EQ NEQ AND OR NOT EQUAL
ATOM NULL DTPR SYMBOLP
STRINGP HUNKP MEMQ > = <
+ * / - 1+ 1- ADD1 SUB1
PLUS MINUS TIMES SQRT
EXPT DIFFERENCE QUOTIENT
ABS BOOLE COS EVENP EXP
FIX FIXP FLOAT FLOATP
GREATERP LESSP LOG LSH
MAX MIN MINUSP MOD
NUMBERP ODDP ONEP
REMAINDER ROT SIN SQRT
ZEROP CAR CDR CAAR CADR))
)
(UCILISP (QUOTE (EQ EQUAL AND OR NOT MEMQ > GE
= LE < + * / - ADD1 SUB1
PLUS MINUS TIMES
DIFFERENCE QUOTIENT CAR
CDR CAAR CADR)))
(PSL (QUOTE (EQ NE EQUAL AND OR NOT MEMQ ADD1
SUB1 EQN ASSOC PLUS MINUS
TIMES SQRT EXPT DIFFERENCE
QUOTIENT GREATERP GEQ LESSP
LEQ CAR CDR CAAR CADR)))
NIL)
(FUNCTION (LAMBDA (X)
(PUTPROP X (QUOTE GLEVALWHENCONST)
T]
[MAPC (SELECTQ GLLISPDIALECT
(INTERLISP (QUOTE (IGREATERP IGEQ ILESSP ILEQ
IPLUS ITIMES
IDIFFERENCE
IQUOTIENT ADD1
SUB1 PLUS MINUS
IMINUS TIMES SQRT
EXPT DIFFERENCE
QUOTIENT GREATERP
GEQ LESSP LEQ)))
(MACLISP (QUOTE (> = < + * / - 1+ 1- ADD1 SUB1
PLUS MINUS IMINUS TIMES
SQRT EXPT DIFFERENCE
QUOTIENT GREATERP LESSP)))
(FRANZLISP (QUOTE (> = < + * / - 1+ 1- ADD1
SUB1 PLUS MINUS IMINUS
TIMES SQRT EXPT
DIFFERENCE QUOTIENT
GREATERP LESSP)))
(UCILISP (QUOTE (> GE = LE < + * / - ADD1 SUB1
PLUS MINUS IMINUS TIMES
SQRT EXPT DIFFERENCE
QUOTIENT GREATERP LESSP)))
(PSL (QUOTE (ADD1 SUB1 EQN PLUS MINUS TIMES
SQRT EXPT DIFFERENCE
QUOTIENT GREATERP GEQ LESSP
LEQ)))
NIL)
(FUNCTION (LAMBDA (X)
(PUTPROP X (QUOTE GLARGSNUMBERP)
T]
[GLDEFFNRESULTTYPES (QUOTE ((NUMBER (PLUS MINUS DIFFERENCE
TIMES EXPT QUOTIENT
REMAINDER MIN MAX
ABS))
(INTEGER (LENGTH FIX ADD1 SUB1))
(REAL (SQRT LOG EXP SIN COS ATAN
ARCSIN ARCCOS ARCTAN
ARCTAN2 FLOAT))
(BOOLEAN (ATOM NULL EQUAL MINUSP
ZEROP GREATERP
LESSP NUMBERP
FIXP FLOATP
STRINGP ARRAYP EQ
NOT NULL BOUNDP]
(SELECTQ GLLISPDIALECT
[INTERLISP (GLDEFFNRESULTTYPES
(QUOTE ((INTEGER (FLENGTH IPLUS NCHARS
IMINUS
IDIFFERENCE
ITIMES
IQUOTIENT
IREMAINDER
IMIN IMAX
LOGAND LOGOR
LOGXOR LSH
RSH LRSH LLSH
GCD COUNT
COUNTDOWN
NARGS))
(BOOLEAN (LISTP IGREATERP
SMALLP
FGREATERP
FLESSP GEQ LEQ
LITATOM NLISTP
NEQ ILESSP
IGEQ ILEQ IEQP
CCODEP SCODEP
SUBRP EVERY
EQUALALL
EQLENGTH
EQUALN EXPRP
EQP))
(STRING (SUBSTRING CONCAT
MKSTRING))
(REAL (RAND RANDSET]
[MACLISP (GLDEFFNRESULTTYPES
(QUOTE ((INTEGER (+ - * / 1+ 1- FLATC))
(BOOLEAN (> PAIRP HUNKP BIGP EQP
< = SYMBOLP))
(STRING SUBSTRING CONCAT]
[FRANZLISP (GLDEFFNRESULTTYPES
(QUOTE ((INTEGER (+ - * / 1+ 1- FLATC))
(BOOLEAN (> BIGP HUNKP
< = DTPR SYMBOLP))
(STRING (SUBSTRING)) |
(ATOM (CONCAT] |
[UCILISP (GLDEFFNRESULTTYPES
(QUOTE ((INTEGER (+ - * / ADD1 SUB1
FLATSIZE FLATSIZEC))
(BOOLEAN (CONSP GE LE INUMP))
(STRING SUBSTRING CONCAT]
[PSL (GLDEFFNRESULTTYPES
(QUOTE ((INTEGER (FLATSIZE FLATSIZE2))
(BOOLEAN (EQN NE PAIRP IDP UNBOUNDP))
(STRING (SUBSTRING CONCAT]
NIL)
(GLDEFFNRESULTTYPEFNS
(APPEND (QUOTE ((CONS . GLLISTRESULTTYPEFN)
(LIST . GLLISTRESULTTYPEFN)
(NCONC . GLLISTRESULTTYPEFN)))
(SELECTQ GLLISPDIALECT
[(INTERLISP UCILISP)
(QUOTE ((NTH . GLNTHRESULTTYPEFN]
[PSL (QUOTE ((PNTH . GLNTHRESULTTYPEFN]
[(MACLISP FRANZLISP)
(QUOTE ((NTHCDR . GLNTHRESULTTYPEFN]
NIL)))
(SELECTQ GLLISPDIALECT
[INTERLISP (GLDEFSYSSTRQ (STRING STRING PROP
((LENGTH NCHARS
RESULT
INTEGER))
MSG
((+ CONCAT RESULT
STRING)))
(INTEGER INTEGER SUPERS
(NUMBER))
(ATOM ATOM PROP
((PNAME MKSTRING
RESULT STRING)
))
(REAL REAL SUPERS (NUMBER]
[MACLISP (GLDEFSYSSTRQ (STRING STRING PROP
((LENGTH FLATC RESULT
INTEGER))
MSG
((+ CONCAT RESULT
STRING)))
(INTEGER INTEGER SUPERS
(NUMBER))
(ATOM ATOM PROP
((PNAME (self)
RESULT STRING)))
(REAL REAL SUPERS (NUMBER]
[FRANZLISP (GLDEFSYSSTRQ (STRING STRING PROP
((LENGTH FLATC
RESULT
INTEGER))
MSG
((+ CONCAT RESULT
STRING)))
(INTEGER INTEGER SUPERS
(NUMBER))
(ATOM ATOM PROP
((PNAME GET←PNAME
RESULT STRING)
))
(REAL REAL SUPERS (NUMBER]
[UCILISP (GLDEFSYSSTRQ (STRING STRING PROP
((LENGTH STRLEN
RESULT
INTEGER))
MSG
((+ CONCAT RESULT
STRING)))
(INTEGER INTEGER SUPERS
(NUMBER))
(ATOM ATOM PROP
((PNAME STR RESULT
STRING)))
(REAL REAL SUPERS (NUMBER]
[PSL (GLDEFSYSSTRQ
(STRING STRING PROP
((LENGTH ((ADD1 (SIZE self)))
RESULT INTEGER))
MSG
((+ CONCAT RESULT STRING)))
(INTEGER INTEGER SUPERS (NUMBER))
(ATOM ATOM PROP ((PNAME ID2STRING RESULT
STRING)))
(REAL REAL SUPERS (NUMBER]
NIL])
(GLISPCONSTANTS
[NLAMBDA ARGS (* GSN "25-JUL-83 10:20"
) (* Define compile-time
constants.)
(PROG (TMP EXPR EXPRSTACK FAULTFN)
(MAPC ARGS (FUNCTION (LAMBDA (ARG)
(PUTPROP (CAR ARG)
(QUOTE GLISPCONSTANTFLG)
T)
(PUTPROP (CAR ARG)
(QUOTE GLISPORIGCONSTVAL)
(CADR ARG))
[PUTPROP (CAR ARG)
(QUOTE GLISPCONSTANTVAL)
(PROGN (SETQ EXPR (LIST (CADR ARG)))
(SETQ TMP (GLDOEXPRC NIL NIL T))
(SET (CAR ARG)
(EVAL (CAR TMP]
(PUTPROP (CAR ARG)
(QUOTE GLISPCONSTANTTYPE)
(OR (CADDR ARG)
(CADR TMP])
(GLISPCP
[LAMBDA NIL (* GSN "25-JUL-83 10:00"
) (* Test whether the
GLISP compiler is
present.)
(COND
((GETD (QUOTE GLDOEXPR))
T)
(T NIL])
(GLISPGLOBALS
[NLAMBDA ARGS (* GSN " 1-JUN-83 17:31"
) (* Define compile-time
constants.)
(MAPC ARGS (FUNCTION (LAMBDA (ARG)
(SELECTQ GLLISPDIALECT
(PSL (GLOBAL (LIST (CAR ARG)))
(PUTPROP (CAR ARG)
(QUOTE GLISPGLOBALVAR)
T))
(PUTPROP (CAR ARG)
(QUOTE GLISPGLOBALVAR)
T))
(PUTPROP (CAR ARG)
(QUOTE GLISPGLOBALVARTYPE)
(CADR ARG])
(GLISPOBJECTS
[NLAMBDA ARGS (* GSN "10-FEB-83 11:51"
) (* "GSN: "
" 7-Jan-81 10:48")
(* Define named structure descriptions.
The descriptions are of the form
(<name> <description>). Each description is put on
the property list of <name> as GLSTRUCTURE)
(MAPC ARGS (FUNCTION (LAMBDA (ARG)
(GLDEFSTR ARG NIL])
(GLLISTRESULTTYPEFN
[LAMBDA (FN ARGTYPES) (* edited:
"12-NOV-82 10:53")
(* Compute result types
for Lisp functions.)
(PROG (ARG1 ARG2)
(SETQ ARG1 (GLXTRTYPE (CAR ARGTYPES)))
[COND
((CDR ARGTYPES)
(SETQ ARG2 (GLXTRTYPE (CADR ARGTYPES]
(RETURN
(SELECTQ
FN
(CONS (OR (AND (LISTP ARG2)
(COND
[(EQ (CAR ARG2)
(QUOTE LIST))
(CONS (QUOTE LIST)
(CONS ARG1 (CDR ARG2]
((AND (EQ (CAR ARG2)
(QUOTE LISTOF))
(EQUAL ARG1 (CADR ARG2)))
ARG2)))
(LIST FN ARGTYPES)))
[NCONC (COND
((EQUAL ARG1 ARG2)
ARG1)
((AND (LISTP ARG1)
(LISTP ARG2)
(EQ (CAR ARG1)
(QUOTE LISTOF))
(EQ (CAR ARG2)
(QUOTE LIST))
(NULL (CDDR ARG2))
(EQUAL (CADR ARG1)
(CADR ARG2)))
ARG1)
(T (OR ARG1 ARG2]
[LIST (CONS FN (MAPCAR ARGTYPES (FUNCTION GLXTRTYPE]
(ERROR])
(GLLISTSTRFN
[LAMBDA (IND DES DESLIST) (* GSN "11-JAN-83 14:05"
)
(* Create a function call to retrieve the field IND
from a LIST structure.)
(PROG (TMP N FNLST)
(SETQ N 1)
[SETQ FNLST (QUOTE ((CAR *GL*)
(CADR *GL*)
(CADDR *GL*)
(CADDDR *GL*]
[COND
((EQ (CAR DES)
(QUOTE LISTOBJECT))
(SETQ N (ADD1 N))
(SETQ FNLST (CDR FNLST]
C (pop DES)
[COND
((NULL DES)
(RETURN))
((NLISTP (CAR DES)))
((SETQ TMP (GLSTRFN IND (CAR DES)
DESLIST))
(RETURN
(GLSTRVAL TMP
(COND
(FNLST (COPY (CAR FNLST)))
(T (LIST (QUOTE CAR)
(GLGENCODE (LIST (QUOTE NTH)
(QUOTE *GL*)
N]
(SETQ N (ADD1 N))
(AND FNLST (SETQ FNLST (CDR FNLST)))
(GO C])
(GLMKATOM
[LAMBDA (NAME) (* edited:
"11-NOV-82 11:54")
(* Make a variable name
for GLCOMP functions.)
(PROG (N NEWATOM)
LP [PUTPROP NAME (QUOTE GLISPATOMNUMBER)
(SETQ N (ADD1 (OR (GETPROP NAME (QUOTE
GLISPATOMNUMBER))
0]
[SETQ NEWATOM (PACK (APPEND (UNPACK NAME)
(UNPACK N]
(* If an atom with this name has something on its
proplist, try again.)
(COND
((GETPROPLIST NEWATOM)
(GO LP))
(T (RETURN NEWATOM])
(GLMKRECORD
[LAMBDA (N NAME) (* GSN "25-JUL-83 14:09"
) (* Make a record with a
given length or
datatype.)
(SELECTQ GLLISPDIALECT
(PSL (MKVECT (SUB1 N)))
((MACLISP FRANZLISP)
(MAKHUNK N))
[INTERLISP (COND
(NAME (EVAL (LIST (QUOTE create)
NAME)))
(T (COND
((LEQ N 0)
NIL)
(T (CONS NIL (GLMKRECORD (SUB1 N)
NAME]
(COND
((LEQ N 0)
NIL)
(T (CONS NIL (GLMKRECORD (SUB1 N)
NAME])
(GLMKSTR
[LAMBDA (STR NAME PAIRS PREVLST) (* edited:
" 3-Dec-83 13:26")
(* Make a structure at runtime.
STR is the structure description, and PAIRS is an
ALIST of field names and values.
The values are unevaluated, in GLISP code form,
i.e., a list of code and type.)
(PROG (TMP NEW N)
(RETURN
(COND
[(ATOM STR)
(COND
((OR (NULL STR)
(FMEMB STR GLBASICTYPES))
(RETURN (GLDEFAULTVALUE STR)))
((FMEMB STR PREVLST)
(RETURN))
(T (RETURN (GLMKSTR (GLGETSTR STR)
STR NIL (CONS STR PREVLST]
((NLISTP STR)
(GLERROR (QUOTE GLMKSTR)
(LIST "Illegal structure specification" STR)))
(T
(SELECTQ
(CAR STR)
(CONS (CONS (GLMKSTR (CADR STR)
NIL PAIRS PREVLST)
(GLMKSTR (CADDR STR)
NIL PAIRS PREVLST)))
[LIST (MAPCAR (CDR STR)
(FUNCTION (LAMBDA (X)
(GLMKSTR X NIL PAIRS PREVLST]
(LISTOF NIL)
[ALIST
(MAPCONC
(CDR STR)
(FUNCTION (LAMBDA (X)
(COND
[(ASSOC (CAR X)
PAIRS)
(LIST
(CONS
(CAR X)
(EVAL (CADR (ASSOC (CAR X)
PAIRS]
((COND
((SETQ TMP (GLMKSTR (CADR X)
NIL PAIRS PREVLST))
(LIST (CONS (CAR X)
TMP]
[PROPLIST
(MAPCONC
(CDR STR)
(FUNCTION (LAMBDA (X)
(COND
[(ASSOC (CAR X)
PAIRS)
(LIST (CAR X)
(EVAL (CADR (ASSOC (CAR X)
PAIRS]
((COND
((SETQ TMP (GLMKSTR (CADR X)
NIL PAIRS PREVLST))
(LIST (CAR X)
TMP]
[TRANSPARENT (COND
((FMEMB (CADR STR)
PREVLST)
NIL)
(T (GLMKSTR (GLGETSTR (CADR STR))
NIL PAIRS
(CONS (CADR STR)
PREVLST]
(ATOM [SETQ NEW (GLMKATOM (OR NAME (QUOTE GLATOM]
[MAPC (CDR STR)
(FUNCTION (LAMBDA (Y)
(COND
[(EQ (CAR Y)
(QUOTE PROPLIST))
(MAPC (CDR Y)
(FUNCTION (LAMBDA (X)
(PUTPROP NEW
(CAR X)
(GLMKSTR
X NIL PAIRS
PREVLST]
((EQ (CAR Y)
(QUOTE BINDING))
(SET NEW (GLMKSTR (CADR Y)
NIL PAIRS
PREVLST]
NEW)
(ATOMOBJECT [SETQ NEW (GLMKATOM (OR NAME
(QUOTE GLATOM]
(PUTPROP NEW (QUOTE CLASS)
NAME)
[MAPC (CDR STR)
(FUNCTION (LAMBDA (X)
(PUTPROP NEW (CAR X)
(GLMKSTR X NIL PAIRS
PREVLST]
NEW)
[LISTOBJECT (CONS NAME
(MAPCAR (CDR STR)
(FUNCTION (LAMBDA (X)
(GLMKSTR X NIL PAIRS
PREVLST]
((OBJECT RECORD)
[SETQ NEW (GLMKRECORD
[COND
[(EQ (CAR STR)
(QUOTE OBJECT))
(ADD1 (LENGTH (CDR STR]
((ATOM (CADR STR))
(LENGTH (CDDR STR)))
(T (LENGTH (CDR STR]
(AND (ATOM (CADR STR))
(CADR STR]
(SETQ N 0)
[COND
((EQ (CAR STR)
(QUOTE OBJECT))
[SELECTQ GLLISPDIALECT
[INTERLISP (COND
((LISTP NEW)
(RPLACA NEW NAME]
(PSL (PUTV NEW 0 NAME))
((MACLISP FRANZLISP)
(RPLACX 0 NEW NAME))
(COND
((LISTP NEW)
(RPLACA NEW NAME]
(SETQ N (ADD1 N]
[MAPC
(CDR STR)
(FUNCTION (LAMBDA (X)
(SETQ TMP (GLMKSTR X NIL PAIRS PREVLST))
[SELECTQ
GLLISPDIALECT
[INTERLISP (COND
((LISTP NEW)
(RPLACA (NTH NEW
(ADD1 N))
TMP]
(PSL (PUTV NEW N TMP))
((MACLISP FRANZLISP)
(RPLACX N NEW TMP))
(COND
((LISTP NEW)
(RPLACA (NTH NEW (ADD1 N))
TMP]
(SETQ N (ADD1 N]
NEW)
(COND
((SETQ TMP (ASSOC (CAR STR)
PAIRS))
(EVAL (CADR TMP)))
((GLMKSTR (CADR STR)
NIL PAIRS PREVLST])
(GLMKVAR
[LAMBDA NIL (* edited:
"27-MAY-82 11:04")
(* Make a variable name
for GLCOMP functions.)
(PROG NIL
(SETQ GLNATOM (ADD1 GLNATOM))
(RETURN (PACK (APPEND (QUOTE (G L V A R))
(UNPACK GLNATOM])
(GLNOTICETYPE
[LAMBDA (TYPE) (* GSN "28-JAN-83 09:39"
) (* Add TYPE to the
global variable
GLTYPESUSED if not
already there.)
(COND
((NOT (FMEMB TYPE GLTYPESUSED))
(SETQ GLTYPESUSED (CONS TYPE GLTYPESUSED])
(GLNTHRESULTTYPEFN
[LAMBDA (FN ARGTYPES) (* edited:
" 3-Dec-83 13:49")
(* Compute the result
type for the function
NTH or NTHCDR.)
(PROG (TMP TYPE)
(SETQ TYPE (SELECTQ GLLISPDIALECT
((INTERLISP PSL UCILISP)
(CAR ARGTYPES))
((MACLISP FRANZLISP)
(CADR ARGTYPES))
NIL))
(RETURN (COND
((AND (LISTP (SETQ TMP (GLXTRTYPE TYPE)))
(EQ (CAR TMP)
(QUOTE LISTOF)))
TYPE)
(T NIL])
(GLOKSTR?
[LAMBDA (STR) (* "GSN: "
"22-Dec-83 10:44")
(* Check a structure
description for
legality.)
(COND
((NULL STR)
NIL)
((ATOM STR)
T)
[(AND (LISTP STR)
(ATOM (CAR STR)))
(SELECTQ (CAR STR)
[(A AN a an An)
(COND
((CDDR STR)
NIL)
((OR (GLGETSTR (CADR STR))
(GLUNIT? (CADR STR))
(COND
(GLCAUTIOUSFLG (PRIN1 "The structure ")
(PRIN1 (CADR STR))
(PRIN1
" is not currently defined. Accepted.")
(TERPRI)
T)
(T T]
[CONS (AND (CDR STR)
(CDDR STR)
(NULL (CDDDR STR))
(GLOKSTR? (CADR STR))
(GLOKSTR? (CADDR STR]
[(LIST OBJECT ATOMOBJECT LISTOBJECT)
(AND (CDR STR)
(EVERY (CDR STR)
(FUNCTION GLOKSTR?]
[RECORD (COND
((AND (CDR STR)
(ATOM (CADR STR)))
(pop STR)))
(AND (CDR STR)
(EVERY (CDR STR)
(FUNCTION (LAMBDA (X)
(AND (ATOM (CAR X))
(GLOKSTR? (CADR X]
[LISTOF (AND (CDR STR)
(NULL (CDDR STR))
(GLOKSTR? (CADR STR]
[(ALIST PROPLIST)
(AND (CDR STR)
(EVERY (CDR STR)
(FUNCTION (LAMBDA (X)
(AND (ATOM (CAR X))
(GLOKSTR? (CADR X]
(ATOM (GLATMSTR? STR))
(TYPEOF T)
(COND
((AND (CDR STR)
(NULL (CDDR STR)))
(GLOKSTR? (CADR STR)))
((ASSOC (CAR STR)
GLUSERSTRNAMES))
[(AND (BOUNDP (QUOTE GEVUSERTYPENAMES)) |
(FMEMB (CAR STR)
GEVUSERTYPENAMES))
(AND (CDR STR)
(EVERY (CDR STR)
(FUNCTION (LAMBDA (X)
(AND (ATOM (CAR X))
(GLOKSTR? (CADR X]
(T NIL]
(T NIL])
(GLP
[LAMBDA (FUN) (* edited:
"29-APR-82 09:42")
(* Prettyprint the
compiled version of a
function)
(PROG (FN)
(SETQ FN (OR FUN GLLASTFNCOMPILED))
(PRIN1 "GLRESULTTYPE: ")
(PRINT (GETPROP FN (QUOTE GLRESULTTYPE)))
(PRINTDEF (GETPROP FN (QUOTE GLCOMPILED)))
(TERPRI)
(RETURN FN])
(GLPROPSTRFN
[LAMBDA (IND DES DESLIST FLG) (* edited:
"14-MAR-83 17:12")
(* Create a function call to retrieve the field IND
from a property-list type structure.
FLG is true if a PROPLIST is inside an ATOM
structure.)
(PROG (DESIND TMP RECNAME N) (* Handle a PROPLIST by
looking inside each
property for IND.)
[COND
((AND (EQ (SETQ DESIND (pop DES))
(QUOTE RECORD))
(ATOM (CAR DES)))
(SETQ RECNAME (pop DES]
(SETQ N 0)
P (COND
((NULL DES)
(RETURN))
((AND (LISTP (CAR DES))
(ATOM (CAAR DES))
(CDAR DES)
(SETQ TMP (GLSTRFN IND (CAR DES)
DESLIST)))
(SETQ TMP
(GLSTRVAL
TMP
(SELECTQ
DESIND
(ALIST (LIST (QUOTE GLGETASSOC)
(KWOTE (CAAR DES))
(QUOTE *GL*)))
[(RECORD OBJECT)
[COND
((EQ DESIND (QUOTE OBJECT))
(SETQ N (ADD1 N]
(SELECTQ
GLLISPDIALECT
[INTERLISP
(COND
(RECNAME (LIST (QUOTE fetch)
(LIST RECNAME (CAAR DES))
(QUOTE of)
(QUOTE *GL*)))
(T (LIST (QUOTE CAR)
(GLGENCODE (LIST (QUOTE NTH)
(QUOTE *GL*)
(ADD1 N]
((MACLISP FRANZLISP)
(LIST (QUOTE CXR)
N
(QUOTE *GL*)))
(PSL (LIST (QUOTE GetV)
(QUOTE *GL*)
N))
(LIST (QUOTE CAR)
(GLGENCODE (LIST (QUOTE NTH)
(QUOTE *GL*)
(ADD1 N]
[(PROPLIST ATOMOBJECT)
(GLGENCODE (LIST (COND
((OR FLG (EQ DESIND
(QUOTE ATOMOBJECT)
))
(QUOTE GETPROP))
(T (QUOTE LISTGET)))
(QUOTE *GL*)
(KWOTE (CAAR DES]
NIL)))
(RETURN TMP))
(T (pop DES)
(SETQ N (ADD1 N))
(GO P])
(GLPUTARITH
[LAMBDA (LHS RHS) (* GSN "22-JAN-83 14:44"
)
(* Process a "store" into a value which is computed
by an arithmetic expression.)
(PROG (LHSC OP TMP NEWLHS NEWRHS)
(SETQ LHSC (CAR LHS))
(SETQ OP (CAR LHSC))
(COND
([NOT (SETQ TMP (FASSOC OP (QUOTE ((PLUS DIFFERENCE)
(MINUS MINUS)
(DIFFERENCE PLUS)
(TIMES QUOTIENT)
(QUOTIENT TIMES)
(IPLUS IDIFFERENCE)
(IMINUS IMINUS)
(IDIFFERENCE IPLUS)
(ITIMES IQUOTIENT)
(IQUOTIENT ITIMES)
(ADD1 SUB1)
(SUB1 ADD1)
(EXPT SQRT)
(SQRT EXPT]
(RETURN)))
(SETQ NEWLHS (CADR LHSC))
(SELECTQ OP
[(ADD1 SUB1 MINUS IMINUS)
(SETQ NEWRHS (LIST (CADR TMP)
(CAR RHS]
[(PLUS DIFFERENCE TIMES QUOTIENT IPLUS IDIFFERENCE
ITIMES IQUOTIENT)
(COND
[(NUMBERP (CADDR LHSC))
(SETQ NEWRHS (LIST (CADR TMP)
(CAR RHS)
(CADDR LHSC]
((NUMBERP (CADR LHSC))
(SETQ NEWLHS (CADDR LHSC))
(SELECTQ OP
[(DIFFERENCE IDIFFERENCE QUOTIENT
IQUOTIENT)
(SETQ NEWRHS (LIST OP (CADR LHSC)
(CAR RHS]
(PROGN (SETQ NEWRHS
(LIST (CADR TMP)
(CAR RHS)
(CADR LHSC]
[EXPT (COND
((EQUAL (CADDR LHSC)
2)
(SETQ NEWRHS (LIST (CADR TMP)
(CAR RHS]
(SQRT (SETQ NEWRHS (LIST (CADR TMP)
(CAR RHS)
2)))
NIL)
(RETURN (AND NEWRHS (GLPUTFN (LIST NEWLHS (CADR LHS))
(LIST NEWRHS (CADR RHS))
NIL])
(GLPUTFN
[LAMBDA (LHS RHS OPTFLG) (* GSN "25-JUL-83 10:57"
) (* edited:
" 2-Jun-81 14:16")
(* edited:
"24-Apr-81 12:05")
(* edited:
"21-Apr-81 11:28")
(* Create code to put the right-hand side datum RHS
into the left-hand side, whose access function and
type are given by LHS.)
(PROG (LHSD LNAME TMP RESULT TMPVAR GETFN PUTFN REST)
(SETQ LHSD (CAR LHS))
[COND
((ATOM LHSD)
(RETURN (OR (AND (GLISPCP)
(GLDOMSG LHS (QUOTE ←)
(LIST RHS)))
(GLUSERSTROP LHS (QUOTE ←)
RHS)
(AND (NULL (CADR LHS))
(CADR RHS)
(GLUSERSTROP (LIST (CAR LHS)
(CADR RHS))
(QUOTE ←)
RHS))
(AND (GLISPCP)
(GLDOVARSETQ LHSD RHS]
(SETQ LNAME (CAR LHSD))
[COND
[(SETQ TMP (GLANYCARCDR? LNAME))
(SETQ TMP (DREVERSE TMP))
[SETQ PUTFN (COND
((EQ (CAR TMP)
(QUOTE A))
(QUOTE RPLACA))
(T (QUOTE RPLACD]
[SETQ GETFN (COND
((EQ (CAR TMP)
(QUOTE A))
(QUOTE CAR))
(T (QUOTE CDR]
[SETQ REST (COND
((CDR TMP)
(LIST (PACK (NCONC1 (CONS (QUOTE C)
(CDR TMP))
(QUOTE R)))
(CADR LHSD)))
(T (CADR LHSD]
(SETQ RESULT
(COND
[(AND OPTFLG (GLEXPENSIVE? REST))
(LIST (QUOTE PROG)
(LIST (LIST (SETQ TMPVAR (GLMKVAR))
REST))
(LIST (QUOTE RETURN)
(LIST GETFN (LIST PUTFN TMPVAR
(SUBST TMPVAR REST
(CAR RHS]
(T (LIST GETFN (LIST PUTFN REST (CAR RHS]
[[SETQ TMP (ASSOC LNAME (QUOTE ((GetV . PutV)
(IGetV . IPutV)
(GET . PUTPROP)
(GETPROP . PUTPROP)
(LISTGET . LISTPUT]
(SETQ RESULT (LIST (CDR TMP)
(CADR LHSD)
(CADDR LHSD)
(CAR RHS]
[(EQ LNAME (QUOTE CXR))
(SETQ RESULT (LIST (QUOTE CXR)
(CADR LHSD)
(LIST (QUOTE RPLACX)
(CADR LHSD)
(CADDR LHSD)
(CAR RHS]
[(EQ LNAME (QUOTE GLGETASSOC))
(SETQ RESULT (LIST (QUOTE PUTASSOC)
(CADR LHSD)
(CAR RHS)
(CADDR LHSD]
[(EQ LNAME (QUOTE EVAL))
(SETQ RESULT (LIST (QUOTE SET)
(CADR LHSD)
(CAR RHS]
[(EQ LNAME (QUOTE fetch))
(SETQ RESULT (LIST (QUOTE replace)
(CADR LHSD)
(QUOTE of)
(CADDDR LHSD)
(QUOTE with)
(CAR RHS]
((SETQ TMP (GLUNITOP LHS RHS (QUOTE PUT)))
(RETURN TMP))
([AND (GLISPCP)
(SETQ TMP (GLDOMSG LHS (QUOTE ←)
(LIST RHS]
(RETURN TMP))
((SETQ TMP (GLUSERSTROP LHS (QUOTE ←)
RHS))
(RETURN TMP))
((SETQ TMP (GLPUTARITH LHS RHS))
(RETURN TMP))
(T (RETURN (GLERROR (QUOTE GLPUTFN)
(LIST "Illegal assignment. LHS =" LHS
"RHS ="
RHS]
X (RETURN (LIST (GLGENCODE RESULT)
(OR (CADR LHS)
(CADR RHS])
(GLRESULTTYPE
[LAMBDA (ATM ARGTYPES) (* edited:
"26-MAY-82 16:14")
(* "GSN: "
" 1-Jun-81 16:03")
(* Get the result type for a function which has a
GLAMBDA definition. ATM is the function name.)
(PROG (TYPE FNDEF STR TMP) (* See if this function
has a known result
type.)
(COND
((SETQ TYPE (GETPROP ATM (QUOTE GLRESULTTYPE)))
(RETURN TYPE)))
(* If there exists a function to compute the result
type, let it do so.)
[COND
((SETQ TMP (GETPROP ATM (QUOTE GLRESULTTYPEFN)))
(RETURN (APPLY* TMP ATM ARGTYPES)))
((SETQ TMP (GLANYCARCDR? ATM))
(RETURN (GLCARCDRRESULTTYPE TMP (CAR ARGTYPES]
(SETQ FNDEF (GLGETDB ATM))
(COND
([OR (NLISTP FNDEF)
(NOT (FMEMB (CAR FNDEF)
(QUOTE (LAMBDA GLAMBDA]
(RETURN)))
(SETQ FNDEF (CDDR FNDEF))
A (COND
((OR (NULL FNDEF)
(NLISTP (CAR FNDEF)))
(RETURN))
([OR (AND (EQ GLLISPDIALECT (QUOTE INTERLISP))
(EQ (CAAR FNDEF)
(QUOTE *)))
(MEMB (CAAR FNDEF)
(QUOTE (GLOBAL Global global]
(pop FNDEF)
(GO A))
([AND (MEMB (CAAR FNDEF)
(QUOTE (RESULT Result result)))
(GLOKSTR? (SETQ STR (CADAR FNDEF]
(RETURN STR))
(T (RETURN])
(GLSEND
[NLAMBDA GLISPSENDARGS (* GSN " 9-FEB-83 16:46"
)
(GLSENDB (EVAL (CAR GLISPSENDARGS))
NIL
(CADR GLISPSENDARGS)
(QUOTE MSG)
(MAPCAR (CDDR GLISPSENDARGS)
(FUNCTION EVAL])
(GLSENDB
[LAMBDA (OBJ CLASS SELECTOR PROPTYPE ARGS) (* GSN " 1-JUN-83 17:43"
) (* Send a runtime
message to OBJ.)
(DECLARE (SPECVARS *GL* *GLVAL*))
(PROG (RESULT ARGLIST FNCODE PUTCODE *GL* *GLVAL* SEL
(FAULTFN (QUOTE GLSENDB))
SV TMP)
[COND
(CLASS)
((SETQ CLASS (GLCLASS OBJ)))
(T (ERROR (LIST "Object" OBJ "has no Class."]
(SETQ ARGLIST (CONS OBJ ARGS))
(COND
((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
PROPTYPE))
(QUOTE GLSENDFAILURE))
(RETURN RESULT))
([AND (EQ SELECTOR (QUOTE CLASS))
(MEMB PROPTYPE (QUOTE (PROP MSG]
(RETURN CLASS))
((NEQ PROPTYPE (QUOTE MSG))
(GO ERR))
[(AND ARGS (NULL (CDR ARGS))
(EQ (NTHCHAR SELECTOR -1)
(QUOTE :))
(SETQ SEL (SUBATOM SELECTOR 1 -2))
[SETQ FNCODE (OR (GLCOMPPROP CLASS SEL (QUOTE STR))
(GLCOMPPROP CLASS SEL (QUOTE PROP]
(SETQ PUTCODE
(PROGN (SELECTQ GLLISPDIALECT
(UCI (COND
((BOUNDP (QUOTE
MACROEXPANSION))
(SETQ SV MACROEXPANSION)
(SETQ MACROEXPANSION NIL))
(T T)))
T)
(SETQ TMP (GLPUTFN
(LIST (SUBST (QUOTE *GL*)
(CAADR FNCODE)
(CADDR FNCODE))
NIL)
(LIST (QUOTE *GLVAL*)
NIL)
NIL))
(SELECTQ GLLISPDIALECT
[UCI (COND
((BOUNDP (QUOTE
MACROEXPANSION))
(SETQ MACROEXPANSION SV]
T)
TMP)))
(SETQ *GLVAL*(CAR ARGS))
(SETQ *GL* OBJ)
(RETURN (EVAL (CAR PUTCODE]
(ARGS (GO ERR))
((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
(QUOTE STR)))
(QUOTE GLSENDFAILURE))
(RETURN RESULT))
((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
(QUOTE PROP)))
(QUOTE GLSENDFAILURE))
(RETURN RESULT))
((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
(QUOTE ADJ)))
(QUOTE GLSENDFAILURE))
(RETURN RESULT))
((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
(QUOTE ISA)))
(QUOTE GLSENDFAILURE))
(RETURN RESULT)))
ERR (ERROR (LIST "Message" SELECTOR "to object" OBJ "of class"
CLASS "not understood."])
(GLSENDC
[NLAMBDA GLISPSENDARGS (* GSN " 9-FEB-83 16:48"
)
(GLSENDB (EVAL (CAR GLISPSENDARGS))
(CADR GLISPSENDARGS)
(CADDR GLISPSENDARGS)
(QUOTE MSG)
(MAPCAR (CDDDR GLISPSENDARGS)
(FUNCTION EVAL])
(GLSENDPROP
[NLAMBDA GLISPSENDPROPARGS (* GSN " 9-FEB-83 16:46"
)
(GLSENDB (EVAL (CAR GLISPSENDPROPARGS))
NIL
(CADR GLISPSENDPROPARGS)
(CADDR GLISPSENDPROPARGS)
(MAPCAR (CDDDR GLISPSENDPROPARGS)
(FUNCTION EVAL])
(GLSENDPROPC
[NLAMBDA GLISPSENDPROPARGS (* GSN " 9-FEB-83 16:48"
)
(GLSENDB (EVAL (CAR GLISPSENDPROPARGS))
(CADR GLISPSENDPROPARGS)
(CADDR GLISPSENDPROPARGS)
(CADDDR GLISPSENDPROPARGS)
(MAPCAR (CDDDDR GLISPSENDPROPARGS)
(FUNCTION EVAL])
(GLSTRCHANGED
[LAMBDA (STR) (* GSN "25-JUL-83 10:31"
)
(* This function is called when the structure STR
has been changed. It uncompiles code which depends
on STR.)
(PROG (FNS)
(COND
((NOT (GETPROP STR (QUOTE GLSTRUCTURE)))
(RETURN))
((GETPROP STR (QUOTE GLPROPFNS))
(PUTPROP STR (QUOTE GLPROPFNS)
NIL)))
[SELECTQ GLLISPDIALECT
[INTERLISP (MARKASCHANGED STR (QUOTE GLISPOBJECTS)
NIL)
(SETQ FNS (GETPROP STR (QUOTE GLFNSUSEDIN]
(SETQ FNS (GETPROP STR (QUOTE GLFNSUSEDIN]
(PUTPROP STR (QUOTE GLFNSUSEDIN)
NIL)
(COND
((GLISPCP)
(MAPC FNS (FUNCTION GLUNCOMPILE])
(GLSTRFN
[LAMBDA (IND DES DESLIST) (* GSN "28-JAN-83 10:19"
)
(* Create a function call to retrieve the field IND
from a structure described by the structure
description DES. The value is NIL if failure,
(NIL DESCR) if DES equals IND, or
(FNSTR DESCR) if IND can be gotten from within DES.
In the latter case, FNSTR is a function to get the
IND from the atom *GL*. GLSTRFN only does retrieval
from a structure, and does not get properties of an
object unless they are part of a TRANSPARENT
substructure. DESLIST is a list of structure
descriptions which have been tried already;
this prevents a compiler loop in case the user
specifies circular TRANSPARENT structures.)
(PROG (DESIND TMP STR UNITREC) (* If this structure has
already been tried, quit
to avoid a loop.)
(COND
((FMEMB DES DESLIST)
(RETURN)))
(SETQ DESLIST (CONS DES DESLIST))
[COND
((OR (NULL DES)
(NULL IND))
(RETURN))
[[OR (ATOM DES)
(AND (LISTP DES)
(ATOM (CADR DES))
(GL-A-AN? (CAR DES))
(SETQ DES (CADR DES]
(RETURN (COND
((SETQ STR (GLGETSTR DES))
(GLNOTICETYPE DES)
(GLSTRFN IND STR DESLIST))
((SETQ UNITREC (GLUNIT? DES))
(GLGETFROMUNIT UNITREC IND DES))
((EQ IND DES)
(LIST NIL (CADR DES)))
(T NIL]
((NLISTP DES)
(GLERROR (QUOTE GLSTRFN)
(LIST "Bad structure specification" DES]
(SETQ DESIND (CAR DES))
[COND
((OR (EQ IND DES)
(EQ DESIND IND))
(RETURN (LIST NIL (CADR DES]
(RETURN (SELECTQ DESIND
[CONS (OR (GLSTRVALB IND (CADR DES)
(QUOTE (CAR *GL*)))
(GLSTRVALB IND (CADDR DES)
(QUOTE (CDR *GL*]
((LIST LISTOBJECT)
(GLLISTSTRFN IND DES DESLIST))
((PROPLIST ALIST RECORD ATOMOBJECT OBJECT)
(GLPROPSTRFN IND DES DESLIST NIL))
(ATOM (GLATOMSTRFN IND DES DESLIST))
(TRANSPARENT (GLSTRFN IND (CADR DES)
DESLIST))
(COND
((AND (SETQ TMP (ASSOC DESIND
GLUSERSTRNAMES))
(CADR TMP))
(APPLY* (CADR TMP)
IND DES DESLIST))
([OR (NULL (CDR DES))
(ATOM (CADR DES))
(AND (LISTP (CADR DES))
(GL-A-AN? (CAADR DES]
NIL)
(T (GLSTRFN IND (CADR DES)
DESLIST])
(GLSTRPROP
[LAMBDA (STR GLPROP PROP ARGS) (* GSN "16-MAR-83 10:49"
)
(* If STR is a structured object, i.e., either a
declared GLISP structure or a Class of Units, get
the property PROP from the GLISP class of properties
GLPROP.)
(PROG (STRB UNITREC GLPROPS PROPL TMP SUPERS)
(OR (ATOM (SETQ STRB (GLXTRTYPE STR)))
(RETURN))
[COND
((SETQ GLPROPS (GETPROP STRB (QUOTE GLSTRUCTURE)))
(GLNOTICETYPE STRB)
(COND
((AND (SETQ PROPL (LISTGET (CDR GLPROPS)
GLPROP))
(SETQ TMP (GLSTRPROPB PROP PROPL ARGS)))
(RETURN TMP]
[SETQ SUPERS (AND GLPROPS (LISTGET (CDR GLPROPS)
(QUOTE SUPERS]
LP (COND
[SUPERS (COND
((SETQ TMP (GLSTRPROP (CAR SUPERS)
GLPROP PROP ARGS))
(RETURN TMP))
(T (SETQ SUPERS (CDR SUPERS))
(GO LP]
((AND (SETQ UNITREC (GLUNIT? STRB))
(SETQ TMP (APPLY* (CADDDR UNITREC)
STRB GLPROP PROP)))
(RETURN TMP])
(GLSTRPROPB
[LAMBDA (PROP PROPL ARGS) (* GSN "10-FEB-83 13:14"
)
(* See if the property PROP can be found within the
list of properties PROPL. If ARGS is specified and
ARGTYPES are specified for a property entry, ARGS
are required to match ARGTYPES.)
(PROG (PROPENT ARGTYPES LARGS)
LP (COND
((NULL PROPL)
(RETURN)))
(SETQ PROPENT (CAR PROPL))
(SETQ PROPL (CDR PROPL))
(COND
((NEQ (CAR PROPENT)
PROP)
(GO LP)))
(OR [AND ARGS (SETQ ARGTYPES (LISTGET (CDDR PROPENT)
(QUOTE ARGTYPES]
(RETURN PROPENT))
(SETQ LARGS ARGS)
LPB (COND
((AND (NULL LARGS)
(NULL ARGTYPES))
(RETURN PROPENT))
((OR (NULL LARGS)
(NULL ARGTYPES))
(GO LP))
((GLTYPEMATCH (CADAR LARGS)
(CAR ARGTYPES))
(SETQ LARGS (CDR LARGS))
(SETQ ARGTYPES (CDR ARGTYPES))
(GO LPB))
(T (GO LP])
(GLSTRVAL
[LAMBDA (OLDFN NEW) (* edited:
"11-JAN-82 14:58")
(* "GSN: "
"19-Mar-81 12:27")
(* GLSTRVAL is a subroutine of GLSTRFN.
Given an old partial retrieval function, in which
the item from which the retrieval is made is
specified by *GL*, and a new function to compute
*GL*, a composite function is made.)
(PROG NIL
(COND
[(CAR OLDFN)
(RPLACA OLDFN (SUBST NEW (QUOTE *GL*)
(CAR OLDFN]
(T (RPLACA OLDFN NEW)))
(RETURN OLDFN])
(GLSTRVALB
[LAMBDA (IND DES NEW) (* "GSN: "
"13-Aug-81 16:13")
(* "GSN: "
"19-Mar-81 12:28")
(* If the indicator IND can be found within the
description DES, make a composite retrieval function
using a copy of the function pattern NEW.)
(PROG (TMP)
(COND
[(SETQ TMP (GLSTRFN IND DES DESLIST))
(RETURN (GLSTRVAL TMP (COPY NEW]
(T (RETURN])
(GLSUPERS
[LAMBDA (CLASS) (* edited:
"11-NOV-82 14:02")
(* Get the list of
superclasses for CLASS.)
(PROG (TMP)
(RETURN (AND (SETQ TMP (GETPROP CLASS (QUOTE GLSTRUCTURE)))
(LISTGET (CDR TMP)
(QUOTE SUPERS])
(GLTRANSPARENTTYPES
[LAMBDA (STR) (* edited:
"14-DEC-81 10:51")
(* Return a list of all
transparent types
defined for STR)
(DECLARE (SPECVARS TTLIST))
(PROG (TTLIST)
[COND
((ATOM STR)
(SETQ STR (GLGETSTR STR]
(GLTRANSPB STR)
(RETURN (DREVERSE TTLIST])
(GLTRANSPB
[LAMBDA (STR) (* GSN "31-JUL-83 21:32"
) (* Look for TRANSPARENT
substructures for
GLTRANSPARENTTYPES.)
(COND
((NLISTP STR))
((EQ (CAR STR)
(QUOTE TRANSPARENT))
(SETQ TTLIST (CONS STR TTLIST)))
[(MEMB (CAR STR)
(QUOTE (LISTOF]
(T (MAPC (CDR STR)
(FUNCTION GLTRANSPB])
(GLTYPEMATCH
[LAMBDA (SUBTYPE TYPE) (* GSN "10-FEB-83 13:31"
)
(* See if the type SUBTYPE matches the type TYPE,
either directly or because TYPE is a SUPER of
SUBTYPE.)
(PROG NIL
(SETQ SUBTYPE (GLXTRTYPE SUBTYPE))
(RETURN (OR (NULL SUBTYPE)
(NULL TYPE)
(EQ TYPE (QUOTE ANYTHING))
(EQUAL SUBTYPE TYPE)
(SOME (GLSUPERS SUBTYPE)
(FUNCTION (LAMBDA (Y)
(GLTYPEMATCH Y TYPE])
(GLUNIT?
[LAMBDA (STR) (* edited:
"27-MAY-82 13:08")
(* GLUNIT? tests a given structure to see if it is a
unit of one of the unit packages on GLUNITPKGS.
If so, the value is the unit package record for the
unit package which matched.)
(PROG (UPS)
(SETQ UPS GLUNITPKGS)
LP [COND
((NULL UPS)
(RETURN))
((APPLY* (CAAR UPS)
STR)
(RETURN (CAR UPS]
(SETQ UPS (CDR UPS))
(GO LP])
(GLUNITOP
[LAMBDA (LHS RHS OP) (* edited:
"27-MAY-82 13:08")
(* GLUNITOP calls a function to generate code for an
operation on a unit in a units package.
UNITREC is the unit record for the units package,
LHS and RHS the code for the left-hand side and
right-hand side of the operation
(in general, the (QUOTE GET') code for each side),
and OP is the operation to be performed.)
(PROG (TMP LST UNITREC) (*
"See if the LHS code matches the GET function of a unit package.")
(SETQ LST GLUNITPKGS)
A (COND
((NULL LST)
(RETURN))
((NOT (MEMB (CAAR LHS)
(CADAR LST)))
(SETQ LST (CDR LST))
(GO A)))
(SETQ UNITREC (CAR LST))
[COND
((SETQ TMP (ASSOC OP (CADDR UNITREC)))
(RETURN (APPLY* (CDR TMP)
LHS RHS]
(RETURN])
(GLUNWRAPC
[LAMBDA (X BUSY) (* GSN "22-JUL-83 14:32"
) (* Unwrap and optimize
an expression if the
compiler is present.)
(COND
((GLISPCP)
(GLUNWRAP X BUSY))
(T X])
(GLUSERSTROP
[LAMBDA (LHS OP RHS) (* GSN "22-JUL-83 15:57"
)
(* Try to perform an operation on a user-defined
structure, which is LHS. The type of LHS is looked
up on GLUSERSTRNAMES, and if found, the appropriate
user function is called.)
(PROG (TMP DES TMPB LST UNITREC)
(SETQ DES (CADR LHS))
[COND
((NULL DES)
(GO B))
[(ATOM DES)
(COND
((NEQ (SETQ TMP (GLGETSTR DES))
DES)
(RETURN (GLUSERSTROP (LIST (CAR LHS)
TMP)
OP RHS)))
(T (GO B]
((NLISTP DES)
(GO B))
([AND (SETQ TMP (ASSOC (CAR DES)
GLUSERSTRNAMES))
(SETQ TMPB (ASSOC OP (CADDDR TMP]
(RETURN (APPLY* (CDR TMPB)
LHS RHS]
B (SETQ LST GLUSERSTRNAMES)
A (COND
((NULL LST)
(RETURN))
((NEQ (CAAR LHS)
(CADDAR LST))
(SETQ LST (CDR LST))
(GO A)))
(SETQ UNITREC (CAR LST))
[COND
((SETQ TMP (ASSOC OP (CADDDR UNITREC)))
(RETURN (APPLY* (CDR TMP)
LHS RHS]
(RETURN])
(GLXTRTYPE
[LAMBDA (TYPE) (* edited:
"26-JUL-82 14:03")
(* Extract an atomic type name from a type spec
which may be either <type> or
(A <type>).)
(COND
((ATOM TYPE)
TYPE)
((NLISTP TYPE)
NIL)
((AND (OR (GL-A-AN? (CAR TYPE))
(EQ (CAR TYPE)
(QUOTE TRANSPARENT)))
(CDR TYPE)
(ATOM (CADR TYPE)))
(CADR TYPE))
((MEMB (CAR TYPE)
GLTYPENAMES)
TYPE)
((ASSOC (CAR TYPE)
GLUSERSTRNAMES)
TYPE)
((AND (ATOM (CAR TYPE))
(CDR TYPE))
(GLXTRTYPE (CADR TYPE)))
(T (GLERROR (QUOTE GLXTRTYPE)
(LIST TYPE "is an illegal type specification."))
NIL])
(GLYESP
[LAMBDA (MSG) (* GSN "31-JUL-83 21:33"
)
(PROG (ANS)
LP (SELECTQ GLLISPDIALECT
(INTERLISP (PRIN1 MSG)
(PRIN1 "? "))
(PROGN (PRINC MSG)
(PRINC "? ")))
(SETQ ANS (READ))
(COND
((FMEMB ANS (QUOTE (YES Yes yes Y y)))
(RETURN T))
((FMEMB ANS (QUOTE (NO No no N n)))
(RETURN NIL)))
(GO LP])
(SEND
[NLAMBDA GLISPSENDARGS (* GSN " 9-FEB-83 16:46"
)
(GLSENDB (EVAL (CAR GLISPSENDARGS))
NIL
(CADR GLISPSENDARGS)
(QUOTE MSG)
(MAPCAR (CDDR GLISPSENDARGS)
(FUNCTION EVAL])
(SENDC
[NLAMBDA GLISPSENDARGS (* GSN " 9-FEB-83 16:48"
)
(GLSENDB (EVAL (CAR GLISPSENDARGS))
(CADR GLISPSENDARGS)
(CADDR GLISPSENDARGS)
(QUOTE MSG)
(MAPCAR (CDDDR GLISPSENDARGS)
(FUNCTION EVAL])
(SENDPROP
[NLAMBDA GLISPSENDPROPARGS (* GSN " 9-FEB-83 16:46"
)
(GLSENDB (EVAL (CAR GLISPSENDPROPARGS))
NIL
(CADR GLISPSENDPROPARGS)
(CADDR GLISPSENDPROPARGS)
(MAPCAR (CDDDR GLISPSENDPROPARGS)
(FUNCTION EVAL])
(SENDPROPC
[NLAMBDA GLISPSENDPROPARGS (* GSN " 9-FEB-83 16:48"
)
(GLSENDB (EVAL (CAR GLISPSENDPROPARGS))
(CADR GLISPSENDPROPARGS)
(CADDR GLISPSENDPROPARGS)
(CADDDR GLISPSENDPROPARGS)
(MAPCAR (CDDDDR GLISPSENDPROPARGS)
(FUNCTION EVAL])
)
(RPAQQ GLBASICTYPES (ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING))
(RPAQQ GLLISPDIALECT INTERLISP)
(RPAQQ GLSPECIALFNS (GLAMBDATRAN GLANALYZEGLISP GLAPPLY GLCOMPCOMS GLED
GLEDS GLERROR GLFIXCOMS GLGETD GLGETDB
GLIFSTRCHANGED GLINTERLISPTRANSFM
GLMAKEGLISPVERSION GLMAKEGLISPVERSIONS
GLP GLPRETTYPRINTCONST
GLPRETTYPRINTGLOBALS GLPRETTYPRINTSTRS)
)
(RPAQQ GLTYPENAMES (CONS LIST RECORD LISTOF ALIST ATOM OBJECT
LISTOBJECT ATOMOBJECT))
(RPAQ GLOBJECTNAMES NIL)
(PUTPROPS GLTYPE GLSTRUCTURE [[ATOM
(PROPLIST [GLSTRUCTURE (CONS (STRDES ANYTHING)
(PROPLIST
(PROP (LISTOF GLPROPENTRY))
(ADJ (LISTOF GLPROPENTRY))
(ISA (LISTOF GLPROPENTRY))
(MSG (LISTOF GLPROPENTRY))
(DOC ANYTHING)
(SUPERS (LISTOF GLTYPE]
(GLISPATOMNUMBER INTEGER)
[GLPROPFNS (ALIST (STR (LISTOF GLPROPFNENTRY))
(PROP (LISTOF GLPROPFNENTRY))
(ADJ (LISTOF GLPROPFNENTRY))
(ISA (LISTOF GLPROPFNENTRY))
(MSG (LISTOF GLPROPFNENTRY]
(GLFNSUSEDIN (LISTOF GLFUNCTION]
PROP
((PROPS (PROP))
(ADJS (ADJ))
(ISAS (ISA))
(MSGS (MSG])
(PUTPROPS GLPROPENTRY GLSTRUCTURE [[CONS (NAME ATOM)
(CONS (CODE ANYTHING)
(PROPLIST (RESULT GLTYPE)
(OPEN BOOLEAN]
PROP
((SHORTVALUE (NAME])
(PUTPROPS GLPROPFNENTRY GLSTRUCTURE ((LIST (NAME ATOM)
(CODE ANYTHING)
(RESULT GLTYPE))))
(PUTPROPS GLFUNCTION GLSTRUCTURE [(ATOM (PROPLIST (GLORIGINALEXPR
ANYTHING)
(GLCOMPILED ANYTHING)
(GLRESULTTYPE
ANYTHING)
(GLARGUMENTTYPES
(LISTOF ANYTHING))
(GLTYPESUSED
(LISTOF GLTYPE])
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR 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)
)
(GLINIT)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA SENDPROPC SENDPROP SENDC SEND GLSENDPROPC GLSENDPROP
GLSENDC GLSEND GLISPOBJECTS GLISPGLOBALS
GLISPCONSTANTS GLERR GLDEFSYSSTRQ GLDEFSTRQ
GLDEFSTRNAMES GLADDTOOBJECTS AN A)
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (2839 77538 (A 2849 . 2960) (AN 2962 . 3074) (GL-A-AN? 3076 . 3291) (GLADDPROP 3293 .
3819) (GLADDTOOBJECT 3821 . 5048) (GLADDTOOBJECTS 5050 . 5303) (GLAINTERPRETER 5305 . 6303) (
GLANYCARCDR? 6305 . 7000) (GLAPPLY 7002 . 7106) (GLAQR 7108 . 7269) (GLAQRB 7271 . 10744) (GLAQRLISTOF
10746 . 11220) (GLAQRRD 11222 . 11379) (GLAQRSTR 11381 . 11763) (GLATMSTR? 11765 . 12586) (
GLATOMSTRFN 12588 . 13066) (GLCARCDRRESULTTYPE 13068 . 13572) (GLCARCDRRESULTTYPEB 13574 . 14749) (
GLCLASS 14751 . 15453) (GLCLASSMEMP 15455 . 15720) (GLCLASSP 15722 . 15953) (GLCLASSSEND 15955 . 16540
) (GLCOMPPROP 16542 . 17710) (GLCOMPPROPL 17712 . 20313) (GLDEFAULTVALUE 20315 . 20647) (
GLDEFFNRESULTTYPES 20649 . 21027) (GLDEFFNRESULTTYPEFNS 21029 . 21396) (GLDEFPROP 21398 . 22179) (
GLDEFSTR 22181 . 24280) (GLDEFSTRNAMES 24282 . 24588) (GLDEFSTRQ 24590 . 24933) (GLDEFSYSSTRQ 24935 .
25279) (GLDEFUNITPKG 25281 . 26207) (GLDELDEF 26209 . 26454) (GLDESCENDANTP 26456 . 26860) (GLDOEXPRC
26862 . 27244) (GLED 27246 . 27594) (GLEDS 27596 . 28021) (GLERR 28023 . 28198) (GLERROR 28200 . 29067
) (GLEXPENSIVE? 29069 . 29574) (GLGENCODE 29576 . 30040) (GLGETASSOC 30042 . 30385) (GLGETD 30387 .
30761) (GLGETDB 30763 . 31045) (GLGETDEF 31047 . 31347) (GLGETFROMUNIT 31349 . 31917) (GLGETPAIRS
31919 . 32659) (GLGETSTR 32661 . 33178) (GLGETSUPERS 33180 . 33444) (GLIFSTRCHANGED 33446 . 33706) (
GLINIT 33708 . 41339) (GLISPCONSTANTS 41341 . 42040) (GLISPCP 42042 . 42293) (GLISPGLOBALS 42295 .
42797) (GLISPOBJECTS 42799 . 43228) (GLLISTRESULTTYPEFN 43230 . 44290) (GLLISTSTRFN 44292 . 45166) (
GLMKATOM 45168 . 45767) (GLMKRECORD 45769 . 46344) (GLMKSTR 46346 . 50139) (GLMKVAR 50141 . 50464) (
GLNOTICETYPE 50466 . 50783) (GLNTHRESULTTYPEFN 50785 . 51341) (GLOKSTR? 51343 . 53082) (GLP 53084 .
53529) (GLPROPSTRFN 53531 . 55332) (GLPUTARITH 55334 . 56944) (GLPUTFN 56946 . 59989) (GLRESULTTYPE
59991 . 61388) (GLSEND 61390 . 61626) (GLSENDB 61628 . 63934) (GLSENDC 63936 . 64192) (GLSENDPROP
64194 . 64461) (GLSENDPROPC 64463 . 64755) (GLSTRCHANGED 64757 . 65493) (GLSTRFN 65495 . 67894) (
GLSTRPROP 67896 . 68906) (GLSTRPROPB 68908 . 69875) (GLSTRVAL 69877 . 70472) (GLSTRVALB 70474 . 70951)
(GLSUPERS 70953 . 71280) (GLTRANSPARENTTYPES 71282 . 71686) (GLTRANSPB 71688 . 72107) (GLTYPEMATCH
72109 . 72591) (GLUNIT? 72593 . 73101) (GLUNITOP 73103 . 74012) (GLUNWRAPC 74014 . 74285) (GLUSERSTROP
74287 . 75383) (GLXTRTYPE 75385 . 76068) (GLYESP 76070 . 76485) (SEND 76487 . 76721) (SENDC 76723 .
76977) (SENDPROP 76979 . 77244) (SENDPROPC 77246 . 77536)))))
STOP
)))))
STOP