(FILECREATED " 4-Dec-83 17:17:15" <CS.NOVAK>GLISPB.LSP.4 81971
changes to: GLISPBCOMS GLPREDICATE GLREDUCEARITH GLUNWRAPMAP
previous date: "28-Aug-83 08:48:51" <CS.NOVAK>GLISPB.LSP.3)
(PRETTYCOMPRINT GLISPBCOMS)
(RPAQQ GLISPBCOMS [(* Copyright (c) |
1983 by Gordon S. Novak Jr.) |
(* This file, GLISPB, is one of three GLISP files. The others |
are GLISPA and GLISPR.) |
(FNS GLLISPADJ GLLISPISA GLMAKEFORLOOP GLMAKEGLISPVERSION |
GLMAKEGLISPVERSIONS GLMAKESTR GLMAKEVTYPE GLMATCH GLMATCHL
GLMINUSFN GLMKLABEL GLMKVTYPE GLNCONCFN GLNEQUALFN |
GLNOTESOURCETYPE GLNOTFN GLOCCURS GLOPERAND GLOPERATOR? |
GLORFN GLOUTPUTFILTER GLPARSEXPR GLPARSFLD GLPARSNFLD |
GLPLURAL GLPOPFN GLPREC GLPREDICATE GLPRETTYPRINTCONST |
GLPRETTYPRINTGLOBALS GLPRETTYPRINTSTRS GLPROGN GLPURE |
GLPUSHEXPR GLPUSHFN GLPUTPROPS GLPUTUPFN GLREDUCE |
GLREDUCEARITH GLREDUCEOP GLREMOVEFN GLRESGLOBAL |
GLSAVEFNTYPES GLSEPCLR GLSEPINIT GLSEPNXT GLSKIPCOMMENTS |
GLSUBATOM GLSUBLIS GLSUBSTTYPE GLTHE GLTHESPECS |
GLTRANSPROG GLUNCOMPILE GLUNSAVEDEF GLUNWRAP GLUNWRAPCOND |
GLUNWRAPINTERSECT GLUNWRAPLOG GLUNWRAPMAP GLUNWRAPPROG |
GLUNWRAPSELECTQ GLUPDATEVARTYPE GLUSERFN GLUSERFNB |
GLUSERGETARGS GLVALUE GLVARTYPE GLXTRFN GLXTRTYPEB |
GLXTRTYPEC) |
(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) |
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS |
(ADDVARS (NLAMA) |
(NLAML) |
(LAMA])
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Copyright (c)
1983 by Gordon S. Novak Jr.) ]
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* This file, GLISPB, is one of three GLISP files. The others are
GLISPA and GLISPR.) ]
(DEFINEQ
(GLLISPADJ
[LAMBDA (ADJ) (* GSN " 4-MAR-83 13:53"
)
(* Test the word ADJ to see if it is a LISP
adjective. If so, return the CONS of the name of the
function to test it and the type of the result.)
(PROG (TMP)
(RETURN (AND [SETQ TMP (FASSOC (U-CASE ADJ)
(QUOTE ((ATOMIC ATOM ATOM)
(NULL NULL NIL)
(NIL NULL NIL)
(INTEGER FIXP INTEGER)
(REAL FLOATP REAL)
(BOUND BOUNDP ATOM)
(ZERO ZEROP NUMBER)
(NUMERIC NUMBERP
NUMBER)
(NEGATIVE MINUSP
NUMBER)
(MINUS MINUSP NUMBER]
(CDR TMP])
(GLLISPISA
[LAMBDA (ISAWORD) (* GSN " 4-MAR-83 13:54"
)
(* Test to see if ISAWORD is a LISP ISA word.
If so, return the CONS of the name of the function
to test for it and the type of the result if true.)
(PROG (TMP)
(COND
([SETQ TMP (FASSOC (U-CASE ISAWORD)
(QUOTE ((ATOM ATOM ATOM)
(LIST LISTP (LISTOF ANYTHING))
(NUMBER NUMBERP NUMBER)
(INTEGER FIXP INTEGER)
(SYMBOL LITATOM ATOM)
(ARRAY ARRAYP ARRAY)
(STRING STRINGP STRING)
(BIGNUM BIGP BIGNUM)
(LITATOM LITATOM ATOM]
(RETURN (CDR TMP])
(GLMAKEFORLOOP
[LAMBDA (LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE)
(* edited:
"24-AUG-82 17:36")
(* edited:
"21-Apr-81 11:25")
(* Compile code for a
FOR loop.)
(COND
((NULL COLLECTCODE)
(LIST
[GLGENCODE
(LIST (QUOTE MAPC)
(CAR DOMAIN)
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
(LIST LOOPVAR)
(COND
(LOOPCOND (LIST (QUOTE COND)
(CONS (CAR LOOPCOND)
LOOPCONTENTS)))
((NULL (CDR LOOPCONTENTS))
(CAR LOOPCONTENTS))
(T (CONS (QUOTE PROGN)
LOOPCONTENTS]
NIL))
(T
(LIST
[COND
[LOOPCOND
(GLGENCODE
(LIST (QUOTE MAPCONC)
(CAR DOMAIN)
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
(LIST LOOPVAR)
(LIST (QUOTE AND)
(CAR LOOPCOND)
(LIST (QUOTE CONS)
(CAR COLLECTCODE)
NIL]
[(AND (LISTP (CAR COLLECTCODE))
(ATOM (CAAR COLLECTCODE))
(CDAR COLLECTCODE)
(EQ (CADAR COLLECTCODE)
LOOPVAR)
(NULL (CDDAR COLLECTCODE)))
(GLGENCODE (LIST (QUOTE MAPCAR)
(CAR DOMAIN)
(LIST (QUOTE FUNCTION)
(CAAR COLLECTCODE]
(T (GLGENCODE (LIST (QUOTE MAPCAR)
(CAR DOMAIN)
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
(LIST LOOPVAR)
(CAR COLLECTCODE]
(LIST (QUOTE LISTOF)
(CADR COLLECTCODE])
(GLMAKEGLISPVERSION
[LAMBDA (OUTPUTDIALECT) (* GSN "26-JUL-83 14:55"
) (* Make a version of
GLISP for another LISP
dialect.)
(PROG (FNS COMS FILE EXT)
(LOAD? (QUOTE LISPTRANS.LSP))
[SETQ EXT (CDR (ASSOC OUTPUTDIALECT (QUOTE ((FRANZLISP .
FRANZ)
(MACLISP . MAC)
(PSL . PSL)
(UCILISP . UCI]
(* Make a list of the
functions to be
translated.)
(SETQ FNS (APPEND [CDR (ASSOC OUTPUTDIALECT
(QUOTE ((FRANZLISP
GLFRANZLISPFN
GLFRANZLISPTRANSFM)
(MACLISP GLMACLISPFN
GLMACLISPTRANSFM)
(PSL GLPSLFN
GLPSLTRANSFM)
(UCILISP GLUCILISPFN
GLUCILISPTRANSFM]
(LDIFFERENCE (CDR (ASSOC (QUOTE FNS)
GLISPRCOMS))
GLSPECIALFNS)))
(SETQ COMS (COPY GLISPRCOMS))
(GLFIXCOMS COMS (QUOTE FNS)
FNS)
[GLFIXCOMS COMS (QUOTE P)
(LIST (LIST (QUOTE SETQ)
(QUOTE GLLISPDIALECT)
(LIST (QUOTE QUOTE)
OUTPUTDIALECT))
(QUOTE (GLINIT]
[GLFIXCOMS COMS (QUOTE VARS)
(LDIFFERENCE (CDR (ASSOC (QUOTE VARS)
GLISPRCOMS))
(QUOTE (GLLISPDIALECT GLSPECIALFNS]
(PUTPROP (QUOTE GLLISPDIALECT)
(QUOTE LISPTRANSEVALWHENCONST)
T)
(PUTPROP (QUOTE GLLISPDIALECT)
(QUOTE LISPTRANSCONSTANTVALUE)
OUTPUTDIALECT)
(RETURN
(LIST (LTRANCOMS OUTPUTDIALECT (MKATOM (CONCAT "GLISPR."
EXT))
COMS)
(LTRANCOMS OUTPUTDIALECT (MKATOM (CONCAT "GLISPA."
EXT))
(GLFIXCOMS
(COPY GLISPACOMS)
(QUOTE FNS)
(LDIFFERENCE (CDR (ASSOC (QUOTE FNS)
GLISPACOMS))
GLSPECIALFNS)))
(LTRANCOMS OUTPUTDIALECT (MKATOM (CONCAT "GLISPB."
EXT))
(GLFIXCOMS
(COPY GLISPBCOMS)
(QUOTE FNS)
(LDIFFERENCE (CDR (ASSOC (QUOTE FNS)
GLISPBCOMS))
GLSPECIALFNS])
(GLMAKEGLISPVERSIONS
[LAMBDA NIL (* GSN "25-JUL-83 14:41"
)
(MAPC (QUOTE (MACLISP FRANZLISP PSL UCILISP))
(FUNCTION (LAMBDA (X)
(TERPRI)
(PRINT (GLMAKEGLISPVERSION X))
(TERPRI])
(GLMAKESTR
[LAMBDA (TYPE EXPR) (* GSN " 1-MAR-83 11:36"
) (* Compile code to
create a structure in
response to a statement
"(A <structure> WITH <field> = <value> ...)")
(PROG (PAIRLIST STRDES)
(COND
((MEMB (CAR EXPR)
(QUOTE (WITH With with)))
(pop EXPR)))
[COND
((NULL (SETQ STRDES (GLGETSTR TYPE)))
(GLERROR (QUOTE GLMAKESTR)
(LIST "The type name" TYPE "is not defined."]
[COND
((EQ (CAR STRDES)
(QUOTE LISTOF))
(RETURN (LIST [CONS (QUOTE LIST)
(MAPCAR EXPR
(FUNCTION (LAMBDA (EXPR)
(GLDOEXPR NIL CONTEXT T]
TYPE]
(SETQ PAIRLIST (GLGETPAIRS EXPR))
(RETURN (LIST (GLBUILDSTR STRDES PAIRLIST (LIST TYPE))
TYPE])
(GLMAKEVTYPE
[LAMBDA (ORIGTYPE VLIST) (* GSN " 3-FEB-83 12:12"
) (* Make a virtual type
for a view of the
original type.)
(PROG (SUPER PL PNAME TMP VTYPE)
(SETQ SUPER (CADR VLIST))
(SETQ VLIST (CDDR VLIST))
[COND
((MEMB (CAR VLIST)
(QUOTE (with With WITH)))
(SETQ VLIST (CDR VLIST]
LP (COND
((NULL VLIST)
(GO OUT)))
(SETQ PNAME (CAR VLIST))
(SETQ VLIST (CDR VLIST))
[COND
((EQ (CAR VLIST)
(QUOTE =))
(SETQ VLIST (CDR VLIST]
(SETQ TMP NIL)
LPB (COND
([OR (NULL VLIST)
(EQ (CAR VLIST)
(QUOTE ,))
(AND (ATOM (CAR VLIST))
(CDR VLIST)
(EQ (CADR VLIST)
(QUOTE =]
(SETQ PL (CONS (LIST PNAME (DREVERSE TMP))
PL))
[COND
((AND VLIST (EQ (CAR VLIST)
(QUOTE ,)))
(SETQ VLIST (CDR VLIST]
(GO LP)))
(SETQ TMP (CONS (CAR VLIST)
TMP))
(SETQ VLIST (CDR VLIST))
(GO LPB)
OUT (SETQ VTYPE (GLMKVTYPE))
(PUTPROP VTYPE (QUOTE GLSTRUCTURE)
(LIST (LIST (QUOTE TRANSPARENT)
ORIGTYPE)
(QUOTE PROP)
PL
(QUOTE SUPERS)
(LIST SUPER)))
(RETURN VTYPE])
(GLMATCH
[LAMBDA (TNEW TINTO) (* GSN "25-FEB-83 16:08"
)
(* Test whether an item of type TNEW could be stored
into a slot of type TINTO.)
(PROG (TMP RES)
(RETURN (COND
([OR (EQ TNEW TINTO)
(NULL TINTO)
(EQ TINTO (QUOTE ANYTHING))
[AND (MEMB TNEW (QUOTE (INTEGER REAL NUMBER)))
(MEMB TINTO (QUOTE (NUMBER ATOM]
(AND (EQ TNEW (QUOTE ATOM))
(LISTP TINTO)
(EQ (CAR TINTO)
(QUOTE ATOM]
TNEW)
((AND (SETQ TMP (GLXTRTYPEC TNEW))
(SETQ RES (GLMATCH TMP TINTO)))
RES)
((AND (SETQ TMP (GLXTRTYPEC TINTO))
(SETQ RES (GLMATCH TNEW TMP)))
RES)
(T NIL])
(GLMATCHL
[LAMBDA (TELEM TLIST) (* GSN "25-FEB-83 16:03"
)
(* Test whether two types match as an element type
and a list type. The result is the resulting element
type.)
(PROG (TMP RES)
(RETURN (COND
((AND (LISTP TLIST)
(EQ (CAR TLIST)
(QUOTE LISTOF))
(GLMATCH TELEM (CADR TLIST)))
TELEM)
[(AND (SETQ TMP (GLXTRTYPEC TLIST))
(SETQ RES (GLMATCHL TELEM TMP]
(T NIL])
(GLMINUSFN
[LAMBDA (LHS) (* GSN "22-JUL-83 13:57"
) (* Construct the
negative of the argument
LHS.)
(OR (GLDOMSG LHS (QUOTE MINUS)
NIL)
(GLUSERSTROP LHS (QUOTE MINUS)
NIL)
(LIST [GLGENCODE (COND
((NUMBERP (CAR LHS))
(MINUS (CAR LHS)))
((EQ (GLXTRTYPE (CADR LHS))
(QUOTE INTEGER))
(LIST (QUOTE IMINUS)
(CAR LHS)))
(T (LIST (QUOTE MINUS)
(CAR LHS]
(CADR LHS])
(GLMKLABEL
[LAMBDA NIL (* edited:
"27-MAY-82 11:02")
(* Make a variable name
for GLCOMP functions.)
(PROG NIL
(SETQ GLNATOM (ADD1 GLNATOM))
(RETURN (PACK (APPEND (QUOTE (G L L A B E L))
(UNPACK GLNATOM])
(GLMKVTYPE
[LAMBDA NIL (* edited:
"18-NOV-82 11:58")
(* Make a virtual type
name for GLCOMP
functions.)
(GLMKATOM (QUOTE GLVIRTUALTYPE])
(GLNCONCFN
[LAMBDA (LHS RHS) (* GSN "25-JAN-83 16:47"
) (* edited:
" 2-Jun-81 14:18")
(* edited:
"21-Apr-81 11:26")
(* Produce a function to implement the ←+ operator.
Code is produced to append the right-hand side to
the left-hand side. Note: parts of the structure
provided are used multiple times.)
(PROG (LHSCODE LHSDES NCCODE TMP STR)
(SETQ LHSCODE (CAR LHS))
(SETQ LHSDES (GLXTRTYPE (CADR LHS)))
(COND
[(EQ LHSDES (QUOTE INTEGER))
(COND
((EQP (CAR RHS)
1)
(SETQ NCCODE (LIST (QUOTE ADD1)
LHSCODE)))
[(OR (FIXP (CAR RHS))
(EQ (CADR RHS)
(QUOTE INTEGER)))
(SETQ NCCODE (LIST (QUOTE IPLUS)
LHSCODE
(CAR RHS]
(T (SETQ NCCODE (LIST (QUOTE PLUS)
LHSCODE
(CAR RHS]
[(OR (EQ LHSDES (QUOTE NUMBER))
(EQ LHSDES (QUOTE REAL)))
(SETQ NCCODE (LIST (QUOTE PLUS)
LHSCODE
(CAR RHS]
[(EQ LHSDES (QUOTE BOOLEAN))
(SETQ NCCODE (LIST (QUOTE OR)
LHSCODE
(CAR RHS]
[(NULL LHSDES)
(SETQ NCCODE (LIST (QUOTE NCONC1)
LHSCODE
(CAR RHS)))
(COND
((AND (ATOM LHSCODE)
(CADR RHS))
(GLUPDATEVARTYPE LHSCODE (LIST (QUOTE LISTOF)
(CADR RHS]
[[AND (LISTP LHSDES)
(EQ (CAR LHSDES)
(QUOTE LISTOF))
(NOT (EQUAL LHSDES (CADR RHS]
(SETQ NCCODE (LIST (QUOTE NCONC1)
LHSCODE
(CAR RHS]
((SETQ TMP (GLUNITOP LHS RHS (QUOTE NCONC)))
(RETURN TMP))
((SETQ TMP (GLDOMSG LHS (QUOTE ←+)
(LIST RHS)))
(RETURN TMP))
((SETQ TMP (GLDOMSG LHS (QUOTE +)
(LIST RHS)))
(SETQ NCCODE (CAR TMP)))
[(AND (SETQ STR (GLGETSTR LHSDES))
(SETQ TMP (GLNCONCFN (LIST (CAR LHS)
STR)
RHS)))
(RETURN (LIST (CAR TMP)
(CADR LHS]
((SETQ TMP (GLUSERSTROP LHS (QUOTE ←+)
RHS))
(RETURN TMP))
((SETQ TMP (GLREDUCEARITH (QUOTE +)
LHS RHS))
(SETQ NCCODE (CAR TMP)))
(T (RETURN)))
(RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE)
LHSDES)
T])
(GLNEQUALFN
[LAMBDA (LHS RHS) (* edited:
"23-DEC-82 10:49")
(* edited:
" 6-Jan-81 16:11")
(* Produce code to test
the two sides for
inequality.)
(PROG (TMP)
(COND
((SETQ TMP (GLDOMSG LHS (QUOTE ~=)
(LIST RHS)))
(RETURN TMP))
((SETQ TMP (GLUSERSTROP LHS (QUOTE ~=)
RHS))
(RETURN TMP))
[(OR (GLATOMTYPEP (CADR LHS))
(GLATOMTYPEP (CADR RHS)))
(RETURN (LIST (GLGENCODE (LIST (QUOTE NEQ)
(CAR LHS)
(CAR RHS)))
(QUOTE BOOLEAN]
(T (RETURN (LIST [GLGENCODE (LIST (QUOTE NOT)
(CAR (GLEQUALFN LHS RHS]
(QUOTE BOOLEAN])
(GLNOTESOURCETYPE
[LAMBDA (SOURCE TYPE ADDISATYPE) (* GSN " 7-MAR-83 16:55"
)
(* If SOURCE represents a variable name, add the
TYPE of SOURCE to the CONTEXT.)
(PROG (TMP)
(RETURN (COND
(ADDISATYPE (COND
((ATOM (CAR SOURCE))
(GLADDSTR (CAR SOURCE)
NIL TYPE CONTEXT))
((AND (LISTP (CAR SOURCE))
(MEMB (CAAR SOURCE)
(QUOTE (SETQ PROG1)))
(ATOM (CADAR SOURCE)))
(GLADDSTR (CADAR SOURCE)
(COND
((SETQ TMP
(GLFINDVARINCTX
(CAR SOURCE)
CONTEXT))
(CADR TMP)))
TYPE CONTEXT])
(GLNOTFN
[LAMBDA (LHS) (* edited:
" 3-MAY-82 14:35")
(* Construct the NOT of
the argument LHS.)
(OR (GLDOMSG LHS (QUOTE ~)
NIL)
(GLUSERSTROP LHS (QUOTE ~)
NIL)
(LIST (GLBUILDNOT (CAR LHS))
(QUOTE BOOLEAN])
(GLOCCURS
[LAMBDA (X STR) (* edited:
" 3-JUN-82 11:02")
(* See if X occurs in
STR, using EQ.)
(COND
((EQ X STR)
T)
((NLISTP STR)
NIL)
(T (OR (GLOCCURS X (CAR STR))
(GLOCCURS X (CDR STR])
(GLOPERAND
[LAMBDA NIL (* edited:
"30-DEC-81 16:41")
(* "GSN: "
"17-Sep-81 14:00")
(* "GSN: "
" 9-Apr-81 12:12")
(* Get the next operand from the input list, EXPR
(global). The operand may be an atom
(possibly containing operators) or a list.)
(PROG NIL
(COND
((SETQ FIRST (GLSEPNXT))
(RETURN (GLPARSNFLD)))
((NULL EXPR)
(RETURN))
[(STRINGP (CAR EXPR))
(RETURN (LIST (pop EXPR)
(QUOTE STRING]
((ATOM (CAR EXPR))
(GLSEPINIT (pop EXPR))
(SETQ FIRST (GLSEPNXT))
(RETURN (GLPARSNFLD)))
(T (RETURN (GLPUSHEXPR (pop EXPR)
T CONTEXT T])
(GLOPERATOR?
[LAMBDA (ATM) (* GSN " 4-MAR-83 14:26"
) (* Test if an atom is a
GLISP operator)
(FMEMB ATM
(QUOTE (← := ←← + - * / > < >= <= ↑ ←+ +← ←- -← = ~= <> AND
And and OR Or or ←←+ ←←- ←+←])
(GLORFN
[LAMBDA (LHS RHS) (* edited:
"26-DEC-82 15:48")
(* "GSN: "
" 8-Jan-81 17:05")
(* OR operator)
(COND
((AND (LISTP (CADR LHS))
(EQ (CAADR LHS)
(QUOTE LISTOF))
(EQUAL (CADR LHS)
(CADR RHS)))
(LIST (LIST (QUOTE UNION)
(CAR LHS)
(CAR RHS))
(CADR LHS)))
((GLDOMSG LHS (QUOTE OR)
(LIST RHS)))
((GLUSERSTROP LHS (QUOTE OR)
RHS))
(T (LIST (LIST (QUOTE OR)
(CAR LHS)
(CAR RHS))
(COND
((EQUAL (GLXTRTYPE (CADR LHS))
(GLXTRTYPE (CADR RHS)))
(CADR LHS))
(T NIL])
(GLOUTPUTFILTER
[LAMBDA (PROPTYPE LST) (* GSN "10-FEB-83 16:13"
) (* Remove unwanted
system properties from
LST for making an output
file.)
(COND
[(MEMB PROPTYPE (QUOTE (PROP ADJ ISA MSG)))
(MAPCONC
LST
(FUNCTION (LAMBDA (L)
(COND
((LISTGET (CDDR L)
(QUOTE SPECIALIZATION))
NIL)
(T
(LIST
(CONS
(CAR L)
(CONS (CADR L)
(MAPCON (CDDR L)
[FUNCTION (LAMBDA (PAIR)
(COND
((MEMB (CAR PAIR)
(QUOTE (VTYPE)))
NIL)
(T (LIST (CAR PAIR)
(CADR PAIR]
(FUNCTION CDDR]
(T LST])
(GLPARSEXPR
[LAMBDA NIL (* edited:
"22-SEP-82 17:16")
(* edited:
"23-Jun-81 14:35")
(* edited:
"14-Apr-81 12:25")
(* edited:
" 9-Apr-81 11:32")
(* Subroutine of GLDOEXPR to parse a GLISP
expression containing field specifications and/or
operators. The global variable EXPR is used, and is
modified to reflect the amount of the expression
which has been parsed.)
(PROG (OPNDS OPERS FIRST LHSP RHSP) (* Get the initial part
of the expression, i.e.,
variable or field
specification.)
L (SETQ OPNDS (CONS (GLOPERAND)
OPNDS))
M [COND
[(NULL FIRST)
(COND
([OR (NULL EXPR)
(NOT (ATOM (CAR EXPR]
(GO B)))
(GLSEPINIT (CAR EXPR))
(COND
((GLOPERATOR? (SETQ FIRST (GLSEPNXT)))
(pop EXPR)
(GO A))
[(MEMB FIRST (QUOTE (IS Is is HAS Has has)))
(COND
((AND OPERS (IGREATERP (GLPREC (CAR OPERS))
5))
(GLREDUCE)
(SETQ FIRST NIL)
(GO M))
(T (SETQ OPNDS
(CONS (GLPREDICATE (pop OPNDS)
CONTEXT T
(AND (BOUNDP (QUOTE
ADDISATYPE))
ADDISATYPE))
OPNDS))
(SETQ FIRST NIL)
(GO M]
(T (GLSEPCLR)
(GO B]
((GLOPERATOR? FIRST)
(GO A))
(T (GLERROR (QUOTE GLPARSEXPR)
(LIST FIRST
"appears illegally or cannot be interpreted."]
(* FIRST now contains an
operator)
A (* While top operator <
top of stack in
precedence, reduce.)
(COND
([NOT (OR (NULL OPERS)
(ILESSP (SETQ LHSP (GLPREC (CAR OPERS)))
(SETQ RHSP (GLPREC FIRST)))
(AND (EQP LHSP RHSP)
(MEMB FIRST (QUOTE (← ↑ :=]
(GLREDUCE)
(GO A))) (* Push new operator
onto the operator
stack.)
(SETQ OPERS (CONS FIRST OPERS))
(GO L)
B (COND
(OPERS (GLREDUCE)
(GO B)))
(RETURN (CAR OPNDS])
(GLPARSFLD
[LAMBDA (PREV) (* edited:
"30-DEC-82 10:55")
(* "GSN: "
"23-Jun-81 15:28")
(* "GSN: "
"21-Apr-81 11:26")
(* Parse a field specification of the form
var:field:field... Var may be missing, and there may
be zero or more fields. The variable FIRST is used
globally; it contains the first atom of the group on
entry, and the next atom on exit.)
(PROG (FIELD TMP)
[COND
((NULL PREV)
(COND
[(EQ FIRST (QUOTE '))
(COND
[(SETQ TMP (GLSEPNXT))
(SETQ FIRST (GLSEPNXT))
(RETURN (LIST (KWOTE TMP)
(QUOTE ATOM]
[EXPR (SETQ FIRST NIL)
(SETQ TMP (pop EXPR))
(RETURN (LIST (KWOTE TMP)
(GLCONSTANTTYPE TMP]
(T (RETURN]
((MEMB FIRST (QUOTE (THE The the)))
(SETQ TMP (GLTHE NIL))
(SETQ FIRST NIL)
(RETURN TMP))
((NEQ FIRST (QUOTE :))
(SETQ PREV FIRST)
(SETQ FIRST (GLSEPNXT]
A (COND
[(EQ FIRST (QUOTE :))
(COND
((SETQ FIELD (GLSEPNXT))
(SETQ PREV (GLGETFIELD PREV FIELD CONTEXT))
(SETQ FIRST (GLSEPNXT))
(GO A]
(T (RETURN (COND
((EQ PREV (QUOTE *NIL*))
(LIST NIL NIL))
(T (GLIDNAME PREV T])
(GLPARSNFLD
[LAMBDA NIL (* edited:
"20-MAY-82 11:30")
(* "GSN: "
" 8-Jan-81 13:45")
(* Parse a field
specification which may
be preceded by a ~.)
(PROG (TMP UOP)
(COND
[(OR (EQ FIRST (QUOTE ~))
(EQ FIRST (QUOTE -)))
(SETQ UOP FIRST)
[COND
((SETQ FIRST (GLSEPNXT))
(SETQ TMP (GLPARSFLD NIL)))
((AND EXPR (ATOM (CAR EXPR)))
(GLSEPINIT (pop EXPR))
(SETQ FIRST (GLSEPNXT))
(SETQ TMP (GLPARSFLD NIL)))
((AND EXPR (LISTP (CAR EXPR)))
(SETQ TMP (GLPUSHEXPR (pop EXPR)
T CONTEXT T)))
(T (RETURN (LIST UOP NIL]
(RETURN (COND
((EQ UOP (QUOTE ~))
(GLNOTFN TMP))
(T (GLMINUSFN TMP]
(T (RETURN (GLPARSFLD NIL])
(GLPLURAL
[LAMBDA (WORD) (* edited:
"27-MAY-82 10:42")
(* Form the plural of a
given word.)
(PROG (TMP LST UCASE ENDING)
(COND
((SETQ TMP (GETPROP WORD (QUOTE PLURAL)))
(RETURN TMP)))
(SETQ LST (DREVERSE (UNPACK WORD)))
(SETQ UCASE (U-CASEP (CAR LST)))
[COND
[[AND (MEMB (CAR LST)
(QUOTE (Y y)))
(NOT (MEMB (CADR LST)
(QUOTE (A a E e O o U u]
(SETQ LST (CDR LST))
(SETQ ENDING (OR (AND UCASE (QUOTE (S E I)))
(QUOTE (s e i]
[(MEMB (CAR LST)
(QUOTE (S s X x)))
(SETQ ENDING (OR (AND UCASE (QUOTE (S E)))
(QUOTE (s e]
(T (SETQ ENDING (OR (AND UCASE (QUOTE (S)))
(QUOTE (s]
(RETURN (PACK (DREVERSE (APPEND ENDING LST])
(GLPOPFN
[LAMBDA (LHS RHS) (* edited:
"29-DEC-82 12:40")
(* "GSN: "
"20-Mar-81 14:44")
(* Produce a function to implement the -←
(pop) operator. Code is produced to remove one
element from the right-hand side and assign it to
the left-hand side.)
(PROG (RHSCODE RHSDES POPCODE GETCODE TMP STR)
(SETQ RHSCODE (CAR RHS))
(SETQ RHSDES (GLXTRTYPE (CADR RHS)))
[COND
((AND (LISTP RHSDES)
(EQ (CAR RHSDES)
(QUOTE LISTOF)))
(SETQ POPCODE (GLPUTFN RHS (LIST (LIST (QUOTE CDR)
RHSCODE)
RHSDES)
T))
(SETQ GETCODE (GLPUTFN LHS (LIST (LIST (QUOTE CAR)
(CAR RHS))
(CADR RHSDES))
NIL)))
((EQ RHSDES (QUOTE BOOLEAN))
(SETQ POPCODE (GLPUTFN RHS (QUOTE (NIL NIL))
NIL))
(SETQ GETCODE (GLPUTFN LHS RHS NIL)))
((SETQ TMP (GLDOMSG RHS (QUOTE -←)
(LIST LHS)))
(RETURN TMP))
([AND (SETQ STR (GLGETSTR RHSDES))
(SETQ TMP (GLPOPFN LHS (LIST (CAR RHS)
STR]
(RETURN TMP))
((SETQ TMP (GLUSERSTROP RHS (QUOTE -←)
LHS))
(RETURN TMP))
((OR (GLATOMTYPEP RHSDES)
(AND (NEQ RHSDES (QUOTE ANYTHING))
(MEMB (GLXTRTYPEB RHSDES)
GLBASICTYPES)))
(RETURN))
(T (* If all else fails,
assume a list.)
(SETQ POPCODE (GLPUTFN RHS (LIST (LIST (QUOTE CDR)
RHSCODE)
RHSDES)
T))
(SETQ GETCODE (GLPUTFN LHS (LIST (LIST (QUOTE CAR)
(CAR RHS))
(CADR RHSDES))
NIL]
(RETURN (LIST (LIST (QUOTE PROG1)
(CAR GETCODE)
(CAR POPCODE))
(CADR GETCODE])
(GLPREC
[LAMBDA (OP) (* edited:
"30-OCT-82 14:36")
(* edited:
"17-Sep-81 13:29")
(* edited:
"14-Aug-81 14:22")
(* edited:
"21-Apr-81 11:27")
(* Precedence numbers
for operators)
(PROG (TMP)
(COND
([SETQ TMP (FASSOC OP (QUOTE ((← . 1)
(:= . 1)
(←← . 1)
(←+ . 2)
(←←+ . 2)
(+← . 2)
(←+← . 2)
(←- . 2)
(←←- . 2)
(-← . 2)
(= . 5)
(~= . 5)
(<> . 5)
(AND . 4)
(And . 4)
(and . 4)
(OR . 3)
(Or . 3)
(or . 3)
(/ . 7)
(+ . 6)
(- . 6)
(> . 5)
(< . 5)
(>= . 5)
(<= . 5)
(↑ . 8]
(RETURN (CDR TMP)))
((EQ OP (QUOTE *))
(RETURN 7))
(T (RETURN 10])
(GLPREDICATE
[LAMBDA (SOURCE CONTEXT VERBFLG ADDISATYPE) (* "GSN: "
" 4-Dec-83 17:03")
(* Get a predicate specification from the EXPR
(referenced globally) and return code to test the
SOURCE for that predicate. VERBFLG is true if a verb
is expected as the top of EXPR.)
(DECLARE (SPECVARS NOTFLG ADDISATYPE))
(PROG (NEWPRED SETNAME PROPERTY TMP NOTFLG)
[COND
((NULL VERBFLG)
(SETQ NEWPRED (GLDOEXPR NIL CONTEXT T)))
((NULL SOURCE)
(GLERROR (QUOTE GLPREDICATE)
(LIST
"The object to be tested was not found. EXPR ="
EXPR)))
((MEMB (CAR EXPR)
(QUOTE (HAS Has has)))
(pop EXPR)
(COND
((MEMB (CAR EXPR)
(QUOTE (NO No no)))
(SETQ NOTFLG T)
(pop EXPR)))
(SETQ NEWPRED (GLDOEXPR NIL CONTEXT T)))
((MEMB (CAR EXPR)
(QUOTE (IS Is is ARE Are are)))
(pop EXPR)
(COND
((MEMB (CAR EXPR)
(QUOTE (NOT Not not)))
(SETQ NOTFLG T)
(pop EXPR)))
(COND
[(GL-A-AN? (CAR EXPR))
(pop EXPR)
(SETQ SETNAME (pop EXPR))
(* The condition is to
test whether SOURCE IS A
SETNAME.)
(COND
[(SETQ NEWPRED (GLADJ SOURCE SETNAME (QUOTE ISA]
((SETQ NEWPRED (GLADJ (LIST (CAR SOURCE)
SETNAME)
SETNAME
(QUOTE ISASELF)))
(GLNOTESOURCETYPE SOURCE SETNAME ADDISATYPE))
((SETQ TMP (GLLISPISA SETNAME))
(SETQ NEWPRED (LIST (GLGENCODE
(LIST (CAR TMP)
(CAR SOURCE)))
(QUOTE BOOLEAN)))
(GLNOTESOURCETYPE SOURCE (CADR TMP)
ADDISATYPE))
((GLCLASSP SETNAME)
(SETQ NEWPRED (LIST (LIST (QUOTE GLCLASSMEMP)
(CAR SOURCE)
(KWOTE SETNAME))
(QUOTE BOOLEAN)))
(GLNOTESOURCETYPE SOURCE SETNAME ADDISATYPE)) |
(T (GLERROR (QUOTE GLPREDICATE)
(LIST "IS A adjective" SETNAME
"could not be found for"
(CAR SOURCE)
"whose type is"
(CADR SOURCE)))
(SETQ NEWPRED (LIST (LIST (QUOTE GLERR)
(CAR SOURCE)
(QUOTE IS)
(QUOTE A)
SETNAME)
(QUOTE BOOLEAN]
(T (SETQ PROPERTY (CAR EXPR))
(* The condition to test
is whether SOURCE is
PROPERTY.)
(COND
((SETQ NEWPRED (GLADJ SOURCE PROPERTY
(QUOTE ADJ)))
(pop EXPR))
((SETQ TMP (GLLISPADJ PROPERTY))
(pop EXPR)
(SETQ NEWPRED (LIST (GLGENCODE
(LIST (CAR TMP)
(CAR SOURCE)))
(QUOTE BOOLEAN)))
(GLNOTESOURCETYPE SOURCE (CADR TMP)
ADDISATYPE))
(T (GLERROR (QUOTE GLPREDICATE)
(LIST "The adjective" PROPERTY
"could not be found for"
(CAR SOURCE)
"whose type is"
(CADR SOURCE)))
(pop EXPR)
(SETQ NEWPRED (LIST (LIST (QUOTE GLERR)
(CAR SOURCE)
(QUOTE IS)
PROPERTY)
(QUOTE BOOLEAN]
(RETURN (COND
(NOTFLG (LIST (GLBUILDNOT (CAR NEWPRED))
(QUOTE BOOLEAN)))
(T NEWPRED])
(GLPRETTYPRINTCONST
[LAMBDA (LST) (* edited:
"21-APR-82 16:06")
(PROG NIL
(TERPRI)
(TERPRI)
(PRIN1 (QUOTE %[))
(PRIN1 (QUOTE GLISPCONSTANTS))
[MAPC LST
(FUNCTION (LAMBDA (X)
(printout NIL T T "(" .FONT LAMBDAFONT X .FONT
DEFAULTFONT .SP 3 .PPV
(GETPROP X (QUOTE GLISPORIGCONSTVAL))
.SP 3 .PPV (GETPROP X (QUOTE
GLISPCONSTANTTYPE))
" )"]
(TERPRI)
(PRIN1 (QUOTE %]))
(TERPRI)
(TERPRI])
(GLPRETTYPRINTGLOBALS
[LAMBDA (LST) (* edited:
"23-APR-82 16:53")
(PROG NIL
(TERPRI)
(TERPRI)
(PRIN1 (QUOTE %[))
(PRIN1 (QUOTE GLISPGLOBALS))
[MAPC LST
(FUNCTION (LAMBDA (X)
(printout NIL T T "(" .FONT LAMBDAFONT X .FONT
DEFAULTFONT .SP 3 .PPV
(GETPROP X (QUOTE GLISPGLOBALVARTYPE))
" )"]
(TERPRI)
(PRIN1 (QUOTE %]))
(TERPRI)
(TERPRI])
(GLPRETTYPRINTSTRS
[LAMBDA (LST) (* GSN "10-FEB-83 16:14"
) (* Pretty-print GLISP
structure definitions
for file package
output.)
(PROG (TMP OBJ)
(TERPRI)
(TERPRI)
(PRIN1 (QUOTE %[))
(PRINT (QUOTE GLISPOBJECTS))
LP (COND
((NULL LST)
(TERPRI)
(PRIN1 (QUOTE %]))
(TERPRI)
(TERPRI)
(RETURN)))
(SETQ OBJ (pop LST))
(COND
((SETQ TMP (GETPROP OBJ (QUOTE GLSTRUCTURE)))
(printout NIL T T "(" .FONT LAMBDAFONT OBJ .FONT
DEFAULTFONT T T 3 .PPV (CAR TMP))
(MAP (CDR TMP)
[FUNCTION (LAMBDA (REST)
(printout NIL T T 3 (CAR REST)
10 .PPV (GLOUTPUTFILTER (CAR REST)
(CADR REST]
(FUNCTION CDDR))
(printout NIL " )")))
(GO LP])
(GLPROGN
[LAMBDA (EXPR CONTEXT) (* edited:
"25-MAY-82 16:09")
(* "GSN: "
"13-Aug-81 14:23")
(* "GSN: "
"21-Apr-81 11:28")
(* Compile an implicit
PROGN, that is, a list
of items.)
(PROG (RESULT TMP TYPE GLSEPATOM GLSEPPTR)
(SETQ GLSEPPTR 0)
A (COND
((NULL EXPR)
(RETURN (LIST (DREVERSE RESULT)
TYPE)))
((SETQ TMP (GLDOEXPR NIL CONTEXT VALBUSY))
(SETQ RESULT (CONS (CAR TMP)
RESULT))
(SETQ TYPE (CADR TMP))
(GO A))
(T (GLERROR (QUOTE GLPROGN)
(LIST
"Illegal item appears in implicit PROGN. EXPR ="
EXPR])
(GLPURE
[LAMBDA (X) (* edited:
" 4-JUN-82 13:37")
(* Test if the function X is a pure computation,
i.e., can be eliminated if the result is not used.)
(FMEMB X
(QUOTE (CAR CDR CXR CAAR CADR CDAR CDDR ADD1 SUB1 CADDR
CADDDR])
(GLPUSHEXPR
[LAMBDA (EXPR START CONTEXT VALBUSY) (* edited:
"25-MAY-82 16:10")
(* "GSN: "
"17-Sep-81 13:59")
(* "GSN: "
" 7-Apr-81 10:33")
(* This function serves to call GLDOEXPR with a new
expression, rebinding the global variable EXPR.)
(PROG (GLSEPATOM GLSEPPTR)
(SETQ GLSEPPTR 0)
(RETURN (GLDOEXPR START CONTEXT VALBUSY])
(GLPUSHFN
[LAMBDA (LHS RHS) (* GSN "25-JAN-83 16:48"
) (* edited:
" 2-Jun-81 14:19")
(* edited:
"21-Apr-81 11:28")
(* Produce a function to implement the +← operator.
Code is produced to push the right-hand side onto
the left-hand side. Note: parts of the structure
provided are used multiple times.)
(PROG (LHSCODE LHSDES NCCODE TMP STR)
(SETQ LHSCODE (CAR LHS))
(SETQ LHSDES (GLXTRTYPE (CADR LHS)))
(COND
[(EQ LHSDES (QUOTE INTEGER))
(COND
((EQP (CAR RHS)
1)
(SETQ NCCODE (LIST (QUOTE ADD1)
LHSCODE)))
[(OR (FIXP (CAR RHS))
(EQ (CADR RHS)
(QUOTE INTEGER)))
(SETQ NCCODE (LIST (QUOTE IPLUS)
LHSCODE
(CAR RHS]
(T (SETQ NCCODE (LIST (QUOTE PLUS)
LHSCODE
(CAR RHS]
[(OR (EQ LHSDES (QUOTE NUMBER))
(EQ LHSDES (QUOTE REAL)))
(SETQ NCCODE (LIST (QUOTE PLUS)
LHSCODE
(CAR RHS]
[(EQ LHSDES (QUOTE BOOLEAN))
(SETQ NCCODE (LIST (QUOTE OR)
LHSCODE
(CAR RHS]
[(NULL LHSDES)
(SETQ NCCODE (LIST (QUOTE CONS)
(CAR RHS)
LHSCODE))
(COND
((AND (ATOM LHSCODE)
(CADR RHS))
(GLUPDATEVARTYPE LHSCODE (LIST (QUOTE LISTOF)
(CADR RHS]
([AND (LISTP LHSDES)
(MEMB (CAR LHSDES)
(QUOTE (LIST CONS LISTOF]
(SETQ NCCODE (LIST (QUOTE CONS)
(CAR RHS)
LHSCODE)))
((SETQ TMP (GLUNITOP LHS RHS (QUOTE PUSH)))
(RETURN TMP))
((SETQ TMP (GLDOMSG LHS (QUOTE +←)
(LIST RHS)))
(RETURN TMP))
((SETQ TMP (GLDOMSG LHS (QUOTE +)
(LIST RHS)))
(SETQ NCCODE (CAR TMP)))
[(AND (SETQ STR (GLGETSTR LHSDES))
(SETQ TMP (GLPUSHFN (LIST (CAR LHS)
STR)
RHS)))
(RETURN (LIST (CAR TMP)
(CADR LHS]
((SETQ TMP (GLUSERSTROP LHS (QUOTE +←)
RHS))
(RETURN TMP))
((SETQ TMP (GLREDUCEARITH (QUOTE +)
RHS LHS))
(SETQ NCCODE (CAR TMP)))
(T (RETURN)))
(RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE)
LHSDES)
T])
(GLPUTPROPS
[LAMBDA (PROPLIS PREVLST) (* edited:
"27-MAY-82 13:07")
(* This function appends PUTPROP calls to the list
PROGG (global) so that ATOMNAME has its property
list built.)
(PROG (TMP TMPCODE)
A (COND
((NULL PROPLIS)
(RETURN)))
(SETQ TMP (pop PROPLIS))
[COND
((SETQ TMPCODE (GLBUILDSTR TMP PAIRLIST PREVLST))
(NCONC1 PROGG (GLGENCODE (LIST (QUOTE PUTPROP)
(QUOTE ATOMNAME)
(KWOTE (CAR TMP))
TMPCODE]
(GO A])
(GLPUTUPFN
[LAMBDA (OP LHS RHS) (* edited:
"26-JAN-82 10:29")
(* This function implements the ←← operator, which
is interpreted as assignment to the source of a
variable (usually "self") outside an open-compiled
function. Any other use of ←← is illegal.)
(PROG (TMP TMPOP)
(OR [SETQ TMPOP (ASSOC OP (QUOTE ((←← . ←)
(←←+ . ←+)
(←←- . ←-)
(←+← . +←]
(ERROR (LIST (QUOTE GLPUTUPFN)
OP)
" Illegal operator."))
(COND
((AND (ATOM (CAR LHS))
(BOUNDP (QUOTE GLPROGLST))
(SETQ TMP (ASSOC (CAR LHS)
GLPROGLST)))
(RETURN (GLREDUCEOP (CDR TMPOP)
(LIST (CADR TMP)
(CADR LHS))
RHS)))
((AND (LISTP (CAR LHS))
(EQ (CAAR LHS)
(QUOTE PROG1))
(ATOM (CADAR LHS)))
(RETURN (GLREDUCEOP (CDR TMPOP)
(LIST (CADAR LHS)
(CADR LHS))
RHS)))
(T (RETURN (GLERROR (QUOTE GLPUTUPFN)
(LIST
"A self-assignment ←← operator is used improperly. LHS ="
LHS])
(GLREDUCE
[LAMBDA NIL (* edited:
"30-OCT-82 14:38")
(* edited:
"14-Aug-81 12:25")
(* edited:
"21-Apr-81 11:28")
(* Reduce the operator on OPERS and the operands on
OPNDS (in GLPARSEXPR) and put the result back on
OPNDS)
(PROG (RHS OPER)
(SETQ RHS (pop OPNDS))
(SETQ OPNDS
(CONS (COND
((MEMB (SETQ OPER (pop OPERS))
(QUOTE (← := ←+ +← ←- -← = ~= <> AND And and
OR Or or ←←+ ←← ←+← ←←-)))
(GLREDUCEOP OPER (pop OPNDS)
RHS))
((FMEMB OPER
(QUOTE (+ - * / > < >= <= ↑)))
(GLREDUCEARITH OPER (pop OPNDS)
RHS))
((EQ OPER (QUOTE MINUS))
(GLMINUSFN RHS))
((EQ OPER (QUOTE ~))
(GLNOTFN RHS))
(T (LIST (GLGENCODE (LIST OPER (CAR (pop OPNDS))
(CAR RHS)))
NIL)))
OPNDS])
(GLREDUCEARITH
[LAMBDA (OP LHS RHS) (* "GSN: "
" 4-Dec-83 17:06")
(* edited:
"14-Aug-81 12:38")
(*
"Reduce an arithmetic operator in an expression.")
(PROG (TMP OPLIST IOPLIST PREDLIST NUMBERTYPES LHSTP RHSTP)
[SETQ OPLIST (QUOTE ((+ . PLUS)
(- . DIFFERENCE)
(* . TIMES)
(/ . QUOTIENT)
(> . GREATERP)
(< . LESSP)
(>= . GEQ)
(<= . LEQ)
(↑ . EXPT]
[SETQ IOPLIST (QUOTE ((+ . IPLUS)
(- . IDIFFERENCE)
(* . ITIMES)
(/ . IQUOTIENT)
(> . IGREATERP)
(< . ILESSP)
(>= . IGEQ)
(<= . ILEQ]
(SETQ PREDLIST
(QUOTE (GREATERP LESSP GEQ LEQ IGREATERP ILESSP IGEQ ILEQ)))
(SETQ NUMBERTYPES (QUOTE (INTEGER REAL NUMBER)))
(SETQ LHSTP (GLXTRTYPE (CADR LHS)))
(SETQ RHSTP (GLXTRTYPE (CADR RHS)))
[COND
([OR (AND (EQ LHSTP (QUOTE INTEGER))
(EQ RHSTP (QUOTE INTEGER))
(SETQ TMP (FASSOC OP IOPLIST)))
(AND (MEMB LHSTP NUMBERTYPES)
(MEMB RHSTP NUMBERTYPES)
(SETQ TMP (FASSOC OP OPLIST]
(RETURN
(LIST [COND
[(AND (NUMBERP (CAR LHS))
(NUMBERP (CAR RHS)))
(EVAL (GLGENCODE (LIST (CDR TMP)
(CAR LHS)
(CAR RHS]
(T (GLGENCODE (COND
((AND (EQ (CDR TMP)
(QUOTE IPLUS))
(EQP (CAR RHS)
1))
(LIST (QUOTE ADD1)
(CAR LHS)))
((AND (EQ (CDR TMP)
(QUOTE IDIFFERENCE))
(EQP (CAR RHS)
1))
(LIST (QUOTE SUB1)
(CAR LHS)))
(T (LIST (CDR TMP)
(CAR LHS)
(CAR RHS]
(COND
((MEMB (CDR TMP)
PREDLIST)
(QUOTE BOOLEAN))
((OR (EQ LHSTP (QUOTE INTEGER))
(EQ RHSTP (QUOTE REAL)))
RHSTP)
(T LHSTP]
(COND
[(AND (EQ LHSTP (QUOTE STRING)) |
(EQ RHSTP (QUOTE STRING))) |
(COND |
[[SETQ TMP (FASSOC OP (QUOTE ((+ CONCAT STRING) |
(> GLSTRGREATERP BOOLEAN)
(>= GLSTRGEP BOOLEAN) |
(< GLSTRLESSP BOOLEAN) |
(<= ALPHORDER BOOLEAN] |
(RETURN (LIST (GLGENCODE (LIST (CADR TMP) |
(CAR LHS) |
(CAR RHS))) |
(CADDR TMP] |
(T (RETURN (GLERROR (QUOTE GLREDUCEARITH) |
(LIST OP |
"is an illegal operation for strings."] |
[(EQ LHSTP (QUOTE BOOLEAN))
(COND
[(NEQ RHSTP (QUOTE BOOLEAN))
(RETURN (GLERROR (QUOTE GLREDUCEARITH)
(LIST
"Operation on Boolean and non-Boolean"]
[(MEMB OP (QUOTE (+ * -)))
(RETURN
(LIST
(GLGENCODE
(SELECTQ OP
(+ (LIST (QUOTE OR)
(CAR LHS)
(CAR RHS)))
(* (LIST (QUOTE AND)
(CAR LHS) (CAR RHS)))
[- (LIST (QUOTE AND)
(CAR LHS)
(LIST (QUOTE NOT)
(CAR RHS]
NIL))
(QUOTE BOOLEAN]
(T (RETURN (GLERROR (QUOTE GLREDUCEARITH)
(LIST OP
"is an illegal operation for Booleans."]
[(AND (LISTP LHSTP)
(EQ (CAR LHSTP)
(QUOTE LISTOF)))
(COND
[(AND (LISTP RHSTP)
(EQ (CAR RHSTP)
(QUOTE LISTOF)))
[COND
((NOT (EQUAL (CADR LHSTP)
(CADR RHSTP)))
(RETURN (GLERROR (QUOTE GLREDUCEARITH)
(LIST
"Operations on lists of different types"
(CADR LHSTP)
(CADR RHSTP]
(COND
[[SETQ TMP (FASSOC OP (QUOTE ((+ UNION)
(- LDIFFERENCE)
(* INTERSECTION)]
(RETURN (LIST (GLGENCODE (LIST (CADR TMP)
(CAR LHS)
(CAR RHS)))
(CADR LHS]
(T (RETURN (GLERROR (QUOTE GLREDUCEARITH)
(LIST "Illegal operation" OP
"on lists."]
[[AND (GLMATCH RHSTP (CADR LHSTP))
(FMEMB OP (QUOTE (+ - >=]
(RETURN
(LIST (GLGENCODE (LIST [COND
((EQ OP (QUOTE +))
(QUOTE CONS))
((EQ OP (QUOTE -))
(QUOTE REMOVE))
((EQ OP (QUOTE >=))
(COND
((GLATOMTYPEP RHSTP)
(QUOTE MEMB))
(T (QUOTE MEMBER]
(CAR RHS)
(CAR LHS)))
(CADR LHS]
(T (RETURN (GLERROR (QUOTE GLREDUCEARITH)
(LIST "Illegal operation on list."]
[(AND (FMEMB OP (QUOTE (+ <=)))
(GLMATCHL LHSTP RHSTP))
(RETURN (COND
((EQ OP (QUOTE +))
(LIST (GLGENCODE (LIST (QUOTE CONS)
(CAR LHS)
(CAR RHS)))
(CADR RHS)))
((EQ OP (QUOTE <=))
(LIST (GLGENCODE
(LIST (COND
((GLATOMTYPEP LHSTP)
(QUOTE MEMB))
(T (QUOTE MEMBER)))
(CAR LHS)
(CAR RHS)))
(QUOTE BOOLEAN]
[(AND (FMEMB OP (QUOTE (+ - >=)))
(SETQ TMP (GLMATCHL LHSTP RHSTP)))
(RETURN (GLREDUCEARITH (LIST (CAR LHS)
(LIST (QUOTE LISTOF)
TMP))
OP
(LIST (CAR RHS)
TMP]
((SETQ TMP (GLDOMSG LHS OP (LIST RHS)))
(RETURN TMP))
((SETQ TMP (GLUSERSTROP LHS OP RHS))
(RETURN TMP))
((SETQ TMP (GLXTRTYPEC LHSTP))
[SETQ TMP (GLREDUCEARITH OP (LIST (CAR LHS)
TMP)
(LIST (CAR RHS)
(OR (GLXTRTYPEC RHSTP)
RHSTP]
(RETURN (LIST (CAR TMP)
LHSTP)))
[(SETQ TMP (FASSOC OP OPLIST))
(AND LHSTP RHSTP (GLERROR (QUOTE GLREDUCEARITH)
(LIST
"Warning: Arithmetic operation on non-numeric arguments of types:"
LHSTP RHSTP)))
(RETURN (LIST (GLGENCODE (LIST (CDR TMP)
(CAR LHS)
(CAR RHS)))
(COND
((MEMB (CDR TMP)
PREDLIST)
(QUOTE BOOLEAN))
(T (QUOTE NUMBER]
(T (ERROR (LIST (QUOTE GLREDUCEARITH)
OP LHS RHS])
(GLREDUCEOP
[LAMBDA (OP LHS RHS) (* edited:
"29-DEC-82 12:20")
(* Reduce the operator
OP with operands LHS and
RHS.)
(PROG (TMP RESULT)
(COND
((FMEMB OP (QUOTE (← :=)))
(RETURN (GLPUTFN LHS RHS NIL)))
[[SETQ TMP (FASSOC OP (QUOTE ((←+ . GLNCONCFN)
(+← . GLPUSHFN)
(←- . GLREMOVEFN)
(-← . GLPOPFN)
(= . GLEQUALFN)
(~= . GLNEQUALFN)
(<> . GLNEQUALFN)
(AND . GLANDFN)
(And . GLANDFN)
(and . GLANDFN)
(OR . GLORFN)
(Or . GLORFN)
(or . GLORFN]
(COND
((SETQ RESULT (APPLY* (CDR TMP)
LHS RHS))
(RETURN RESULT))
(T (GLERROR (QUOTE GLREDUCEOP)
(LIST "The operator" OP
"could not be interpreted for arguments"
LHS "and" RHS]
((MEMB OP (QUOTE (←← ←←+ ←←- ←+←)))
(RETURN (GLPUTUPFN OP LHS RHS)))
(T (ERROR (LIST (QUOTE GLREDUCEOP)
OP LHS RHS])
(GLREMOVEFN
[LAMBDA (LHS RHS) (* GSN "25-JAN-83 16:50"
) (* edited:
" 2-Jun-81 14:20")
(* edited:
"21-Apr-81 11:29")
(* Produce a function to implement the ←- operator.
Code is produced to remove the right-hand side from
the left-hand side. Note: parts of the structure
provided are used multiple times.)
(PROG (LHSCODE LHSDES NCCODE TMP STR)
(SETQ LHSCODE (CAR LHS))
(SETQ LHSDES (GLXTRTYPE (CADR LHS)))
(COND
[(EQ LHSDES (QUOTE INTEGER))
(COND
((EQP (CAR RHS)
1)
(SETQ NCCODE (LIST (QUOTE SUB1)
LHSCODE)))
(T (SETQ NCCODE (LIST (QUOTE IDIFFERENCE)
LHSCODE
(CAR RHS]
[(OR (EQ LHSDES (QUOTE NUMBER))
(EQ LHSDES (QUOTE REAL)))
(SETQ NCCODE (LIST (QUOTE DIFFERENCE)
LHSCODE
(CAR RHS]
[(EQ LHSDES (QUOTE BOOLEAN))
(SETQ NCCODE (LIST (QUOTE AND)
LHSCODE
(LIST (QUOTE NOT)
(CAR RHS]
([OR (NULL LHSDES)
(AND (LISTP LHSDES)
(EQ (CAR LHSDES)
(QUOTE LISTOF]
(SETQ NCCODE (LIST (QUOTE REMOVE)
(CAR RHS)
LHSCODE)))
((SETQ TMP (GLUNITOP LHS RHS (QUOTE REMOVE)))
(RETURN TMP))
((SETQ TMP (GLDOMSG LHS (QUOTE ←-)
(LIST RHS)))
(RETURN TMP))
((SETQ TMP (GLDOMSG LHS (QUOTE -)
(LIST RHS)))
(SETQ NCCODE (CAR TMP)))
[(AND (SETQ STR (GLGETSTR LHSDES))
(SETQ TMP (GLREMOVEFN (LIST (CAR LHS)
STR)
RHS)))
(RETURN (LIST (CAR TMP)
(CADR LHS]
((SETQ TMP (GLUSERSTROP LHS (QUOTE ←-)
RHS))
(RETURN TMP))
(T (RETURN)))
(RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE)
LHSDES)
T])
(GLRESGLOBAL
[LAMBDA NIL (* GSN "26-JAN-83 13:41"
)
(* Get GLOBAL and RESULT declarations for the GLISP
compiler. The property GLRESULTTYPE is the RESULT
declaration, if specified; GLGLOBALS is a list of
global variables referenced and their types.)
(COND
((LISTP (CAR GLEXPR))
(COND
[(MEMB (CAAR GLEXPR)
(QUOTE (RESULT Result result)))
(COND
((AND (GLOKSTR? (CADAR GLEXPR))
(NULL (CDDAR GLEXPR)))
(PUTPROP GLAMBDAFN (QUOTE GLRESULTTYPE)
(SETQ RESULTTYPE (GLSUBSTTYPE
(GLEVALSTR (CADAR GLEXPR)
GLTOPCTX)
GLTYPESUBS)))
(pop GLEXPR))
(T (GLERROR (QUOTE GLCOMP)
(LIST "Bad RESULT structure declaration:"
(CAR GLEXPR)))
(pop GLEXPR]
((MEMB (CAAR GLEXPR)
(QUOTE (GLOBAL Global global)))
(SETQ GLGLOBALVARS (GLDECL (CDAR GLEXPR)
(QUOTE (NIL NIL))
GLTOPCTX NIL NIL))
(PUTPROP GLAMBDAFN (QUOTE GLGLOBALS)
GLGLOBALVARS)
(pop GLEXPR])
(GLSAVEFNTYPES
[LAMBDA (GLAMBDAFN TYPELST) (* GSN "28-JAN-83 09:55"
)
(PROG (Y)
(MAPC TYPELST (FUNCTION (LAMBDA (X)
(COND
([NOT (FMEMB GLAMBDAFN (SETQ Y
(GETPROP X (QUOTE GLFNSUSEDIN]
(PUTPROP X (QUOTE GLFNSUSEDIN)
(CONS GLAMBDAFN Y])
(GLSEPCLR
[LAMBDA NIL (* edited:
"30-DEC-81 16:34")
(SETQ GLSEPPTR 0])
(GLSEPINIT
[LAMBDA (ATM) (* GSN " 9-FEB-83 17:24"
) (* "GSN: "
"30-Dec-80 10:05")
(* Initialize the
scanning function which
breaks apart atoms
containing embedded
operators.)
(COND
((AND (ATOM ATM)
(NOT (STRINGP ATM)))
(SETQ GLSEPATOM ATM)
(SETQ GLSEPPTR 1))
(T (SETQ GLSEPATOM NIL)
(SETQ GLSEPPTR 0])
(GLSEPNXT
[LAMBDA NIL (* GSN " 6-JUN-83 16:08"
)
(* Get the next sub-atom from the atom which was
previously given to GLSEPINIT.
Sub-atoms are defined by splitting the given atom at
the occurrence of operators.
Operators which are defined are : ← ←+ ←← +← ←- -← '
= ~= <> > <)
(PROG (END TMP FOUNDSLASH)
(COND
((ZEROP GLSEPPTR)
(RETURN))
((NULL GLSEPATOM)
(SETQ GLSEPPTR 0)
(RETURN (QUOTE *NIL*)))
((NUMBERP GLSEPATOM)
(SETQ TMP GLSEPATOM)
(SETQ GLSEPPTR 0)
(RETURN TMP))
(GLNOSPLITATOMS (SETQ GLSEPPTR 0)
(RETURN GLSEPATOM)))
(SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM GLSEPPTR))
A (COND
[(NULL END)
(RETURN (PROG1 [COND
((AND (EQP GLSEPPTR 1)
FOUNDSLASH)
(GLSUBATOM GLSEPATOM 1 -1))
((EQP GLSEPPTR 1)
GLSEPATOM)
((IGREATERP GLSEPPTR (NCHARS GLSEPATOM))
NIL)
(T (GLSUBATOM GLSEPATOM GLSEPPTR
(NCHARS GLSEPATOM]
(SETQ GLSEPPTR 0]
((MEMB (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR
(IPLUS GLSEPPTR 2)))
(QUOTE (←←+ ←←- ←+←)))
(SETQ GLSEPPTR (IPLUS GLSEPPTR 3))
(RETURN TMP))
((MEMB (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR
(ADD1 GLSEPPTR)))
(QUOTE (:= ←← ←+ +← ←- -← ~= <> >= <=)))
(SETQ GLSEPPTR (IPLUS GLSEPPTR 2))
(RETURN TMP))
([AND (NOT GLSEPMINUS)
(EQ (NTHCHAR GLSEPATOM END)
(QUOTE -))
(NOT (EQ (NTHCHAR GLSEPATOM (ADD1 END))
(QUOTE ←]
(SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END)))
(GO A))
((AND (IGREATERP END 1)
(EQ (NTHCHAR GLSEPATOM (SUB1 END))
(QUOTE \)))
(SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END)))
(SETQ FOUNDSLASH T)
(GO A))
[(IGREATERP END GLSEPPTR)
(RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR
(SUB1 END))
(SETQ GLSEPPTR END]
(T (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR GLSEPPTR)
(SETQ GLSEPPTR (ADD1 GLSEPPTR])
(GLSKIPCOMMENTS
[LAMBDA NIL (* edited:
"26-MAY-82 16:17")
(* "GSN: "
" 7-Jan-81 16:36")
(* Skip comments in
GLEXPR.)
(PROG NIL
A (COND
([AND (LISTP GLEXPR)
(LISTP (CAR GLEXPR))
(OR (AND (EQ GLLISPDIALECT (QUOTE INTERLISP))
(EQ (CAAR GLEXPR)
(QUOTE *)))
(EQ (CAAR GLEXPR)
(QUOTE COMMENT]
(pop GLEXPR)
(GO A])
(GLSUBATOM
[LAMBDA (X Y Z) (* edited:
"30-DEC-81 16:35")
(OR (SUBATOM X Y Z)
(QUOTE *NIL*])
(GLSUBLIS
[LAMBDA (PAIRS EXPR) (* GSN "22-JAN-83 16:27"
) (* Same as SUBLIS, but
allows first elements in
PAIRS to be non-atomic.)
(PROG (TMP)
(RETURN (COND
((SETQ TMP (ASSOC EXPR PAIRS))
(CDR TMP))
((NLISTP EXPR)
EXPR)
(T (CONS (GLSUBLIS PAIRS (CAR EXPR))
(GLSUBLIS PAIRS (CDR EXPR])
(GLSUBSTTYPE
[LAMBDA (TYPE SUBS) (* edited:
"30-AUG-82 10:29")
(* Make subtype
substitutions within
TYPE according to
GLTYPESUBS.)
(SUBLIS SUBS TYPE])
(GLTHE
[LAMBDA (PLURALFLG) (* GSN "16-FEB-83 11:56"
) (* edited:
"17-Apr-81 14:23")
(* EXPR begins with THE.
Parse the expression and
return code.)
(DECLARE (SPECVARS SOURCE SPECS))
(PROG (SOURCE SPECS NAME QUALFLG DTYPE NEWCONTEXT LOOPVAR LOOPCOND
TMP) (* Now trace the path
specification.)
(GLTHESPECS)
[SETQ QUALFLG
(AND EXPR
(MEMB (CAR EXPR)
(QUOTE (with With WITH who Who WHO which Which
WHICH that That THAT]
B [COND
[(NULL SPECS)
(COND
((MEMB (CAR EXPR)
(QUOTE (IS Is is HAS Has has ARE Are are)))
(RETURN (GLPREDICATE SOURCE CONTEXT T NIL)))
(QUALFLG (GO C))
(T (RETURN SOURCE]
((AND QUALFLG (NOT PLURALFLG)
(NULL (CDR SPECS)))
(* If this is a definite reference to a qualified
entity, make the name of the entity plural.)
(SETQ NAME (CAR SPECS))
(RPLACA SPECS (GLPLURAL (CAR SPECS]
(* Try to find the next name on the list of SPECS
from SOURCE.)
[COND
[(NULL SOURCE)
(OR (SETQ SOURCE (GLIDNAME (SETQ NAME (pop SPECS))
NIL))
(RETURN (GLERROR (QUOTE GLTHE)
(LIST "The definite reference to"
NAME "could not be found."]
(SPECS (SETQ SOURCE (GLGETFIELD SOURCE (pop SPECS)
CONTEXT]
(GO B)
C [COND
([ATOM (SETQ DTYPE (GLXTRTYPE (CADR SOURCE]
(SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE]
[COND
((OR (NLISTP DTYPE)
(NEQ (CAR DTYPE)
(QUOTE LISTOF)))
(GLERROR (QUOTE GLTHE)
(LIST "The group name" NAME "has type" DTYPE
"which is not a legal group type."]
(SETQ NEWCONTEXT (CONS NIL CONTEXT))
(GLADDSTR (SETQ LOOPVAR (GLMKVAR))
NAME
(CADR DTYPE)
NEWCONTEXT)
(SETQ LOOPCOND
(GLPREDICATE (LIST LOOPVAR (CADR DTYPE))
NEWCONTEXT
(MEMB (pop EXPR)
(QUOTE (who Who WHO which Which WHICH
that That THAT)))
NIL))
[SETQ TMP (GLGENCODE (LIST (COND
(PLURALFLG (QUOTE SUBSET))
(T (QUOTE SOME)))
(CAR SOURCE)
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
(LIST LOOPVAR)
(CAR LOOPCOND]
(RETURN (COND
(PLURALFLG (LIST TMP (CADR SOURCE)))
(T (LIST (LIST (QUOTE CAR)
TMP)
(CADR DTYPE])
(GLTHESPECS
[LAMBDA NIL (* edited:
"20-MAY-82 17:19")
(* "GSN: "
"17-Apr-81 14:23")
(* EXPR begins with THE. Parse the expression and
return code in SOURCE and path names in SPECS.)
(PROG NIL
A [COND
((NULL EXPR)
(RETURN))
((MEMB (CAR EXPR)
(QUOTE (THE The the)))
(pop EXPR)
(COND
((NULL EXPR)
(RETURN (GLERROR (QUOTE GLTHE)
(LIST "Nothing following THE"]
(COND
[(ATOM (CAR EXPR))
(GLSEPINIT (CAR EXPR))
(COND
((EQ (GLSEPNXT)
(CAR EXPR))
(SETQ SPECS (CONS (pop EXPR)
SPECS)))
(T (GLSEPCLR)
(SETQ SOURCE (GLDOEXPR NIL CONTEXT T))
(RETURN]
(T (SETQ SOURCE (GLDOEXPR NIL CONTEXT T))
(RETURN))) (* SPECS contains a path
specification.
See if there is any
more.)
(COND
((MEMB (CAR EXPR)
(QUOTE (OF Of of)))
(pop EXPR)
(GO A])
(GLTRANSPROG
[LAMBDA (X) (* edited:
"29-APR-83 11:56")
(* Translate places where a PROG variable is
initialized to a value as allowed by Interlisp.
This is done by adding a SETQ to set the value of
each PROG variable which is initialized.
In some cases, a change of variable name is required
to preserve the same semantics.)
(PROG (TMP ARGVALS SETVARS REST)
[MAP
(CADR X)
(FUNCTION (LAMBDA (Y)
(COND
((LISTP (CAR Y)) (* If possible, use the
same variable;
otherwise, make a new
one.)
[SETQ TMP
(COND
([OR [SOME (CADR X)
(FUNCTION (LAMBDA (Z)
(AND (LISTP Z)
(GLOCCURS (CAR Z)
(CADAR Y]
(SOME ARGVALS (FUNCTION (LAMBDA (Z)
(GLOCCURS (CAAR Y)
Z]
(GLMKVAR))
(T (CAAR Y]
[SETQ SETVARS (NCONC1 SETVARS (LIST (QUOTE SETQ)
TMP
(CADAR Y]
(SETQ REST (DSUBST TMP (CAAR Y)
(CDDR X)))
(SETQ ARGVALS (CONS (CADAR Y)
ARGVALS))
(RPLACA Y TMP]
[COND
(SETVARS (RPLACD (CDR X)
(NCONC SETVARS REST]
(RETURN X])
(GLUNCOMPILE
[LAMBDA (GLAMBDAFN) (* GSN " 6-JUN-83 16:00"
) (* Remove the
GLISP-compiled
definition and
properties of GLAMBDAFN)
(PROG (SPECS SPECLST STR LST TMP)
(OR (GETPROP GLAMBDAFN (QUOTE GLCOMPILED))
(SETQ SPECS (GETPROP GLAMBDAFN (QUOTE GLSPECIALIZATION)))
(RETURN))
(COND
((NOT GLQUIETFLG)
(PRIN1 "uncompiling ")
(PRIN1 GLAMBDAFN)
(TERPRI)))
(PUTPROP GLAMBDAFN (QUOTE GLCOMPILED)
NIL)
(PUTPROP GLAMBDAFN (QUOTE GLRESULTTYPE)
NIL)
(GLUNSAVEDEF GLAMBDAFN)
[MAPC (GETPROP GLAMBDAFN (QUOTE GLTYPESUSED))
(FUNCTION (LAMBDA (Y)
(PUTPROP Y (QUOTE GLFNSUSEDIN)
(DREMOVE GLAMBDAFN (GETPROP Y
(QUOTE
GLFNSUSEDIN]
(PUTPROP GLAMBDAFN (QUOTE GLTYPESUSED)
NIL)
(OR SPECS (RETURN)) (* Uncompile a
specialization of a
generic function.)
A (COND
((NULL SPECS)
(RETURN)))
(SETQ SPECLST (pop SPECS))
[PUTPROP (CAR SPECLST)
(QUOTE GLINSTANCEFNS)
(DREMOVE GLAMBDAFN (GETPROP (CAR SPECLST)
(QUOTE GLINSTANCEFNS]
(* Remove the
specialization entry in
the datatype where it
was created.)
(OR (SETQ STR (GETPROP (CADR SPECLST)
(QUOTE GLSTRUCTURE)))
(GO A))
(SETQ LST (CDR STR))
LP (COND
((NULL LST)
(GO A))
((EQ (CAR LST)
(CADDR SPECLST))
[COND
((AND (SETQ TMP (ASSOC (CADDDR SPECLST)
(CADR LST)))
(EQ (CADR TMP)
GLAMBDAFN))
(RPLACA (CDR LST)
(DREMOVE TMP (CADR LST]
(GO A))
(T (SETQ LST (CDDR LST))
(GO LP])
(GLUNSAVEDEF
[LAMBDA (GLAMBDAFN) (* GSN "28-JAN-83 11:15"
) (* Remove the
GLISP-compiled
definition of GLAMBDAFN)
(SELECTQ GLLISPDIALECT
(INTERLISP (PUTD GLAMBDAFN (GETPROP GLAMBDAFN
(QUOTE EXPR)))
(PUTHASH (GETD GLAMBDAFN)
NIL CLISPARRAY))
[FRANZLISP (PUTD GLAMBDAFN (GETPROP GLAMBDAFN
(QUOTE GLORIGINALEXPR]
((MACLISP UCILISP PSL)
(GLPUTHOOK GLAMBDAFN))
(ERROR])
(GLUNWRAP
[LAMBDA (X BUSY) (* GSN "22-JUL-83 14:20"
) (* Unwrap an expression
X by removing extra
stuff inserted during
compilation.)
(COND
((NLISTP X)
X)
((NOT (ATOM (CAR X)))
(ERROR (QUOTE GLUNWRAP)
X))
((SELECTQ
(CAR X)
((QUOTE GO)
X)
[(PROG2 PROGN)
(COND
((NULL (CDDR X))
(GLUNWRAP (CADR X)
BUSY))
(T [MAP (CDR X)
(FUNCTION (LAMBDA (Y)
(RPLACA Y (GLUNWRAP
(CAR Y)
(AND BUSY (NULL (CDR Y]
(GLEXPANDPROGN X BUSY NIL)
(COND
((NULL (CDDR X))
(CADR X))
(T X]
[PROG1
(COND
((NULL (CDDR X))
(GLUNWRAP (CADR X)
BUSY))
(T [MAP (CDR X)
(FUNCTION (LAMBDA (Y)
(RPLACA Y (GLUNWRAP
(CAR Y)
(AND BUSY (EQ Y (CDR X]
(COND
(BUSY (GLEXPANDPROGN (CDR X)
BUSY NIL))
(T (RPLACA X (QUOTE PROGN))
(GLEXPANDPROGN X BUSY NIL)))
(COND
((NULL (CDDR X))
(CADR X))
(T X]
(FUNCTION (RPLACA (CDR X)
(GLUNWRAP (CADR X)
BUSY))
[MAP (CDDR X)
(FUNCTION (LAMBDA (Y)
(RPLACA Y (GLUNWRAP (CAR Y)
T]
X)
((MAP MAPC MAPCAR MAPCONC SUBSET SOME EVERY)
(GLUNWRAPMAP X BUSY))
[LAMBDA [MAP (CDDR X)
(FUNCTION (LAMBDA (Y)
(RPLACA Y (GLUNWRAP
(CAR Y)
(AND BUSY (NULL (CDR Y]
(GLEXPANDPROGN (CDR X)
BUSY NIL)
X]
((PROG RESETVARS)
(GLUNWRAPPROG X BUSY))
(COND (GLUNWRAPCOND X BUSY))
((SELECTQ CASEQ)
(GLUNWRAPSELECTQ X BUSY))
((UNION INTERSECTION LDIFFERENCE)
(GLUNWRAPINTERSECT X))
(COND
((AND (EQ (CAR X)
(QUOTE *))
(EQ GLLISPDIALECT (QUOTE INTERLISP)))
X)
((AND (NOT BUSY)
(CDR X)
(NULL (CDDR X))
(GLPURE (CAR X)))
(GLUNWRAP (CADR X)
NIL))
(T
[MAP (CDR X)
(FUNCTION (LAMBDA (Y)
(RPLACA Y (GLUNWRAP (CAR Y)
T]
(COND
((AND (CDR X)
(NULL (CDDR X))
(LISTP (CADR X))
(GLCARCDR? (CAR X))
(GLCARCDR? (CAADR X))
(ILESSP (IPLUS (NCHARS (CAR X))
(NCHARS (CAADR X)))
9))
[RPLACA
X
(PACK
(CONS (QUOTE C)
(DREVERSE
(CONS (QUOTE R)
(NCONC (GLANYCARCDR? (CAADR X))
(GLANYCARCDR? (CAR X]
(RPLACA (CDR X)
(CADADR X))
(GLUNWRAP X BUSY))
([AND (GETPROP (CAR X)
(QUOTE GLEVALWHENCONST))
(EVERY (CDR X)
(FUNCTION GLCONST?))
(OR (NOT (GETPROP (CAR X)
(QUOTE GLARGSNUMBERP)))
(EVERY (CDR X)
(FUNCTION NUMBERP]
(EVAL X))
((FMEMB (CAR X)
(QUOTE (AND OR)))
(GLUNWRAPLOG X))
(T X])
(GLUNWRAPCOND
[LAMBDA (X BUSY) (* GSN "27-JAN-83 13:57"
) (* Unwrap a COND
expression.)
(PROG (RESULT)
(SETQ RESULT X)
A (COND
((NULL (CDR RESULT))
(GO B)))
(RPLACA (CADR RESULT)
(GLUNWRAP (CAADR RESULT)
T))
(COND
((EQ (CAADR RESULT)
NIL)
(RPLACD RESULT (CDDR RESULT))
(GO A))
(T [MAP (CDADR RESULT)
(FUNCTION (LAMBDA (Y)
(RPLACA Y (GLUNWRAP (CAR Y)
(AND BUSY
(NULL (CDR Y]
(GLEXPANDPROGN (CADR RESULT)
BUSY NIL)))
(COND
((EQ (CAADR RESULT)
T)
(RPLACD (CDR RESULT)
NIL)))
(SETQ RESULT (CDR RESULT))
(GO A)
B (COND
[(AND (NULL (CDDR X))
(EQ (CAADR X)
T))
(RETURN (CONS (QUOTE PROGN)
(CDADR X]
(T (RETURN X])
(GLUNWRAPINTERSECT
[LAMBDA (CODE) (* GSN "17-FEB-83 13:40"
)
(* Optimize intersections and unions of subsets of
the same set: (INTERSECT (SUBSET S P)
(SUBSET S Q)) -> (SUBSET S (AND P Q)))
(PROG (LHS RHS P Q QQ SA SB)
(SETQ LHS (GLUNWRAP (CADR CODE)
T))
(SETQ RHS (GLUNWRAP (CADDR CODE)
T))
(OR (AND (LISTP LHS)
(LISTP RHS)
(EQ (CAR LHS)
(QUOTE SUBSET))
(EQ (CAR RHS)
(QUOTE SUBSET)))
(GO OUT))
(SELECTQ GLLISPDIALECT
((INTERLISP PSL)
(SETQ SA (GLUNWRAP (CADR LHS)
T))
(SETQ SB (GLUNWRAP (CADR RHS)
T)))
((MACLISP FRANZLISP UCILISP)
(SETQ SA (GLUNWRAP (CADDR LHS)
T))
(SETQ SB (GLUNWRAP (CADDR RHS)
T)))
(ERROR)) (* Make sure the sets
are the same.)
(OR (EQUAL SA SB)
(GO OUT))
(SELECTQ GLLISPDIALECT
[(INTERLISP PSL)
(SETQ P (GLXTRFN (CADDR LHS)))
(SETQ Q (GLXTRFN (CADDR RHS]
[(MACLISP FRANZLISP UCILISP)
(SETQ P (GLXTRFN (CADR LHS)))
(SETQ Q (GLXTRFN (CADR RHS]
(ERROR))
(SETQ QQ (SUBST (CAR P)
(CAR Q)
(CADR Q)))
[RETURN
(GLGENCODE
(LIST
(QUOTE SUBSET)
SA
(LIST
(QUOTE FUNCTION)
(LIST
(QUOTE LAMBDA)
(LIST (CAR P))
(GLUNWRAP (SELECTQ
(CAR CODE)
(INTERSECTION (LIST (QUOTE AND)
(CADR P)
QQ))
(UNION (LIST (QUOTE OR)
(CADR P)
QQ))
(LDIFFERENCE
(LIST (QUOTE AND)
(CADR P)
(LIST (QUOTE NOT)
QQ)))
(ERROR))
T]
OUT [MAP (CDR CODE)
(FUNCTION (LAMBDA (Y)
(RPLACA Y (GLUNWRAP (CAR Y)
T]
(RETURN CODE])
(GLUNWRAPLOG
[LAMBDA (X) (* GSN "16-MAR-83 10:50"
)
(* Unwrap a logical expression by performing
constant transformations and splicing in sublists of
the same type, e.g., (AND X
(AND Y Z)) -> (AND X Y Z).)
(PROG (Y LAST)
(SETQ Y (CDR X))
(SETQ LAST X)
LP [COND
((NULL Y)
(GO OUT))
([OR (AND (NULL (CAR Y))
(EQ (CAR X)
(QUOTE AND)))
(AND (EQ (CAR Y)
T)
(EQ (CAR X)
(QUOTE OR]
(RPLACD Y NIL))
([OR (AND (NULL (CAR Y))
(EQ (CAR X)
(QUOTE OR)))
(AND (EQ (CAR Y)
T)
(EQ (CAR X)
(QUOTE AND]
(SETQ Y (CDR Y))
(RPLACD LAST Y)
(GO LP))
((AND (LISTP (CAR Y))
(EQ (CAAR Y)
(CAR X)))
(RPLACD (LAST (CAR Y))
(CDR Y))
(RPLACD Y (CDDAR Y))
(RPLACA Y (CADAR Y]
(SETQ Y (CDR Y))
(SETQ LAST (CDR LAST))
(GO LP)
OUT [COND
[(NULL (CDR X))
(RETURN (EQ (CAR X)
(QUOTE AND]
((NULL (CDDR X))
(RETURN (CADR X]
(RETURN X])
(GLUNWRAPMAP
[LAMBDA (X BUSY) (* "GSN: "
" 4-Dec-83 17:17")
(* Unwrap and optimize
mapping-type functions.)
(PROG (LST FN OUTSIDE INSIDE OUTFN INFN NEWFN NEWMAP TMPVAR NEWLST
CDRFN)
(SELECTQ
GLLISPDIALECT
[(INTERLISP UTLISP PSL)
(SETQ LST (GLUNWRAP (CADR X)
T))
[SETQ FN (GLUNWRAP (CADDR X)
(NOT (MEMB (CAR X)
(QUOTE (MAPC MAP]
(SETQ CDRFN (AND (CDDDR X)
(LIST (GLUNWRAP (CADDDR X)
T]
[(MACLISP UCILISP) |
(SETQ LST (GLUNWRAP (CADDR X) |
T)) |
(SETQ FN (GLUNWRAP (CADR X) |
(NOT (MEMB (CAR X) |
(QUOTE (MAPC MAP] |
[FRANZLISP |
(COND |
[(MEMB (CAR X) |
(QUOTE (SOME EVERY))) |
(SETQ LST (GLUNWRAP (CADR X) |
T)) |
(SETQ FN (GLUNWRAP (CADDR X) |
T)) |
(SETQ CDRFN (AND (CDDDR X) |
(LIST (GLUNWRAP (CADDDR X) |
T] |
(T (SETQ LST (GLUNWRAP (CADDR X) |
T)) |
(SETQ FN (GLUNWRAP |
(CADR X) |
(NOT (MEMB (CAR X) |
(QUOTE (MAPC MAP] |
(ERROR)) |
(COND
((OR [NOT (MEMB (SETQ OUTFN (CAR X))
(QUOTE (SUBSET MAPCAR MAPC MAPCONC]
[NOT (AND (LISTP LST)
(MEMB (SETQ INFN (CAR LST))
(QUOTE (SUBSET MAPCAR]
CDRFN)
(GO OUT)))
(* Optimize compositions of mapping functions to
avoid construction of lists of intermediate
results.)
(* These optimizations are not correct if the
mapping functions have interdependent side-effects.
However, these are likely to be very rare, so we do
it anyway.)
(SETQ OUTSIDE (GLXTRFN FN))
[SETQ INSIDE (GLXTRFN (SELECTQ GLLISPDIALECT
((INTERLISP PSL)
(SETQ NEWLST (CADR LST))
(CADDR LST))
((MACLISP FRANZLISP UCILISP)
(SETQ NEWLST (CADDR LST))
(CADR LST))
(ERROR]
(SELECTQ
INFN
(SUBSET (SELECTQ
OUTFN
[(SUBSET MAPCONC)
(SETQ NEWMAP OUTFN)
(SETQ NEWFN (LIST (QUOTE AND)
(CADR INSIDE)
(SUBST (CAR INSIDE)
(CAR OUTSIDE)
(CADR OUTSIDE]
[MAPCAR (SETQ NEWMAP (QUOTE MAPCONC))
(SETQ NEWFN
(LIST (QUOTE AND)
(CADR INSIDE)
(LIST (QUOTE CONS)
(SUBST (CAR INSIDE)
(CAR OUTSIDE)
(CADR OUTSIDE))
NIL]
[MAPC (SETQ NEWMAP (QUOTE MAPC))
(SETQ NEWFN (LIST (QUOTE AND)
(CADR INSIDE)
(SUBST (CAR INSIDE)
(CAR OUTSIDE)
(CADR OUTSIDE]
(ERROR)))
(MAPCAR [SETQ NEWFN (LIST (QUOTE PROG)
(LIST (SETQ TMPVAR (GLMKVAR)))
(LIST (QUOTE SETQ)
TMPVAR
(CADR INSIDE))
(LIST (QUOTE RETURN)
(QUOTE *GLCODE*]
(SELECTQ
OUTFN
(SUBSET (SETQ NEWMAP (QUOTE MAPCONC))
(SETQ NEWFN
(SUBST (LIST (QUOTE AND)
(SUBST TMPVAR
(CAR OUTSIDE)
(CADR OUTSIDE))
(LIST (QUOTE CONS)
TMPVAR NIL))
(QUOTE *GLCODE*)
NEWFN)))
(MAPCAR (SETQ NEWMAP (QUOTE MAPCAR))
(SETQ NEWFN (SUBST (SUBST TMPVAR
(CAR OUTSIDE)
(CADR OUTSIDE))
(QUOTE *GLCODE*)
NEWFN)))
(MAPC (SETQ NEWMAP (QUOTE MAPC))
(SETQ NEWFN (SUBST (SUBST TMPVAR
(CAR OUTSIDE)
(CADR OUTSIDE))
(QUOTE *GLCODE*)
NEWFN)))
(ERROR)))
(ERROR))
(RETURN
(GLUNWRAP [GLGENCODE
(LIST NEWMAP NEWLST
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
(LIST (CAR INSIDE))
NEWFN]
BUSY))
OUT (RETURN (GLGENCODE (CONS OUTFN (CONS LST (CONS FN CDRFN])
(GLUNWRAPPROG
[LAMBDA (X BUSY) (* GSN "22-JUL-83 14:21"
) (* Unwrap a PROG
expression.)
(PROG (LAST)
(COND
((NEQ GLLISPDIALECT (QUOTE INTERLISP))
(GLTRANSPROG X)))
(* First see if the PROG is not busy and ends with a
RETURN.)
[COND
((AND (NOT BUSY)
(EQ (CAR X)
(QUOTE PROG))
(SETQ LAST (LAST X))
(LISTP (CAR LAST))
(EQ (CAAR LAST)
(QUOTE RETURN))) (* Remove the RETURN.
If atomic, remove the
atom also.)
(COND
((ATOM (CADAR LAST))
(RPLACD (NLEFT X 2)
NIL))
(T (RPLACA LAST (CADAR LAST] (* Do any
initializations of PROG
variables.)
[MAPC (CADR X)
(FUNCTION (LAMBDA (Y)
(COND
((LISTP Y)
(RPLACA (CDR Y)
(GLUNWRAP (CADR Y)
T]
[MAP (CDDR X)
(FUNCTION (LAMBDA (Y)
(RPLACA Y (GLUNWRAP (CAR Y)
NIL]
(GLEXPANDPROGN (CDR X)
BUSY T)
(RETURN X])
(GLUNWRAPSELECTQ
[LAMBDA (X BUSY) (* GSN "27-JAN-83 13:57"
) (* Unwrap a SELECTQ or
CASEQ expression.)
(PROG (L SELECTOR) (* First unwrap the
component expressions.)
(RPLACA (CDR X)
(GLUNWRAP (CADR X)
T))
[MAP
(CDDR X)
(FUNCTION (LAMBDA (Y)
(COND
((OR (CDR Y)
(EQ (CAR X)
(QUOTE CASEQ)))
[MAP (CDAR Y)
(FUNCTION (LAMBDA (Z)
(RPLACA Z
(GLUNWRAP
(CAR Z)
(AND BUSY (NULL (CDR Z]
(GLEXPANDPROGN (CAR Y)
BUSY NIL))
(T (RPLACA Y (GLUNWRAP (CAR Y)
BUSY]
(* Test if the selector
is a compile-time
constant.)
(COND
((NOT (GLCONST? (CADR X)))
(RETURN X))) (* Evaluate the
selection at compile
time.)
(SETQ SELECTOR (GLCONSTVAL (CADR X)))
(SETQ L (CDDR X))
LP [COND
((NULL L)
(RETURN NIL))
((AND (NULL (CDR L))
(EQ (CAR X)
(QUOTE SELECTQ)))
(RETURN (CAR L)))
((AND (EQ (CAR X)
(QUOTE CASEQ))
(EQ (CAAR L)
T))
(RETURN (GLUNWRAP (CONS (QUOTE PROGN)
(CDAR L))
BUSY)))
([OR (EQ SELECTOR (CAAR L))
(AND (LISTP (CAAR L))
(MEMB SELECTOR (CAAR L]
(RETURN (GLUNWRAP (CONS (QUOTE PROGN)
(CDAR L))
BUSY]
(SETQ L (CDR L))
(GO LP])
(GLUPDATEVARTYPE
[LAMBDA (VAR TYPE) (* edited:
" 5-MAY-82 15:49")
(* "GSN: "
"25-Jan-81 18:00")
(* Update the type of
VAR to be TYPE.)
(PROG (CTXENT)
(COND
((NULL TYPE))
[(SETQ CTXENT (GLFINDVARINCTX VAR CONTEXT))
(COND
((NULL (CADDR CTXENT))
(RPLACA (CDDR CTXENT)
TYPE]
(T (GLADDSTR VAR NIL TYPE CONTEXT])
(GLUSERFN
[LAMBDA (EXPR) (* GSN "23-JAN-83 15:31"
) (* "GSN: "
" 7-Apr-81 10:44")
(* Process a user-function, i.e., any function which
is not specially compiled by GLISP.
The function is tested to see if it is one which a
unit package wants to compile specially;
if not, the function is compiled by GLUSERFNB.)
(PROG (FNNAME TMP UPS)
(SETQ FNNAME (CAR EXPR))
(* First see if a user structure-name package wants
to intercept this function call.)
(SETQ UPS GLUSERSTRNAMES)
LPA [COND
((NULL UPS)
(GO B))
([SETQ TMP (ASSOC FNNAME (CAR (CDDDDR (CAR UPS]
(RETURN (APPLY* (CDR TMP)
EXPR CONTEXT]
(SETQ UPS (CDR UPS))
(GO LPA)
B
(* Test the function name to see if it is a function
which some unit package would like to intercept and
compile specially.)
(SETQ UPS GLUNITPKGS)
LP [COND
((NULL UPS)
(GO C))
([AND [MEMB FNNAME (CAR (CDDDDR (CAR UPS]
(SETQ TMP (ASSOC (QUOTE UNITFN)
(CADDR (CAR UPS]
(RETURN (APPLY* (CDR TMP)
EXPR CONTEXT]
(SETQ UPS (CDR UPS))
(GO LP)
C (COND
[(AND (BOUNDP (QUOTE GLFNSUBS))
(SETQ TMP (ASSOC FNNAME GLFNSUBS)))
(RETURN (GLUSERFNB (CONS (CDR TMP)
(CDR EXPR]
(T (RETURN (GLUSERFNB EXPR])
(GLUSERFNB
[LAMBDA (EXPR) (* GSN "23-JAN-83 15:54"
) (* "GSN: "
" 7-Apr-81 10:44")
(* Parse an arbitrary function by getting the
function name and then calling GLDOEXPR to get the
arguments.)
(PROG (ARGS ARGTYPES FNNAME TMP)
(SETQ FNNAME (pop EXPR))
A (COND
[(NULL EXPR)
(SETQ ARGS (DREVERSE ARGS))
(SETQ ARGTYPES (DREVERSE ARGTYPES))
(RETURN (COND
((AND (GETPROP FNNAME (QUOTE GLEVALWHENCONST))
(EVERY ARGS (FUNCTION GLCONST?)))
(LIST (EVAL (CONS FNNAME ARGS))
(GLRESULTTYPE FNNAME ARGTYPES)))
(T (LIST (CONS FNNAME ARGS)
(GLRESULTTYPE FNNAME ARGTYPES]
([SETQ TMP (OR (GLDOEXPR NIL CONTEXT T)
(PROG1 (GLERROR (QUOTE GLUSERFNB)
(LIST
"Function call contains illegal item. EXPR ="
EXPR))
(SETQ EXPR NIL]
(SETQ ARGS (CONS (CAR TMP)
ARGS))
(SETQ ARGTYPES (CONS (CADR TMP)
ARGTYPES))
(GO A])
(GLUSERGETARGS
[LAMBDA (EXPR CONTEXT) (* edited:
"24-AUG-82 17:40")
(* edited:
" 7-Apr-81 10:44")
(* Get the arguments to an function call for use by
a user compilation function.)
(PROG (ARGS TMP)
(pop EXPR)
A (COND
((NULL EXPR)
(RETURN (DREVERSE ARGS)))
([SETQ TMP (OR (GLDOEXPR NIL CONTEXT T)
(PROG1 (GLERROR (QUOTE GLUSERFNB)
(LIST
"Function call contains illegal item. EXPR ="
EXPR))
(SETQ EXPR NIL]
(SETQ ARGS (CONS TMP ARGS))
(GO A])
(GLVALUE
[LAMBDA (SOURCE PROP TYPE DESLIST) (* GSN "10-FEB-83 12:57"
)
(* Get the value of the property PROP from SOURCE,
whose type is given by TYPE.
The property may be a field in the structure, or may
be a PROP virtual field.)
(* DESLIST is a list of object types which have
previously been tried, so that a compiler loop can
be prevented.)
(PROG (TMP PROPL TRANS FETCHCODE)
(COND
((FMEMB TYPE DESLIST)
(RETURN))
((SETQ TMP (GLSTRFN PROP TYPE DESLIST))
(RETURN (GLSTRVAL TMP SOURCE)))
((SETQ PROPL (GLSTRPROP TYPE (QUOTE PROP)
PROP NIL))
(SETQ TMP (GLCOMPMSGL (LIST SOURCE TYPE)
(QUOTE PROP)
PROPL NIL CONTEXT))
(RETURN TMP))) (* See if the value can
be found in a
TRANSPARENT subobject.)
(SETQ TRANS (GLTRANSPARENTTYPES TYPE))
B (COND
((NULL TRANS)
(RETURN))
((SETQ TMP (GLVALUE (QUOTE *GL*)
PROP
(GLXTRTYPE (CAR TRANS))
(CONS (CAR TRANS)
DESLIST)))
(SETQ FETCHCODE (GLSTRFN (CAR TRANS)
TYPE NIL))
(GLSTRVAL TMP (CAR FETCHCODE))
(GLSTRVAL TMP SOURCE)
(RETURN TMP))
((SETQ TMP (CDR TMP))
(GO B])
(GLVARTYPE
[LAMBDA (VAR CONTEXT) (* edited:
"16-DEC-81 12:00")
(* "GSN: "
"21-Apr-81 11:30")
(* Get the
structure-description
for a variable in the
specified context.)
(PROG (TMP)
(RETURN (COND
((SETQ TMP (GLFINDVARINCTX VAR CONTEXT))
(OR (CADDR TMP)
(QUOTE *NIL*)))
(T NIL])
(GLXTRFN
[LAMBDA (FNLST) (* edited:
" 3-DEC-82 10:24")
(* Extract the code and variable from a FUNCTION
list. If there is no variable, a new one is created.
The result is a list of the variable and code.)
(PROG (TMP) (* If only the function
name is specified, make
a LAMBDA form.)
[COND
((ATOM (CADR FNLST))
(RPLACA (CDR FNLST)
(LIST (QUOTE LAMBDA)
(LIST (SETQ TMP (GLMKVAR)))
(LIST (CADR FNLST)
TMP]
[COND
((CDDDR (CADR FNLST))
(RPLACD (CDADR FNLST)
(LIST (CONS (QUOTE PROGN)
(CDDADR FNLST]
(RETURN (LIST (CAADR (CADR FNLST))
(CADDR (CADR FNLST])
(GLXTRTYPEB
[LAMBDA (TYPE) (* edited:
"26-JUL-82 14:02")
(* Extract a -real- type
from a type spec.)
(COND
((NULL TYPE)
NIL)
[(ATOM TYPE)
(COND
((MEMB TYPE GLBASICTYPES)
TYPE)
(T (GLXTRTYPEB (GLGETSTR TYPE]
((NLISTP TYPE)
NIL)
((MEMB (CAR TYPE)
GLTYPENAMES)
TYPE)
((ASSOC (CAR TYPE)
GLUSERSTRNAMES)
TYPE)
((AND (ATOM (CAR TYPE))
(CDR TYPE))
(GLXTRTYPEB (CADR TYPE)))
(T (GLERROR (QUOTE GLXTRTYPE)
(LIST TYPE "is an illegal type specification."))
NIL])
(GLXTRTYPEC
[LAMBDA (TYPE) (* edited:
" 1-NOV-82 16:38")
(* Extract a -real- type
from a type spec.)
(AND (ATOM TYPE)
(NOT (MEMB TYPE GLBASICTYPES))
(GLXTRTYPE (GLGETSTR TYPE])
)
[FILEPKGCOM (QUOTE GLISPCONSTANTS)
(QUOTE MACRO)
(QUOTE (GLISPCONSTANTS (E (GLPRETTYPRINTCONST (QUOTE
GLISPCONSTANTS]
(FILEPKGTYPE (QUOTE GLISPCONSTANTS)
(QUOTE DESCRIPTION)
(QUOTE "GLISP compile-time constants")
(QUOTE GETDEF)
(QUOTE GLGETCONSTDEF))
[FILEPKGCOM (QUOTE GLISPGLOBALS)
(QUOTE MACRO)
(QUOTE (GLISPGLOBALS (E (GLPRETTYPRINTGLOBALS (QUOTE
GLISPGLOBALS]
(FILEPKGTYPE (QUOTE GLISPGLOBALS)
(QUOTE DESCRIPTION)
(QUOTE "GLISP global variables")
(QUOTE GETDEF)
(QUOTE GLGETGLOBALDEF))
[FILEPKGCOM (QUOTE GLISPOBJECTS)
(QUOTE MACRO)
(QUOTE (GLISPOBJECTS (E (GLPRETTYPRINTSTRS (QUOTE
GLISPOBJECTS]
(FILEPKGTYPE (QUOTE GLISPOBJECTS)
(QUOTE DESCRIPTION)
(QUOTE "GLISP Object Definitions")
(QUOTE GETDEF)
(QUOTE GLGETDEF)
(QUOTE DELDEF)
(QUOTE GLDELDEF))
(ADDTOVAR LAMBDASPLST GLAMBDA)
(ADDTOVAR LAMBDATRANFNS (GLAMBDA GLAMBDATRAN EXPR NIL))
(ADDTOVAR PRETTYEQUIVLST (GLAMBDA . LAMBDA))
(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)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
(FILEMAP (NIL (2599 80225 (GLLISPADJ 2609 . 3263) (GLLISPISA 3265 . 3882) (GLMAKEFORLOOP 3884 . 5404)
(GLMAKEGLISPVERSION 5406 . 7512) (GLMAKEGLISPVERSIONS 7514 . 7755) (GLMAKESTR 7757 . 8604) (
GLMAKEVTYPE 8606 . 9910) (GLMATCH 9912 . 10615) (GLMATCHL 10617 . 11091) (GLMINUSFN 11093 . 11619) (
GLMKLABEL 11621 . 11950) (GLMKVTYPE 11952 . 12197) (GLNCONCFN 12199 . 14445) (GLNEQUALFN 14447 . 15225
) (GLNOTESOURCETYPE 15227 . 15875) (GLNOTFN 15877 . 16201) (GLOCCURS 16203 . 16513) (GLOPERAND 16515
. 17313) (GLOPERATOR? 17315 . 17613) (GLORFN 17615 . 18322) (GLOUTPUTFILTER 18324 . 19012) (
GLPARSEXPR 19014 . 21267) (GLPARSFLD 21269 . 22593) (GLPARSNFLD 22595 . 23444) (GLPLURAL 23446 . 24302
) (GLPOPFN 24304 . 26111) (GLPREC 26113 . 27159) (GLPREDICATE 27161 . 30253) (GLPRETTYPRINTCONST 30255
. 30828) (GLPRETTYPRINTGLOBALS 30830 . 31337) (GLPRETTYPRINTSTRS 31339 . 32235) (GLPROGN 32237 .
33038) (GLPURE 33040 . 33342) (GLPUSHEXPR 33344 . 33839) (GLPUSHFN 33841 . 36054) (GLPUTPROPS 36056 .
36617) (GLPUTUPFN 36619 . 37685) (GLREDUCE 37687 . 38670) (GLREDUCEARITH 38672 . 44504) (GLREDUCEOP
44506 . 45528) (GLREMOVEFN 45530 . 47360) (GLRESGLOBAL 47362 . 48380) (GLSAVEFNTYPES 48382 . 48681) (
GLSEPCLR 48683 . 48800) (GLSEPINIT 48802 . 49291) (GLSEPNXT 49293 . 51371) (GLSKIPCOMMENTS 51373 .
51901) (GLSUBATOM 51903 . 52038) (GLSUBLIS 52040 . 52466) (GLSUBSTTYPE 52468 . 52726) (GLTHE 52728 .
55248) (GLTHESPECS 55250 . 56296) (GLTRANSPROG 56298 . 57501) (GLUNCOMPILE 57503 . 59344) (GLUNSAVEDEF
59346 . 59856) (GLUNWRAP 59858 . 62620) (GLUNWRAPCOND 62622 . 63543) (GLUNWRAPINTERSECT 63545 . 65367
) (GLUNWRAPLOG 65369 . 66495) (GLUNWRAPMAP 66497 . 70527) (GLUNWRAPPROG 70529 . 71594) (
GLUNWRAPSELECTQ 71596 . 73142) (GLUPDATEVARTYPE 73144 . 73643) (GLUSERFN 73645 . 75114) (GLUSERFNB
75116 . 76166) (GLUSERGETARGS 76168 . 76800) (GLVALUE 76802 . 78079) (GLVARTYPE 78081 . 78552) (
GLXTRFN 78554 . 79309) (GLXTRTYPEB 79311 . 79943) (GLXTRTYPEC 79945 . 80223)))))
STOP
)))))
STOP