Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-01 - decus/20-0004/glisp.lsp
There are no other files named glisp.lsp in the archive.
(FILECREATED "18-FEB-82 08:35:22" <LISPUSERS>GLISP.LSP;3 129492 

     previous date: "17-FEB-82 22:41:10" <LISPUSERS>GLISP.LSP;2)


(PRETTYCOMPRINT GLISPCOMS)

(RPAQQ GLISPCOMS [(FNS GL-A-AN? GLADDRESULTTYPE GLADDSTR GLADJ 
		       GLAMBDATRAN GLANDFN GLATMSTR? GLBUILDALIST 
		       GLBUILDCONS GLBUILDLIST GLBUILDNOT GLBUILDSTR 
		       GLCARCDR? GLCOMP GLCOMPCOMS GLCOMPILE GLCOMPMSG 
		       GLCOMPOPEN GLCONST? GLCONSTSTR? GLCONSTVAL 
		       GLDECL GLDECLDS GLDEFPROP GLDEFSTR GLDEFSTRQ 
		       GLDEFUNITPKG GLDELDEF GLDOA GLDOCOND GLDOEXPR 
		       GLDOFOR GLDOIF GLDOLAMBDA GLDOMAIN GLDOMSG 
		       GLDOPROG GLDOPROGN GLDOPROG1 GLDOREPEAT 
		       GLDORETURN GLDOSELECTQ GLDOSEND GLDOSETQ GLDOTHE 
		       GLDOVARSETQ GLDOWHILE GLED GLEQUALFN GLERR 
		       GLERROR GLEXPANDPROGN GLFINDVARINCTX GLGETASSOC 
		       GLGETD GLGETDEF GLGETFIELD GLGETFROMUNIT 
		       GLGETPAIRS GLGETSTR GLIDNAME GLIDTYPE GLINIT 
		       GLINITLAMBDATRAN GLLISPADJ GLLISPISA GLMAKESTR 
		       GLMKLABEL GLMKVAR GLNCONCFN GLNEQUALFN GLOKSTR? 
		       GLOPERAND GLOPERATOR? GLORFN GLPARSEXPR 
		       GLPARSFLD GLPARSNFLD GLPLURAL GLPOPFN GLPREC 
		       GLPREDICATE GLPRETTYPRINTSTRS GLPROGN GLPURE 
		       GLPUSHEXPR GLPUSHFN GLPUTFN GLPUTUPFN GLPUTPROPS 
		       GLREDUCE GLREDUCEARITH GLREDUCEOP GLREMOVEFN 
		       GLRESULTTYPE GLSEPCLR GLSEPINIT GLSEPNXT 
		       GLSKIPCOMMENTS GLSTRFN GLSTRPROP GLSTRVAL 
		       GLSTRVALB GLSUBATOM GLTHE GLTRANSPARENTTYPES 
		       GLTRANSPB GLUNITOP GLUNIT? GLUNWRAP GLUNWRAPCOND 
		       GLUNWRAPPROG GLUNWRAPSELECTQ GLUSERFN GLUSERFNB 
		       GLVALUE GLVARTYPE GLXTRTYPE)
	(P (GLINIT))
	(FILES (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
	       LAMBDATRAN)
	(ADDVARS (LAMBDASPLST GLAMBDA)
		 (LAMBDATRANFNS (GLAMBDA GLAMBDATRAN EXPR NIL)))
	(GLOBALVARS GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS 
		    GLTYPENAMES GLBREAKONERROR)
	(SPECVARS CONTEXT START EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR 
		  GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS 
		  GLEXPR DESLIST EXPRSTACK)
	(VARS GLTYPENAMES)
	(FILEPKGCOMS GLISPOBJECTS)
	(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
		  (ADDVARS (NLAMA GLDEFSTRQ)
			   (NLAML)
			   (LAMA])
(DEFINEQ

(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])

(GLADDRESULTTYPE
  [LAMBDA (SDES)                                             (* "GSN: " "25-Jan-81 18:17")
                                                             (* Add the type SDES to RESULTTYPE in GLCOMP)
    (COND
      ((NULL RESULTTYPE)
	(SETQ RESULTTYPE SDES))
      [(AND (LISTP RESULTTYPE)
	    (EQ (CAR RESULTTYPE)
		(QUOTE OR)))
	(COND
	  ((NOT (MEMBER SDES (CDR RESULTTYPE)))
	    (NCONC1 RESULTTYPE SDES]
      ((NOT (EQUAL SDES RESULTTYPE))
	(SETQ RESULTTYPE (LIST (QUOTE OR)
			       RESULTTYPE SDES])

(GLADDSTR
  [LAMBDA (ATM NAME STR CONTEXT)                             (* "GSN: " " 2-Jan-81 13:37")

          (* Add an entry to the current context for a variable ATM, whose NAME in context is given, and which has structure
	  STR. The entry is pushed onto the front of the list at the head of the context.)

                                                             (* edited: "30-Sep-80 18:04")
    (RPLACA CONTEXT (CONS (LIST ATM NAME STR)
			  (CAR CONTEXT])

(GLADJ
  [LAMBDA (SOURCE PROPERTY ADJWD)                            (* edited: " 6-JAN-82 14:06")
                                                             (* "GSN: " "17-Sep-81 13:58")
                                                             (* "Compile code to test if SOURCE is PROPERTY.")
    (PROG (ADJL TMP TRANS TMP FETCHCODE)
          (COND
	    [(EQ ADJWD (QUOTE ISASELF))
	      (COND
		((SETQ ADJL (GLSTRPROP PROPERTY (QUOTE ISA)
				       (QUOTE self)))
		  (GO A))
		(T (RETURN]
	    ((SETQ ADJL (GLSTRPROP (CADR SOURCE)
				   ADJWD PROPERTY))
	      (GO A)))                                       (* See if the adjective can be found in a TRANSPARENT 
							     substructure.)
          (SETQ TRANS (GLTRANSPARENTTYPES (CADR SOURCE)))
      B   (COND
	    ((NULL TRANS)
	      (RETURN))
	    ((SETQ TMP (GLADJ (LIST (QUOTE *GL*)
				    (GLXTRTYPE (CAR TRANS)))
			      PROPERTY ADJWD))
	      (SETQ FETCHCODE (GLSTRFN (CAR TRANS)
				       (CADR SOURCE)
				       NIL))
	      (GLSTRVAL TMP (CAR FETCHCODE))
	      (GLSTRVAL TMP (CAR SOURCE))
	      (RETURN TMP))
	    (T (SETQ TRANS (CDR TRANS))
	       (GO B)))
      A   (COND
	    ([AND (LISTP (CADR ADJL))
		  (MEMB (CAADR ADJL)
			(QUOTE (NOT Not not)))
		  (ATOM (CADADR ADJL))
		  (NULL (CDDADR ADJL))
		  (SETQ TMP (GLSTRPROP (CADR SOURCE)
				       ADJWD
				       (CADADR ADJL]
	      (SETQ ADJL TMP)
	      (SETQ NOTFLG (NOT NOTFLG))
	      (GO A)))
          (RETURN (GLCOMPMSG SOURCE ADJL NIL CONTEXT])

(GLAMBDATRAN
  [LAMBDA (GLEXPR)                                           (* edited: "30-NOV-81 14:54")
                                                             (* "GSN: " "21-Sep-81 16:19")
                                                             (* "GSN: " "30-Dec-80 14:36")

          (* This function is called when a GLAMBDA function is found by the interpreter. If the function definition is 
	  available on the property GLCOMPILED, that definition is returned; otherwise, GLCOMP is called to compile the 
	  function.)


    (PROG (NEWEXPR)
          (SAVEDEF FAULTFN)
          (PUTPROP FAULTFN (QUOTE GLCOMPILED)
		   (SETQ NEWEXPR (GLCOMP FAULTFN GLEXPR)))
          (PUTHASH (GETD FAULTFN)
		   NEWEXPR CLISPARRAY)
          (RETURN NEWEXPR])

(GLANDFN
  [LAMBDA (LHS RHS)                                          (* edited: " 4-JAN-82 14:36")
                                                             (* "GSN: " " 8-Jan-81 17:04")
                                                             (* AND operator)
    (COND
      ((NULL LHS)
	RHS)
      ((NULL RHS)
	LHS)
      ((AND (LISTP (CAR LHS))
	    (EQ (CAAR LHS)
		(QUOTE AND))
	    (LISTP (CAR RHS))
	    (EQ (CAAR RHS)
		(QUOTE AND)))
	(LIST (APPEND (CAR LHS)
		      (CDAR RHS))
	      (CADR LHS)))
      ((AND (LISTP (CAR LHS))
	    (EQ (CAAR LHS)
		(QUOTE AND)))
	(LIST (APPEND (CAR LHS)
		      (LIST (CAR RHS)))
	      (CADR LHS)))
      ((AND (LISTP (CAR RHS))
	    (EQ (CAAR RHS)
		(QUOTE AND)))
	(LIST (CONS (QUOTE AND)
		    (CONS (CAR LHS)
			  (CDAR RHS)))
	      (CADR LHS)))
      (T (LIST (LIST (QUOTE AND)
		     (CAR LHS)
		     (CAR RHS))
	       (CADR RHS])

(GLATMSTR?
  [LAMBDA (STR)                                              (* edited: "16-DEC-81 18:08")
                                                             (* "GSN: " "14-Sep-81 12:45")
    (PROG (TMP)
          (COND
	    ((OR (AND (CDR STR)
		      (NLISTP (CADR STR)))
		 (AND (CDDR STR)
		      (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])

(GLBUILDALIST
  [LAMBDA (ALIST PREVLST)                                    (* edited: " 4-JAN-82 11:42")
                                                             (* "GSN: " "15-Sep-81 13:24")
                                                             (* "GSN: " "14-Sep-81 12:25")
                                                             (* "GSN: " "13-Aug-81 13:34")
    (PROG (STR LIS TMP1 TMP2)
      A   [COND
	    ((NULL ALIST)
	      (RETURN (AND LIS (GLBUILDLIST LIS]
          (SETQ TMP1 (pop ALIST))
          [COND
	    ((SETQ TMP2 (GLBUILDSTR TMP1 PAIRLIST PREVLST))
	      (SETQ LIS (NCONC1 LIS (GLBUILDCONS (KWOTE (CAR TMP1))
						 TMP2 T]
          (GO A])

(GLBUILDCONS
  [LAMBDA (X Y OPTFLG)                                       (* edited: " 4-JAN-82 12:43")
                                                             (* "GSN: " "15-Sep-81 13:09")
                                                             (* Generate code to build a CONS structure.)
    (COND
      ((NULL Y)
	(GLBUILDLIST (LIST X)
		     OPTFLG))
      ((AND (LISTP Y)
	    (EQ (CAR Y)
		(QUOTE LIST)))
	(GLBUILDLIST (CONS X (CDR Y))
		     OPTFLG))
      [(AND OPTFLG (GLCONST? X)
	    (GLCONST? Y))
	(LIST (QUOTE QUOTE)
	      (CONS (GLCONSTVAL X)
		    (GLCONSTVAL Y]
      [(AND OPTFLG (GLCONSTSTR? X)
	    (GLCONSTSTR? Y))
	(LIST (QUOTE COPY)
	      (LIST (QUOTE QUOTE)
		    (CONS (GLCONSTVAL X)
			  (GLCONSTVAL Y]
      (T (LIST (QUOTE CONS)
	       X Y])

(GLBUILDLIST
  [LAMBDA (LST OPTFLG)                                       (* edited: " 1-DEC-81 11:20")
                                                             (* "GSN: " "15-Sep-81 13:18")
                                                             (* 
							     
"Build a LIST structure, possibly doing compile-time constant
folding.")
    (COND
      [(EVERY LST (FUNCTION GLCONST?))
	(COND
	  [OPTFLG (LIST (QUOTE QUOTE)
			(MAPCAR LST (FUNCTION GLCONSTVAL]
	  (T (LIST (QUOTE APPEND)
		   (LIST (QUOTE QUOTE)
			 (MAPCAR LST (FUNCTION GLCONSTVAL]
      [(EVERY LST (FUNCTION GLCONSTSTR?))
	(LIST (QUOTE COPY)
	      (LIST (QUOTE QUOTE)
		    (MAPCAR LST (FUNCTION GLCONSTVAL]
      (T (CONS (QUOTE LIST)
	       LST])

(GLBUILDNOT
  [LAMBDA (CODE)                                             (* edited: "30-NOV-81 13:42")
                                                             (* 
							     
"Build code to do (NOT CODE), doing compile-time folding
if possible.")
    (PROG (TMP)
          (COND
	    [(GLCONST? CODE)
	      (RETURN (NOT (GLCONSTVAL CODE]
	    ((NLISTP CODE)
	      (RETURN (LIST (QUOTE NOT)
			    CODE)))
	    ((EQ (CAR CODE)
		 (QUOTE NOT))
	      (RETURN (CADR CODE)))
	    ((NOT (ATOM (CAR CODE)))
	      (RETURN))
	    [[SETQ TMP (FASSOC (CAR CODE)
			       (QUOTE ((LISTP . NLISTP)
					(EQ . NEQ)
					(NEQ . EQ)
					(IGREATERP . ILEQ)
					(ILEQ . IGREATERP)
					(ILESSP . IGEQ)
					(IGEQ . ILESSP)
					(GREATERP . LEQ)
					(LEQ . GREATERP)
					(LESSP . GEQ)
					(GEQ . LESSP]
	      (RETURN (CONS (CDR TMP)
			    (CDR CODE]
	    (T (RETURN (LIST (QUOTE NOT)
			     CODE])

(GLBUILDSTR
  [LAMBDA (STR PAIRLIST PREVLST)                             (* edited: "25-JAN-82 17:00")
                                                             (* "GSN: " " 5-Oct-81 13:23")
                                                             (* "GSN: " "15-Sep-81 13:36")
                                                             (* "GSN: " "14-Sep-81 13:00")
                                                             (* "GSN: " "13-Aug-81 14:06")

          (* Generate code to build a structure according to the structure description STR. PAIRLIST is a list of elements 
	  of the form (SLOTNAME CODE TYPE) for each named slot to be filled in in the structure. (PREVLST is a list of 
	  structures of which this is a substructure, to prevent loops.))


    (DECLARE (SPECVARS PAIRLIST PROGG))
    (PROG [ATOMNAME PROPLIS TEMP PROGG TMPCODE (ATMSTR (QUOTE ((ATOM)
								(INTEGER . 0)
								(REAL . 0.0)
								(NUMBER . 0)
								(BOOLEAN)
								(NIL)
								(ANYTHING]
          (COND
	    ((NULL STR)
	      (RETURN))
	    [(ATOM STR)
	      (COND
		((SETQ TEMP (ASSOC STR ATMSTR))
		  (RETURN (CDR TEMP)))
		((MEMB STR PREVLST)
		  (RETURN))
		[(SETQ TEMP (GLGETSTR STR))
		  (RETURN (GLBUILDSTR TEMP NIL (CONS STR PREVLST]
		(T (RETURN]
	    ((NLISTP STR)
	      (GLERROR (QUOTE GLBUILDSTR)
		       (LIST "Illegal structure type encountered:" STR))
	      (RETURN)))
          (SELECTQ (CAR STR)
		   (CONS (RETURN (GLBUILDCONS (GLBUILDSTR (CADR STR)
							  PAIRLIST PREVLST)
					      (GLBUILDSTR (CADDR STR)
							  PAIRLIST PREVLST)
					      T)))
		   [LIST (RETURN (GLBUILDLIST (MAPCAR (CDR STR)
						      (FUNCTION (LAMBDA (X)
							  (GLBUILDSTR X PAIRLIST PREVLST]
		   (ALIST (RETURN (GLBUILDALIST (CDR STR)
						PREVLST)))
		   (ATOM [SETQ PROGG (COPY (QUOTE (PROG (ATOMNAME)
							(SETQ ATOMNAME (GENSYM]
			 [COND
			   ((SETQ TEMP (ASSOC (QUOTE BINDING)
					      STR))
			     (SETQ TMPCODE (GLBUILDSTR (CADR TEMP)
						       PAIRLIST PREVLST))
			     (NCONC1 PROGG (LIST (QUOTE SET)
						 (QUOTE ATOMNAME)
						 TMPCODE]
			 (COND
			   ((SETQ PROPLIS (CDR (ASSOC (QUOTE PROPLIST)
						      STR)))
			     (GLPUTPROPS PROPLIS PREVLST)))
			 [NCONC1 PROGG (COPY (QUOTE (RETURN ATOMNAME]
			 (RETURN PROGG))
		   [TRANSPARENT (RETURN (AND (NOT (MEMB (CADR STR)
							PREVLST))
					     (SETQ TEMP (GLGETSTR (CADR STR)))
					     (GLBUILDSTR TEMP PAIRLIST (CONS (CADR STR)
									     PREVLST]
		   (LISTOF NIL)
		   [(RECORD TYPERECORD ASSOCRECORD PROPRECORD ARRAYRECORD HASHLINK DATATYPE 
			    ATOMRECORD)
		     (RETURN (CONS (QUOTE create)
				   (CONS (CADR STR)
					 (MAPCONC (CDDR STR)
						  (FUNCTION (LAMBDA (X)
						      (AND (SETQ TEMP (GLBUILDSTR X PAIRLIST PREVLST))
							   (LIST (CAR X)
								 (QUOTE _)
								 TEMP]
		   (COND
		     [(ATOM (CAR STR))
		       (COND
			 ((SETQ TEMP (ASSOC (CAR STR)
					    PAIRLIST))
			   (RETURN (CADR TEMP)))
			 ((AND (ATOM (CADR STR))
			       (NOT (ASSOC (CADR STR)
					   ATMSTR)))
			   (RETURN (GLBUILDSTR (CADR STR)
					       NIL PREVLST)))
			 (T (RETURN (GLBUILDSTR (CADR STR)
						PAIRLIST PREVLST]
		     (T (RETURN])

(GLCARCDR?
  [LAMBDA (X)                                                (* edited: "13-JAN-82 13:45")
                                                             (* Test if X is a CAR or CDR combination up to 3 long.)
    (FMEMB X (QUOTE (CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR])

(GLCOMP
  [LAMBDA (GLAMBDAFN GLEXPR)                                 (* edited: "25-JAN-82 17:03")
                                                             (* "GSN: " "13-Aug-81 14:19")
                                                             (* "GSN: " " 1-Jun-81 16:01")
                                                             (* "GSN: " "21-Apr-81 11:22")

          (* GLISP compiler function. GLAMBDAFN is the atom whose function definition is being compiled;
	  GLEXPR is the GLAMBDA expression to be compiled. The compiled function is saved on the property list of GLAMBDAFN 
	  under the indicator GLCOMPILED. The property GLRESULTTYPE is the RESULT declaration, if specified;
	  GLGLOBALS is a list of global variables referenced and their types.)


    (PROG (NEWARGS NEWEXPR GLNATOM GLTOPCTX PROGFLG PROGLST RESULTTYPE GLGLOBALVARS RESULT GLSEPATOM
		   (GLSEPPTR 0)
		   VALBUSY EXPRSTACK)
          [COND
	    ((NOT GLQUIETFLG)
	      (PRINT (LIST (QUOTE GLCOMP)
			   GLAMBDAFN]
          (SETQ EXPRSTACK (LIST GLEXPR))
          (SETQ GLNATOM 0)
          (SETQ GLTOPCTX (LIST NIL))                         (* Process the argument list of the GLAMBDA.)
          (SETQ NEWARGS (GLDECL (CADR GLEXPR)
				T NIL GLTOPCTX))             (* See if there is a RESULT declaration.)
          (SETQ GLEXPR (CDDR GLEXPR))
          (GLSKIPCOMMENTS)
          [COND
	    ([AND (LISTP (CAR GLEXPR))
		  (MEMB (CAAR GLEXPR)
			(QUOTE (RESULT Result result]
	      (COND
		((AND (GLOKSTR? (CADAR GLEXPR))
		      (NULL (CDDAR GLEXPR)))
		  (SETQ RESULTTYPE (CADAR GLEXPR))
		  (pop GLEXPR))
		(T (GLERROR (QUOTE GLCOMP)
			    (LIST "Bad RESULT declaration:" (CAR GLEXPR)))
		   (pop GLEXPR]
          (GLSKIPCOMMENTS)
          (COND
	    ([AND (LISTP (CAR GLEXPR))
		  (MEMB (CAAR GLEXPR)
			(QUOTE (GLOBAL Global global]
	      (SETQ GLGLOBALVARS (GLDECL (CDAR GLEXPR)
					 NIL NIL GLTOPCTX))
	      (PUTPROP GLAMBDAFN (QUOTE GLGLOBALS)
		       GLGLOBALVARS)
	      (pop GLEXPR)))
          (SETQ VALBUSY (NULL (CDR GLEXPR)))
          (SETQ NEWEXPR (GLPROGN GLEXPR (CONS NIL GLTOPCTX)))
          (PUTPROP GLAMBDAFN (QUOTE GLRESULTTYPE)
		   (OR RESULTTYPE (CADR NEWEXPR)))
          [SETQ RESULT (CONS (QUOTE LAMBDA)
			     (CONS NEWARGS (CAR NEWEXPR]
          (RETURN (GLUNWRAP RESULT T])

(GLCOMPCOMS
  [LAMBDA (COMSLIST PRINTFLG)                                (* edited: "30-DEC-81 13:25")
                                                             (* Compile all the GLAMBDA funtions on a COMS list.)
    (PROG (FNS)
      LP  [COND
	    ((NULL COMSLIST)
	      (RETURN))
	    ((NLISTP (CAR COMSLIST)))
	    ((EQ (CAAR COMSLIST)
		 (QUOTE FNS))
	      [SETQ FNS (COND
		  ((EQ (CADAR COMSLIST)
		       (QUOTE *))
		    (EVAL (CADDAR COMSLIST)))
		  (T (CDAR COMSLIST]
	      (MAPC FNS (FUNCTION (LAMBDA (X)
			(COND
			  ((EQ (CAR (GLGETD X))
			       (QUOTE GLAMBDA))
			    (GLCOMPILE X)
			    (COND
			      (PRINTFLG (PROG (SAVE)
					      (SETQ SAVE SYSPRETTYFLG)
					      (SETQ SYSPRETTYFLG T)
					      (TERPRI)
					      (TERPRI)
					      (TERPRI)
					      (PRINT X)
					      (SHOWPRINT (GLGETD X))
					      (TERPRI)
					      (SHOWPRINT (GETPROP X (QUOTE GLCOMPILED)))
					      (SETQ SYSPRETTYFLG SAVE]
          (SETQ COMSLIST (CDR COMSLIST))
          (GO LP])

(GLCOMPILE
  [LAMBDA (FAULTFN)                                          (* edited: "13-JAN-82 16:02")
                                                             (* "GSN: " "26-Jun-81 11:00")
                                                             (* 
							     
"Compile the function definition stored for the atom FAULTFN using
the GLISP compiler.")
    (GLAMBDATRAN (GLGETD FAULTFN))
    FAULTFN])

(GLCOMPMSG
  [LAMBDA (OBJECT MSGLST ARGLIST CONTEXT)                    (* edited: "25-JAN-82 17:06")
                                                             (* Compile a Message. MSGLST is the Message list, 
							     consisting of message selector, code, and properties 
							     defined with the message.)
    (DECLARE (SPECVARS GLPROGLST))
    (PROG (GLPROGLST RESULTTYPE METHOD RESULT)
          (SETQ RESULTTYPE (LISTGET (CDDR MSGLST)
				    (QUOTE RESULT)))
          (SETQ METHOD (CADR MSGLST))
          [COND
	    [(ATOM METHOD)                                   (* Function name is specified.)
	      (COND
		[(LISTGET (CDDR MSGLST)
			  (QUOTE OPEN))
		  (RETURN (GLCOMPOPEN METHOD (CONS OBJECT ARGLIST)
				      (CONS (CADR OBJECT)
					    (LISTGET (CDDR MSGLST)
						     (QUOTE ARGTYPES)))
				      CONTEXT RESULTTYPE (LISTGET (CDDR MSGLST)
								  (QUOTE SPECVARS]
		(T (RETURN (LIST [CONS METHOD (CONS (CAR OBJECT)
						    (MAPCAR ARGLIST (FUNCTION CAR]
				 (OR [GLRESULTTYPE METHOD (CONS (CADR OBJECT)
								(MAPCAR ARGLIST
									(FUNCTION CADR]
				     (LISTGET (CDDR MSGLST)
					      (QUOTE RESULT]
	    ((NLISTP METHOD)
	      (RETURN (GLERROR (QUOTE GLCOMPMSG)
			       (LIST "The form of Response is illegal for message" (CAR MSGLST]
                                                             (* The Method is a list of stuff to be compiled open.)
          (SETQ CONTEXT (LIST NIL))
          (COND
	    ((ATOM (CAR OBJECT))
	      (GLADDSTR (LIST (QUOTE PROG1)
			      (CAR OBJECT))
			(QUOTE self)
			(CADR OBJECT)
			CONTEXT))
	    ((AND (LISTP (CAR OBJECT))
		  (EQ (CAAR OBJECT)
		      (QUOTE PROG1))
		  (ATOM (CADAR OBJECT))
		  (NULL (CDDAR OBJECT)))
	      (GLADDSTR (CAR OBJECT)
			(QUOTE self)
			(CADR OBJECT)
			CONTEXT))
	    (T (SETQ GLPROGLST (CONS (LIST (QUOTE self)
					   (CAR OBJECT))
				     GLPROGLST))
	       (GLADDSTR (QUOTE self)
			 NIL
			 (CADR OBJECT)
			 CONTEXT)))
          (SETQ RESULT (GLPROGN METHOD CONTEXT))             (* If more than one expression resulted, embed in a 
							     PROGN.)
          [RPLACA RESULT (COND
		    ((CDAR RESULT)
		      (CONS (QUOTE PROGN)
			    (CAR RESULT)))
		    (T (CAAR RESULT]
          (RETURN (LIST (COND
			  [GLPROGLST (LIST (QUOTE PROG)
					   GLPROGLST
					   (LIST (QUOTE RETURN)
						 (CAR RESULT]
			  (T (CAR RESULT)))
			(OR (CADR RESULT)
			    RESULTTYPE])

(GLCOMPOPEN
  [LAMBDA (FN ARGS ARGTYPES CONTEXT RESULTTYPE SPCVARS)      (* edited: "22-DEC-81 12:39")

          (* Compile the function FN Open, given as arguments ARGS with argument types ARGTYPES. Types may be defined in the
	  definition of function FN (which may be either a GLAMBDA or LAMBDA function) or by ARGTYPES;
	  ARGTYPES takes precedence.)


    (DECLARE (SPECVARS GLPROGLST))
    (PROG (PTR FNDEF OLDCONTEXT GLPROGLST NEWEXPR)           (* Put a new level on top of CONTEXT.)
          (SETQ OLDCONTEXT CONTEXT)
          (SETQ CONTEXT (LIST NIL))
          (SETQ FNDEF (GLGETD FN))                           (* Get the parameter declarations and add to CONTEXT.)
          (GLDECL (CADR FNDEF)
		  T NIL CONTEXT)                             (* Make the function parameters into "names" and put in 
							     the values, hiding any which are simple variables.)
          (SETQ PTR (DREVERSE (CAR CONTEXT)))
          (RPLACA CONTEXT NIL)
      LP  (COND
	    ((NULL PTR)
	      (GO B)))
          (COND
	    ((AND (ATOM (CAAR ARGS))
		  (NEQ SPCVARS T)
		  (NOT (MEMB (CAAR PTR)
			     SPCVARS)))                      (* Wrap the atom in a PROG1 so it won't match as a name;
							     the PROG1 will generally be stripped later.)
	      (GLADDSTR (LIST (QUOTE PROG1)
			      (CAAR ARGS))
			(CAAR PTR)
			(OR (CADDAR PTR)
			    (CADAR ARGS)
			    (CAR ARGTYPES))
			CONTEXT))
	    ((AND (NEQ SPCVARS T)
		  (NOT (MEMB (CAAR PTR)
			     SPCVARS))
		  (LISTP (CAAR ARGS))
		  (EQ (CAAAR ARGS)
		      (QUOTE PROG1))
		  (ATOM (CADAAR ARGS))
		  (NULL (CDDAAR ARGS)))
	      (GLADDSTR (CAAR ARGS)
			(CAAR PTR)
			(OR (CADDAR PTR)
			    (CADAR ARGS)
			    (CAR ARGTYPES))
			CONTEXT))
	    (T                                               (* Since the actual argument is not atomic, make a PROG 
							     variable for it.)
	       (SETQ GLPROGLST (CONS (LIST (CAAR PTR)
					   (CAAR ARGS))
				     GLPROGLST))
	       (GLADDSTR (CAAR PTR)
			 (CADAR PTR)
			 (OR (CADDAR PTR)
			     (CADAR ARGS)
			     (CAR ARGTYPES))
			 CONTEXT)))
          (SETQ PTR (CDR PTR))
          (SETQ ARGS (CDR ARGS))
          (SETQ ARGTYPES (CDR ARGTYPES))
          (GO LP)
      B   (SETQ FNDEF (CDDR FNDEF))                          (* Get rid of comments at start of function.)
      C   (COND
	    ((AND FNDEF (LISTP (CAR FNDEF))
		  (EQ (CAAR FNDEF)
		      (QUOTE *)))
	      (SETQ FNDEF (CDR FNDEF))
	      (GO C)))
          (SETQ NEWEXPR (GLPROGN FNDEF CONTEXT))             (* Get rid of atomic result if it isnt busy outside.)
          (COND
	    ([AND (NOT VALBUSY)
		  (CDAR EXPR)
		  (OR [ATOM (CADR (SETQ PTR (NLEFT (CAR NEWEXPR)
						   2]
		      (AND (LISTP (CADR PTR))
			   (EQ (CAADR PTR)
			       (QUOTE PROG1))
			   (ATOM (CADADR PTR))
			   (NULL (CDDADR PTR]
	      (RPLACD PTR NIL)))
          [SETQ RESULT (LIST (COND
			       [GLPROGLST (SETQ PTR (LAST (CAR NEWEXPR)))
					  (RPLACA PTR (LIST (QUOTE RETURN)
							    (CAR PTR)))
					  (CONS (QUOTE PROG)
						(CONS (DREVERSE GLPROGLST)
						      (CAR NEWEXPR]
			       ((CDAR NEWEXPR)
				 (CONS (QUOTE PROGN)
				       (CAR NEWEXPR)))
			       (T (CAAR NEWEXPR)))
			     (OR (CADR NEWEXPR)
				 RESULTTYPE
				 (GLRESULTTYPE FN]
          (RETURN RESULT])

(GLCONST?
  [LAMBDA (X)                                                (* edited: " 4-JAN-82 11:41")
                                                             (* "GSN: " "15-Sep-81 13:12")
                                                             (* 
							     
"Test X to see if it represents a compile-time constant value.")
    (OR (NULL X)
	(NUMBERP X)
	(AND (LISTP X)
	     (EQ (CAR X)
		 (QUOTE QUOTE])

(GLCONSTSTR?
  [LAMBDA (X)                                                (* edited: " 1-DEC-81 11:11")
                                                             (* Test to see if X is a constant structure.)
    (OR (GLCONST? X)
	(AND (LISTP X)
	     (OR (EQ (CAR X)
		     (QUOTE QUOTE))
		 (AND (MEMB (CAR X)
			    (QUOTE (COPY APPEND)))
		      (LISTP (CADR X))
		      (EQ (CAADR X)
			  (QUOTE QUOTE])

(GLCONSTVAL
  [LAMBDA (X)                                                (* edited: " 1-DEC-81 11:13")
                                                             (* "GSN: " "15-Sep-81 13:14")
                                                             (* "Get the value of a compile-time constant")
    (COND
      ((NULL X)
	NIL)
      ((NUMBERP X)
	X)
      ((AND (LISTP X)
	    (EQ (CAR X)
		(QUOTE QUOTE)))
	(CADR X))
      ((AND (LISTP X)
	    (MEMB (CAR X)
		  (QUOTE (COPY APPEND)))
	    (LISTP (CADR X))
	    (EQ (CAADR X)
		(QUOTE QUOTE)))
	(CADADR X))
      (T (ERROR])

(GLDECL
  [LAMBDA (LST NOVAROK VALOK GLTOPCTX)                       (* edited: "25-JAN-82 17:09")
                                                             (* "GSN: " " 1-Jun-81 16:02")
                                                             (* "GSN: " "24-Apr-81 12:02")
                                                             (* "GSN: " "21-Apr-81 11:24")

          (* Process a declaration list from a GLAMBDA expression. Each element of the list is of the form <var>, 
	  <var>:<str-descr>, :<str-descr>, or <var>: (A <str-descr>) or (A <str-descr>). Forms without a variable are 
	  accepted only if NOVAROK is true. If VALOK is true, a PROG form (variable value) is allowed.
	  The result is a list of variable names.)


    (PROG (RESULT FIRST SECOND THIRD TOP TMP EXPR VARS STR)
      A                                                      (* Get the next variable/description from LST)
          [COND
	    ((NULL LST)
	      (RETURN (DREVERSE RESULT]
          (SETQ TOP (pop LST))
          (COND
	    ((NOT (ATOM TOP))
	      (GO B)))
          (SETQ VARS NIL)
          (SETQ STR NIL)
          (GLSEPINIT TOP)
          (SETQ FIRST (GLSEPNXT))
          (SETQ SECOND (GLSEPNXT))
          [COND
	    ((EQ FIRST (QUOTE :))
	      (COND
		[(NULL SECOND)
		  (COND
		    ((AND NOVAROK LST (GLOKSTR? (CAR LST)))
		      (GLDECLDS (GLMKVAR)
				(pop LST))
		      (GO A))
		    (T (GO E]
		((AND NOVAROK (GLOKSTR? SECOND)
		      (NULL (GLSEPNXT)))
		  (GLDECLDS (GLMKVAR)
			    SECOND)
		  (GO A))
		(T (GO E]
      D                                                      (* At least one variable name has been found.
							     Collect other variable names until a <type> is found.)
          (SETQ VARS (NCONC1 VARS FIRST))
          (COND
	    ((NULL SECOND)
	      (GO C))
	    [(EQ SECOND (QUOTE :))
	      (COND
		((AND (SETQ THIRD (GLSEPNXT))
		      (GLOKSTR? THIRD)
		      (NULL (GLSEPNXT)))
		  (SETQ STR THIRD)
		  (GO C))
		((AND (NULL THIRD)
		      (GLOKSTR? (CAR LST)))
		  (SETQ STR (pop LST))
		  (GO C))
		(T (GO E]
	    [(EQ SECOND (QUOTE ,))
	      (COND
		((SETQ FIRST (GLSEPNXT))
		  (SETQ SECOND (GLSEPNXT))
		  (GO D))
		((ATOM (CAR LST))
		  (GLSEPINIT (pop LST))
		  (SETQ FIRST (GLSEPNXT))
		  (SETQ SECOND (GLSEPNXT))
		  (GO D]
	    (T (GO E)))
      C                                                      (* Define the <type> for each variable on VARS.)
          [MAPC VARS (FUNCTION (LAMBDA (X)
		    (GLDECLDS X STR]
          (GO A)
      B                                                      (* The top of LST is non-atomic.
							     Must be either (A <type>) or 
							     (<var> <value>).)
          (COND
	    ((AND (GL-A-AN? (CAR TOP))
		  NOVAROK
		  (GLOKSTR? TOP))
	      (GLDECLDS (GLMKVAR)
			TOP))
	    [(AND VALOK (NOT (GL-A-AN? (CAR TOP)))
		  (ATOM (CAR TOP))
		  (CDR TOP))
	      (SETQ EXPR (CDR TOP))
	      (SETQ TMP (GLDOEXPR NIL GLTOPCTX T))
	      (COND
		(EXPR (GO E)))
	      (GLADDSTR (CAR TOP)
			NIL
			(CADR TMP)
			GLTOPCTX)
	      (push RESULT (LIST (CAR TOP)
				 (CAR TMP]
	    (T (GO E)))
          (GO A)
      E   (GLERROR (QUOTE GLDECL)
		   (LIST "Bad argument structure" LST))
          (RETURN])

(GLDECLDS
  [LAMBDA (ATM STR)                                          (* "GSN: " " 2-Jan-81 13:39")
                                                             (* Add ATM to the RESULT list of GLDECL, and declare its
							     structure.)
    (PROG NIL
          (push RESULT ATM)
          (GLADDSTR ATM NIL STR GLTOPCTX])

(GLDEFPROP
  [LAMBDA (OBJECT PROP LST)                                  (* edited: "25-JAN-82 17:15")
                                                             (* "GSN: " "18-Sep-81 15:41")
                                                             (* 
							     
"Define properties for an object type.  Each property is of the
form (<propname> (<definition>) (TYPE <type>) (TOSET <code>)).
TYPE and TOSET are optional.")
    (PROG (LSTP)
          [MAPC LST (FUNCTION (LAMBDA (X)
		    (COND
		      ((OR (NLISTP X)
			   (NOT (ATOM (CAR X)))
			   (NULL (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)                                              (* edited: "25-JAN-82 17:19")
                                                             (* "GSN: " "23-Sep-81 19:20")
                                                             (* "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)
          (SETQ STRNAME (pop LST))
          (PUTPROP STRNAME (QUOTE GLSTRUCTURE)
		   (LIST (pop LST)))                         (* 
							     
"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)))
		   (PROGN (PRIN1 "For structure ")
			  (PRIN1 STRNAME)
			  (PRIN1 " the unknown property name ")
			  (PRIN1 (CAR LST))
			  (PRIN1 " is used.  Ignored.")
			  (TERPRI)))
          (SETQ LST (CDDR LST))
          (GO LP])

(GLDEFSTRQ
  [NLAMBDA ARGS                                              (* "GSN: " "17-Sep-81 11:44")
                                                             (* "GSN: " "24-Apr-81 12:09")
                                                             (* "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)


    (for ARG in ARGS do (GLDEFSTR ARG])

(GLDEFUNITPKG
  [LAMBDA (UNITREC)                                          (* "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)                                        (* edited: "30-OCT-81 12:23")
                                                             (* Remove the GLISP structure definition for NAME.)
    (REMPROP NAME (QUOTE GLSTRUCTURE])

(GLDOA
  [LAMBDA (EXPR)                                             (* edited: "25-JAN-82 17:22")
                                                             (* "GSN: " "13-Aug-81 13:39")
                                                             (* "GSN: " "25-Jun-81 15:26")
                                                             (* 
							     
"Function to compile an expression of the form (A <type> ...)")
    (PROG (TYPE UNITREC TMP)
          (SETQ TYPE (CADR EXPR))
          (COND
	    [(GLGETSTR TYPE)
	      (RETURN (GLMAKESTR TYPE (CDDR EXPR]
	    ([AND (SETQ UNITREC (GLUNIT? TYPE))
		  (SETQ TMP (ASSOC (QUOTE A)
				   (CADDR UNITREC]
	      (RETURN (APPLY* (CDR TMP)
			      EXPR)))
	    (T (GLERROR (QUOTE GLDOA)
			(LIST "The type" TYPE "is not defined."])

(GLDOCOND
  [LAMBDA (CONDEXPR)                                         (* "GSN: " "21-Apr-81 11:24")
                                                             (* Compile a COND expression.)
    (LIST [CONS (QUOTE COND)
		(MAPCAR (CDR CONDEXPR)
			(FUNCTION (LAMBDA (X)
			    (CAR (GLPROGN X CONTEXT]
	  NIL])

(GLDOEXPR
  [LAMBDA (START CONTEXT VALBUSY)                            (* edited: "25-JAN-82 16:10")
                                                             (* "GSN: " "23-Sep-81 17:08")
                                                             (* "GSN: " "24-Aug-81 13:25")
                                                             (* "GSN: " "19-Jun-81 17:03")
                                                             (* "GSN: " "23-Apr-81 10:53")

          (* Compile a single expression. START is set if EXPR is the start of a new expression, i.e., if EXPR might be a 
	  function call. The global variable EXPR is the expression, CONTEXT the context in which it is compiled.
	  VALBUSY is T if the value of the expression is needed outside the expression. The value is a list of the new 
	  expression and its value-description.)


    (PROG (FIRST TMP RESULT)
          (SETQ EXPRSTACK (CONS EXPR EXPRSTACK))
          (COND
	    ((NLISTP EXPR)
	      (GLERROR (QUOTE GLDOEXPR)
		       (LIST "Expression is not a list."))
	      (GO OUT))
	    ((AND (NOT START)
		  (STRINGP (CAR EXPR)))
	      (SETQ RESULT (LIST (PROG1 (CAR EXPR)
					(SETQ EXPR (CDR EXPR)))
				 (QUOTE STRING)))
	      (GO OUT))
	    ((OR (NOT (LITATOM (CAR EXPR)))
		 (NOT START))
	      (GO A)))

          (* Test the initial atom to see if it is a function name. It is assumed to be a function name if it doesnt contain
	  any GLISP operators and the following atom doesnt start with a GLISP binary operator.)


          (COND
	    ((EQ (CAR EXPR)
		 (QUOTE *))                                  (* INTERLISP Comment -- pass it through)
	      (SETQ RESULT (LIST EXPR NIL))
	      (GO OUT))
	    ((MEMB (CAR EXPR)
		   (QUOTE (QUOTE Quote quote)))
	      (SETQ FIRST (CAR EXPR))                        (* Dont try to do anything with something beginning with
							     QUOTE)
	      (GO B)))
          (GLSEPINIT (CAR EXPR))                             (* See if the initial atom contains an expression 
							     operator.)
          (COND
	    [(NEQ (SETQ FIRST (GLSEPNXT))
		  (CAR EXPR))
	      (COND
		((OR (MEMB (CAR EXPR)
			   (QUOTE (APPLY* BLKAPPLY* PACK* PP*)))
		     (GETD (CAR EXPR))
		     (GETPROP (CAR EXPR)
			      (QUOTE MACRO))
		     (AND (NEQ FIRST (QUOTE ~))
			  (GLOPERATOR? FIRST)))
		  (GLSEPCLR)
		  (SETQ FIRST (CAR EXPR))
		  (GO B))
		(T (GLSEPCLR)
		   (GO A]
	    ([OR (NLISTP (CDR EXPR))
		 (NOT (LITATOM (CADR EXPR]
	      (GO B)))                                       (* See if the initial atom is followed by an expression 
							     operator.)
          (GLSEPINIT (CADR EXPR))
          (SETQ TMP (GLSEPNXT))
          (GLSEPCLR)
          (COND
	    ((GLOPERATOR? TMP)
	      (GO A)))                                       (* The EXPR is a function reference.
							     Test for system functions.)
      B   (SETQ RESULT (SELECTQ FIRST
				((QUOTE Quote quote GO Go go)
				  (LIST EXPR NIL))
				((PROG Prog
				   prog)
				  (GLDOPROG EXPR CONTEXT))
				((FUNCTION Function function)
                                                             (* To be implemented *****)
				  (LIST EXPR (QUOTE LISP)))
				((SETQ Setq setq)
				  (GLDOSETQ EXPR))
				((COND
				    Cond cond)
				  (GLDOCOND EXPR))
				((RETURN Return return)
				  (GLDORETURN EXPR))
				((FOR For for)
				  (GLDOFOR EXPR))
				((THE The the)
				  (GLDOTHE EXPR))
				((IF If if)
				  (GLDOIF EXPR CONTEXT))
				((A a AN An an)
				  (GLDOA EXPR))
				((_ SEND Send send)
				  (GLDOSEND EXPR))
				((PROGN PROG2)
				  (GLDOPROGN EXPR))
				(PROG1 (GLDOPROG1 EXPR))
				(SELECTQ (GLDOSELECTQ EXPR CONTEXT))
				((WHILE While while)
				  (GLDOWHILE EXPR CONTEXT))
				((REPEAT Repeat repeat)
				  (GLDOREPEAT EXPR))
				(GLUSERFN EXPR)))
          (GO OUT)
      A                                                      (* The current EXPR is possibly a GLISP expression.
							     Parse the next subexpression using GLPARSEXPR.)
          (SETQ RESULT (GLPARSEXPR))
      OUT (SETQ EXPRSTACK (CDR EXPRSTACK))
          (RETURN RESULT])

(GLDOFOR
  [LAMBDA (EXPR)                                             (* edited: "13-JAN-82 16:12")
                                                             (* "GSN: " "21-Apr-81 11:25")
                                                             (* Compile code for a FOR loop.)
    (DECLARE (SPECVARS DOMAINNAME))
    (PROG (DOMAIN DOMAINNAME DTYPE ORIGEXPR LOOPVAR NEWCONTEXT LOOPCONTENTS SINGFLAG LOOPCOND 
		  COLLECTCODE VARSLST)
          (SETQ ORIGEXPR EXPR)
          (pop EXPR)                                         (* Parse the forms (FOR EACH <set> ...) and 
							     (FOR <var> IN <set> ...))
          (COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (EACH Each each)))
	      (SETQ SINGFLAG T)
	      (pop EXPR))
	    ([AND (ATOM (CAR EXPR))
		  (MEMB (CADR EXPR)
			(QUOTE (IN In in]
	      (SETQ LOOPVAR (pop EXPR))
	      (pop EXPR))
	    (T (GO X)))                                      (* Now get the <set>)
          (COND
	    ((NULL (SETQ DOMAIN (GLDOMAIN SINGFLAG)))
	      (GO X)))
          (SETQ DTYPE (GLXTRTYPE (CADR DOMAIN)))
          [COND
	    ((NEQ (CAR DTYPE)
		  (QUOTE LISTOF))
	      (OR (EQ [CAR (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE]
		      (QUOTE LISTOF))
		  (GO X]                                     (* Add a level onto the context for the inside of the 
							     loop.)
          (SETQ NEWCONTEXT (CONS NIL CONTEXT))               (* If a loop variable wasnt specified, make one.)
          (OR LOOPVAR (SETQ LOOPVAR (GLMKVAR)))
          (GLADDSTR LOOPVAR DOMAINNAME (CADR DTYPE)
		    NEWCONTEXT)                              (* See if a condition is specified.
							     If so, add it to LOOPCOND.)
          [COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (WITH With with)))
	      (pop EXPR)
	      (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE))
					  NEWCONTEXT NIL NIL)))
	    ((MEMB (CAR EXPR)
		   (QUOTE (WHICH Which which WHO Who who THAT That that)))
	      (pop EXPR)
	      (SETQ LOOPCOND (GLPREDICATE (LIST LOOPVAR (CADR DTYPE))
					  NEWCONTEXT T T]
          [COND
	    ([AND EXPR (MEMB (CAR EXPR)
			     (QUOTE (when When WHEN]
	      (SETQ LOOPCOND (GLANDFN LOOPCOND (GLDOEXPR NIL NEWCONTEXT T]
          [COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (collect Collect COLLECT)))
	      (pop EXPR)
	      (SETQ COLLECTCODE (GLDOEXPR NIL NEWCONTEXT T)))
	    (T (COND
		 ((MEMB (CAR EXPR)
			(QUOTE (DO Do do)))
		   (pop EXPR)))
	       (SETQ LOOPCONTENTS (CAR (GLPROGN EXPR NEWCONTEXT]
          [COND
	    ((NULL COLLECTCODE)
	      (RETURN (LIST [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 [SETQ VARSLST (LIST (CONS (QUOTE <SET>)
					 (CAR DOMAIN))
				   (CONS (QUOTE <LOOPVAR>)
					 LOOPVAR)
				   (CONS (QUOTE <CODE>)
					 (CAR COLLECTCODE))
				   (CONS (QUOTE <CONDITION>)
					 (CAR LOOPCOND]
	       (RETURN (LIST (COND
			       (LOOPCOND (SETQ VARSLST (CONS (CONS (QUOTE <ACCUM>)
								   (GLMKVAR))
							     VARSLST))
					 (SUBLIS VARSLST
						 [QUOTE (PROG (<ACCUM>)
							      [MAPC <SET>
								    (FUNCTION (LAMBDA (<LOOPVAR>)
									(COND
									  (<CONDITION> (DOCOLLECT
									      <CODE> <ACCUM>]
							      (RETURN (ENDCOLLECT <ACCUM>]
						 T))
			       [(AND (LISTP (CAR COLLECTCODE))
				     (ATOM (CAAR COLLECTCODE))
				     (CDAR COLLECTCODE)
				     (EQ (CADAR COLLECTCODE)
					 LOOPVAR)
				     (NULL (CDDAR COLLECTCODE)))
				 (LIST (QUOTE MAPCAR)
				       (CAR DOMAIN)
				       (LIST (QUOTE FUNCTION)
					     (CAAR COLLECTCODE]
			       (T (SUBLIS VARSLST [QUOTE (MAPCAR <SET> (FUNCTION (LAMBDA (<LOOPVAR>)
								     <CODE>]
					  T)))
			     (LIST (QUOTE LISTOF)
				   (CADR COLLECTCODE]
      X   (RETURN (GLUSERFN ORIGEXPR])

(GLDOIF
  [LAMBDA (EXPR CONTEXT)                                     (* edited: "25-JAN-82 17:26")
                                                             (* "GSN: " "14-Aug-81 16:47")
                                                             (* "GSN: " "20-Apr-81 11:07")
                                                             (* Process an IF ... THEN expression.)
    (PROG (PRED ACTIONS CONDLIST TYPE TMP OLDCONTEXT)
          (SETQ OLDCONTEXT CONTEXT)
          (pop EXPR)
      A   [COND
	    ((NULL EXPR)
	      (RETURN (LIST (CONS (QUOTE COND)
				  CONDLIST)
			    TYPE]
          (SETQ CONTEXT (CONS NIL OLDCONTEXT))
          (SETQ PRED (GLPREDICATE NIL CONTEXT NIL T))
          (COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (THEN Then then)))
	      (pop EXPR)))
          (SETQ ACTIONS (CONS (CAR PRED)
			      NIL))
          (SETQ TYPE (CADR PRED))
      C   (SETQ CONDLIST (NCONC1 CONDLIST ACTIONS))
      B   (COND
	    ((NULL EXPR)
	      (GO A))
	    ((MEMB (CAR EXPR)
		   (QUOTE (ELSEIF ElseIf Elseif elseIf elseif)))
	      (pop EXPR)
	      (GO A))
	    ((MEMB (CAR EXPR)
		   (QUOTE (ELSE Else else)))
	      (pop EXPR)
	      (SETQ ACTIONS (CONS T NIL))
	      (SETQ TYPE (QUOTE BOOLEAN))
	      (GO C))
	    ((SETQ TMP (GLDOEXPR NIL CONTEXT T))
	      (NCONC1 ACTIONS (CAR TMP))
	      (SETQ TYPE (CADR TMP))
	      (GO B))
	    (T (GLERROR (QUOTE GLDOIF)
			(LIST "IF statement contains bad code."])

(GLDOLAMBDA
  [LAMBDA (EXPR ARGTYPES CONTEXT)                            (* edited: "16-DEC-81 15:47")
                                                             (* Compile a LAMBDA expression for which the ARGTYPES 
							     are given.)
    (PROG (ARGS NEWEXPR VALBUSY)
          (SETQ ARGS (CADR EXPR))
          (SETQ CONTEXT (CONS NIL CONTEXT))
      LP  (COND
	    (ARGS (GLADDSTR (CAR ARGS)
			    NIL
			    (CAR ARGTYPES)
			    CONTEXT)
		  (SETQ ARGS (CDR ARGS))
		  (SETQ ARGTYPES (CDR ARGTYPES))
		  (GO LP)))
          (SETQ VALBUSY T)
          (SETQ NEWEXPR (GLPROGN (CDDR EXPR)
				 CONTEXT))
          (RETURN (LIST (CONS (QUOTE LAMBDA)
			      (CONS (CADR EXPR)
				    (CAR NEWEXPR)))
			(CADR NEWEXPR])

(GLDOMAIN
  [LAMBDA (SINGFLAG)                                         (* edited: "26-JAN-82 11:53")
                                                             (* "GSN: " "17-Apr-81 16:51")

          (* Get a domain specification from the EXPR. If SINGFLAG is set and the top of EXPR is a simple atom, the atom is 
	  made plural and used as a variable or field name.)


    (PROG (NAME)
          (COND
	    [(ATOM (CAR EXPR))
	      (GLSEPINIT (CAR EXPR))
	      (COND
		((EQ (SETQ NAME (GLSEPNXT))
		     (CAR EXPR))
		  (pop EXPR)
		  (SETQ DOMAINNAME NAME)
		  (RETURN (GLIDNAME (COND
				      (SINGFLAG (GLPLURAL NAME))
				      (T NAME))
				    NIL)))
		(T (GLSEPCLR)
		   (RETURN (GLDOEXPR NIL CONTEXT T]
	    (T (RETURN (GLDOEXPR NIL CONTEXT T])

(GLDOMSG
  [LAMBDA (OBJECT SELECTOR ARGS)                             (* edited: "11-JAN-82 14:31")

          (* Attempt to compile code for the sending of a message to an object. OBJECT is the destination, in the form 
	  (<code> <type>), SELECTOR is the message selector, and ARGS is a list of arguments of the form 
	  (<code> <type>). The result is of this form, or NIL if failure.)


    (PROG (UNITREC TYPE TMP METHOD TRANS FETCHCODE)
          (SETQ TYPE (GLXTRTYPE (CADR OBJECT)))
          (COND
	    ((SETQ METHOD (GLSTRPROP TYPE (QUOTE MSG)
				     SELECTOR))
	      (RETURN (GLCOMPMSG OBJECT METHOD ARGS CONTEXT)))
	    ([AND (SETQ UNITREC (GLUNIT? TYPE))
		  (SETQ TMP (ASSOC (QUOTE MSG)
				   (CADDR UNITREC]
	      (RETURN (APPLY* (CDR TMP)
			      OBJECT SELECTOR ARGS)))
	    [(SETQ TRANS (GLTRANSPARENTTYPES (CADR OBJECT]
	    (T (RETURN)))                                    (* See if the message can be handled by a TRANSPARENT 
							     subobject.)
      B   (COND
	    ((NULL TRANS)
	      (RETURN))
	    ((SETQ TMP (GLDOMSG (LIST (QUOTE *GL*)
				      (GLXTRTYPE (CAR TRANS)))
				SELECTOR ARGS))
	      (SETQ FETCHCODE (GLSTRFN (CAR TRANS)
				       (CADR OBJECT)
				       NIL))
	      (GLSTRVAL TMP (CAR FETCHCODE))
	      (GLSTRVAL TMP (CAR OBJECT))
	      (RETURN TMP))
	    ((SETQ TMP (CDR TMP))
	      (GO B])

(GLDOPROG
  [LAMBDA (EXPR CONTEXT)                                     (* edited: "25-JAN-82 17:31")
                                                             (* "GSN: " "17-Sep-81 14:01")
                                                             (* "GSN: " "13-Aug-81 14:17")
                                                             (* "GSN: " "21-Apr-81 11:23")
                                                             (* Compile a PROG expression.)
    (PROG (PROGLST NEWEXPR RESULT NEXTEXPR TMP RESULTTYPE)
          (pop EXPR)
          (SETQ CONTEXT (CONS NIL CONTEXT))
          (SETQ PROGLST (GLDECL (pop EXPR)
				NIL T CONTEXT))
          (SETQ CONTEXT (CONS NIL CONTEXT))                  (* Compile the contents of the PROG onto NEWEXPR)
                                                             (* Compile the next expression in a PROG.)
      L   (COND
	    ((NULL EXPR)
	      (GO X)))
          (SETQ NEXTEXPR (pop EXPR))
          (COND
	    ((ATOM NEXTEXPR)
	      (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR))         (* *****)
                                                             (* Set up the context for the label we just found.)
	      (GO L))
	    ((NLISTP NEXTEXPR)
	      (GLERROR (QUOTE GLDOPROG)
		       (LIST "PROG contains bad stuff:" NEXTEXPR))
	      (GO L))
	    ((EQ (CAR NEXTEXPR)
		 (QUOTE *))
	      (SETQ NEWEXPR (CONS NEXTEXPR NEWEXPR))
	      (GO L)))
          [COND
	    ((SETQ TMP (GLPUSHEXPR NEXTEXPR T CONTEXT NIL))
	      (SETQ NEWEXPR (CONS (CAR TMP)
				  NEWEXPR]
          (GO L)
      X   [SETQ RESULT (CONS (QUOTE PROG)
			     (CONS PROGLST (DREVERSE NEWEXPR]
          (RETURN (LIST RESULT RESULTTYPE])

(GLDOPROGN
  [LAMBDA (EXPR)                                             (* edited: " 5-NOV-81 14:31")
                                                             (* Compile a PROGN in the source program.)
    (PROG (RES)
          (SETQ RES (GLPROGN (CDR EXPR)
			     CONTEXT))
          (RETURN (LIST (CONS (CAR EXPR)
			      (CAR RES))
			(CADR RES])

(GLDOPROG1
  [LAMBDA (EXPR CONTEXT)                                     (* edited: "25-JAN-82 17:34")
                                                             (* "GSN: " "13-Aug-81 14:23")
                                                             (* "GSN: " "21-Apr-81 11:28")
                                                             (* Compile a PROG1, whose result is the value of its 
							     first argument.)
    (PROG (RESULT TMP TYPE TYPEFLG)
          (SETQ EXPR (CDR EXPR))
      A   (COND
	    ((NULL EXPR)
	      (RETURN (LIST (CONS (QUOTE PROG1)
				  (DREVERSE RESULT))
			    TYPE)))
	    ((SETQ TMP (GLDOEXPR NIL CONTEXT (NOT TYPEFLG)))
	      (SETQ RESULT (CONS (CAR TMP)
				 RESULT))                    (* Get the result type from the first item of the 
							     PROG1.)
	      (COND
		((NOT TYPEFLG)
		  (SETQ TYPE (CADR TMP))
		  (SETQ TYPEFLG T)))
	      (GO A))
	    (T (GLERROR (QUOTE GLDOPROG1)
			(LIST "PROG1 contains bad subexpression."))
	       (pop EXPR)
	       (GO A])

(GLDOREPEAT
  [LAMBDA (EXPR)                                             (* edited: "25-JAN-82 17:38")
    (PROG (ACTIONS TMP LABEL)
          (pop EXPR)
      A   [COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (UNTIL Until until)))
	      (pop EXPR))
	    ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T)))
	      (SETQ ACTIONS (NCONC1 ACTIONS (CAR TMP)))
	      (GO A))
	    (EXPR (RETURN (GLERROR (QUOTE GLDOREPEAT)
				   (LIST "REPEAT contains bad subexpression."]
          [COND
	    ((OR (NULL EXPR)
		 (NULL (SETQ TMP (GLPREDICATE NIL CONTEXT NIL NIL)))
		 EXPR)
	      (GLERROR (QUOTE GLDOREPEAT)
		       (LIST "REPEAT contains no UNTIL or bad UNTIL clause"))
	      (SETQ TMP (LIST NIL (QUOTE BOOLEAN]
          (SETQ LABEL (GLMKLABEL))
          (RETURN (LIST [CONS (QUOTE PROG)
			      (CONS NIL (CONS LABEL (NCONC1 ACTIONS
							    (LIST (QUOTE COND)
								  (LIST (GLBUILDNOT (CAR TMP))
									(LIST (QUOTE GO)
									      LABEL]
			NIL])

(GLDORETURN
  [LAMBDA (EXPR)                                             (* "GSN: " " 7-Apr-81 11:49")
                                                             (* "GSN: " "25-Jan-81 20:29")
                                                             (* Compile a RETURN, capturing the type of the result as
							     a type of the function result.)
    (PROG (TMP)
          (pop EXPR)
          (COND
	    [(NULL EXPR)
	      (GLADDRESULTTYPE NIL)
	      (RETURN (QUOTE ((RETURN)
			       NIL]
	    (T (SETQ TMP (GLDOEXPR NIL CONTEXT T))
	       (GLADDRESULTTYPE (CADR TMP))
	       (RETURN (LIST (LIST (QUOTE RETURN)
				   (CAR TMP))
			     (CADR TMP])

(GLDOSELECTQ
  [LAMBDA (EXPR CONTEXT)                                     (* edited: "30-DEC-81 13:01")
                                                             (* Compile a SELECTQ. Special treatment is necessary in 
							     order to quote the selectors implicitly.)
    (PROG (RESULT)
          [SETQ RESULT (LIST (CAR (GLPUSHEXPR (LIST (CADR EXPR))
					      NIL CONTEXT T]
          (SETQ EXPR (CDDR EXPR))
      A   [COND
	    ((NULL EXPR)
	      (RETURN (LIST (CONS (QUOTE SELECTQ)
				  RESULT)
			    NIL]
          [SETQ RESULT (NCONC1 RESULT (COND
				 [(CDR EXPR)
				   (CONS (CAAR EXPR)
					 (CAR (GLPROGN (CDAR EXPR)
						       CONTEXT]
				 (T (CAR (GLDOEXPR NIL CONTEXT T]
          (SETQ EXPR (CDR EXPR))
          (GO A])

(GLDOSEND
  [LAMBDA (EXPRR)                                            (* edited: "25-JAN-82 17:41")

          (* Compile code for the sending of a message to an object. The syntax of the message expression is 
	  (_ <object> <selector> <arg1>...<argn>), where the _ may optionally be SEND, Send, or send.)


    (PROG ((EXPR (CDR EXPRR))
	   OBJECT SELECTOR ARGS TMP)
          (SETQ OBJECT (GLPUSHEXPR (LIST (pop EXPR))
				   NIL CONTEXT T))
          (SETQ SELECTOR (pop EXPR))
          [COND
	    ((OR (NULL SELECTOR)
		 (NOT (LITATOM SELECTOR)))
	      (RETURN (GLERROR (QUOTE GLDOSEND)
			       (LIST SELECTOR "is an illegal message Selector."]
                                                             (* Collect arguments of the message, if any.)
      A   (COND
	    [(NULL EXPR)
	      (COND
		((SETQ TMP (GLDOMSG OBJECT SELECTOR ARGS))
		  (RETURN TMP))
		(T                                           (* No message was defined, so just pass it through and 
							     hope one will be defined by runtime.)
		   (RETURN (LIST [CONS (QUOTE _)
				       (CONS (CAR OBJECT)
					     (CONS SELECTOR (MAPCAR ARGS (FUNCTION CAR]
				 (CADR OBJECT]
	    ((SETQ TMP (GLDOEXPR NIL CONTEXT T))
	      (SETQ ARGS (NCONC1 ARGS TMP))
	      (GO A))
	    (T (GLERROR (QUOTE GLDOSEND)
			(LIST "A message argument is bad."])

(GLDOSETQ
  [LAMBDA (EXPR)                                             (* "GSN: " " 7-Apr-81 11:52")
                                                             (* "GSN: " "25-Jan-81 17:50")
                                                             (* Compile a SETQ expression)
    (PROG (VAR)
          (pop EXPR)
          (SETQ VAR (pop EXPR))
          (RETURN (GLDOVARSETQ VAR (GLDOEXPR NIL CONTEXT T])

(GLDOTHE
  [LAMBDA (EXPR)                                             (* edited: "25-JAN-82 17:44")
                                                             (* "GSN: " "17-Apr-81 14:53")
                                                             (* Process a THE expression in a list.)
    (PROG (RESULT)
          (SETQ RESULT (GLTHE))
          [COND
	    (EXPR (GLERROR (QUOTE GLDOTHE)
			   (LIST "Stuff left over at end of The expression." EXPR]
          (RETURN RESULT])

(GLDOVARSETQ
  [LAMBDA (VAR RHS)                                          (* "GSN: " "25-Jan-81 18:00")

          (* Compile code to do a SETQ of VAR to the RHS. If the type of VAR is unknown, it is set to the type of RHS.)


    (PROG (CTXENT)
          (COND
	    [(SETQ CTXENT (GLFINDVARINCTX VAR CONTEXT))
	      (COND
		((NULL (CADDR CTXENT))
		  (RPLACA (CDDR CTXENT)
			  (CADR RHS]
	    ((CADR RHS)
	      (GLADDSTR VAR NIL (CADR RHS)
			CONTEXT)))
          (RETURN (LIST (LIST (QUOTE SETQ)
			      VAR
			      (CAR RHS))
			(CADR RHS])

(GLDOWHILE
  [LAMBDA (EXPR CONTEXT)                                     (* edited: "25-JAN-82 17:45")
    (PROG (ACTIONS TMP LABEL)
          (SETQ CONTEXT (CONS NIL CONTEXT))
          (pop EXPR)
          [SETQ ACTIONS (LIST (CAR (GLPREDICATE NIL CONTEXT NIL T]
          (COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (DO Do do)))
	      (pop EXPR)))
      A   (COND
	    ((AND EXPR (SETQ TMP (GLDOEXPR NIL CONTEXT T)))
	      (SETQ ACTIONS (NCONC1 ACTIONS (CAR TMP)))
	      (GO A))
	    (EXPR (GLERROR (QUOTE GLDOWHILE)
			   (LIST "Bad stuff in While statement:" EXPR))
		  (pop EXPR)
		  (GO A)))
          (SETQ LABEL (GLMKLABEL))
          (RETURN (LIST [LIST (QUOTE PROG)
			      NIL LABEL (LIST (QUOTE COND)
					      (NCONC1 ACTIONS (LIST (QUOTE GO)
								    LABEL]
			NIL])

(GLED
  [LAMBDA (FN)                                               (* edited: "13-JAN-82 16:02")
                                                             (* "GSN: " "15-Apr-81 16:51")
                                                             (* Edit the compiled version of a GLISP function.)
    (EDITV (GETPROPLIST FN))
    FN])

(GLEQUALFN
  [LAMBDA (LHS RHS)                                          (* edited: "29-DEC-81 15:06")
                                                             (* "GSN: " " 7-Jan-81 17:28")
                                                             (* "GSN: " " 6-Jan-81 16:11")
                                                             (* Produce code to test the two sides for equality.)
    (PROG NIL
          (RETURN (LIST [COND
			  ((NULL (CAR RHS))
			    (LIST (QUOTE NULL)
				  (CAR LHS)))
			  ((NULL (CAR LHS))
			    (LIST (QUOTE NULL)
				  (CAR RHS)))
			  (T (LIST (COND
				     ((OR (EQ (CADR LHS)
					      (QUOTE INTEGER))
					  (EQ (CADR RHS)
					      (QUOTE INTEGER)))
				       (QUOTE EQP))
				     ((OR (EQ (CADR LHS)
					      (QUOTE ATOM))
					  (EQ (CADR RHS)
					      (QUOTE ATOM)))
				       (QUOTE EQ))
				     (T (QUOTE EQUAL)))
				   (CAR LHS)
				   (CAR RHS]
			(QUOTE BOOLEAN])

(GLERR
  [LAMBDA (ERREXP)                                           (* edited: "26-JAN-82 11:28")
    (PRIN1 "Execution of GLISP error expression: ")
    (PRINT ERREXP)
    (ERROR])

(GLERROR
  [LAMBDA (FN MSGLST)                                        (* edited: "26-JAN-82 11:27")
                                                             (* Print a GLISP error message.
							     The global stack EXPRSTACK is used to help the user 
							     locat 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)))
		     (SHOWPRINT (CAR EXPRSTACK))
		     (PRIN1 "within expr. ")
		     (SHOWPRINT (CADR EXPRSTACK)))
          (COND
	    (GLBREAKONERROR (ERROR)))
          (RETURN (LIST (LIST (QUOTE GLERR)
			      (LIST (QUOTE QUOTE)
				    (CAR EXPRSTACK)))
			NIL])

(GLEXPANDPROGN
  [LAMBDA (LST)                                              (* edited: "13-JAN-82 11:42")
                                                             (* If a PROGN occurs within a PROGN, expand it by 
							     splicing its contents into the top-level list.)
    (MAP LST (FUNCTION (LAMBDA (X)
	     (COND
	       ((NLISTP (CAR X)))
	       ((FMEMB (CAAR X)
		       (QUOTE (PROGN PROG2)))
		 [COND
		   ((CDDAR X)
		     (RPLACD (LAST (CAR X))
			     (CDR X))
		     (RPLACD X (CDDAR X]
		 (RPLACA X (CADAR X])

(GLFINDVARINCTX
  [LAMBDA (VAR CONTEXT)                                      (* "GSN: " " 2-Jan-81 14:26")
                                                             (* Find the first entry for variable VAR in the CONTEXT 
							     structure.)
    (AND CONTEXT (OR (ASSOC VAR (CAR CONTEXT))
		     (GLFINDVARINCTX VAR (CDR CONTEXT])

(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)                                               (* edited: "13-JAN-82 16:00")
                                                             (* Get the EXPR definition of FN, if available.)
    (COND
      ((AND (CCODEP FN)
	    (EQ (UNSAVEDEF FN (QUOTE EXPR))
		(QUOTE EXPR)))
	(PRIN1 FN)
	(SPACES 1)
	(PRIN1 "unsaved.")
	(TERPRI)))
    (GETD FN])

(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])

(GLGETFIELD
  [LAMBDA (SOURCE FIELD CONTEXT)                             (* edited: "26-JAN-82 11:17")
                                                             (* "GSN: " "18-Sep-81 13:48")
                                                             (* "GSN: " "13-Aug-81 16:40")
                                                             (* "GSN: " "21-Apr-81 11:26")

          (* Find a way to retrieve the FIELD from the structure pointed to by SOURCE (which may be a variable name, NIL, or
	  a list (CODE DESCR)) relative to CONTEXT. The result is a list of code to get the field and the structure 
	  description of the resulting field.)


    (PROG (TMP CODE CTXENTRY CTXLIST STRLIST)
          [COND
	    ((NULL SOURCE)
	      (GO B))
	    ((ATOM SOURCE)
	      (COND
		((AND (SETQ CTXENTRY (GLFINDVARINCTX SOURCE CONTEXT))
		      (SETQ TMP (GLVALUE SOURCE FIELD (CADDR CTXENTRY)
					 NIL)))
		  (RETURN TMP))
		((SETQ TMP (GLGETFIELD NIL SOURCE CONTEXT))
		  (SETQ SOURCE TMP))
		(T (RETURN (GLERROR (QUOTE GLGETFIELD)
				    (LIST "The name" SOURCE "cannot be found."]
          [COND
	    ((LISTP SOURCE)
	      (COND
		((SETQ TMP (GLVALUE (CAR SOURCE)
				    FIELD
				    (CADR SOURCE)
				    NIL))
		  (RETURN TMP))
		(T (RETURN (GLERROR (QUOTE GLGETFIELD)
				    (LIST "The property" FIELD "cannot be found for type"
					  (CADR SOURCE)
					  "in"
					  (CAR SOURCE]
      B                                                      (* No source is specified. Look for a source in the 
							     context.)
          (COND
	    ((NULL CONTEXT)
	      (RETURN)))
          (SETQ CTXLIST (pop CONTEXT))
      C   (COND
	    ((NULL CTXLIST)
	      (GO B)))
          (SETQ CTXENTRY (pop CTXLIST))
          (COND
	    [(EQ FIELD (CADR CTXENTRY))
	      (RETURN (LIST (CAR CTXENTRY)
			    (CADDR CTXENTRY]
	    ((NULL (SETQ TMP (GLVALUE (CAR CTXENTRY)
				      FIELD
				      (CADDR CTXENTRY)
				      NIL)))
	      (GO C)))
          (RETURN TMP])

(GLGETFROMUNIT
  [LAMBDA (UNITREC IND DES)                                  (* "GSN: " " 2-Jun-81 13:46")
                                                             (* 
							     
"Call the appropriate function to compile code to get the indicator
'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)                                             (* edited: "26-JAN-82 10:05")
                                                             (* "GSN: " "13-Aug-81 12:36")
                                                             (* 
							     
"Get pairs of <field> = <value>, where the = and , are optional.")
    (PROG (PROP VAL PAIRLIST)
      A   (COND
	    ((NULL EXPR)
	      (RETURN 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 (GLDOEXPR NIL CONTEXT T))
          (SETQ PAIRLIST (NCONC1 PAIRLIST (CONS PROP VAL)))
          (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])

(GLIDNAME
  [LAMBDA (NAME DEFAULTFLG)                                  (* edited: "26-JAN-82 11:57")
                                                             (* "GSN: " "13-Aug-81 15:00")
                                                             (* "GSN: " "14-Apr-81 17:04")
                                                             (* Identify a given name as either a known variable name
							     of as an implicit field reference.)
    (PROG (TMP)
          (RETURN (COND
		    [(ATOM NAME)
		      (COND
			((NULL NAME)
			  (LIST NIL (QUOTE BOOLEAN)))
			((LITATOM NAME)
			  (COND
			    ((EQ NAME T)
			      (LIST NAME (QUOTE BOOLEAN)))
			    [(SETQ TMP (GLVARTYPE NAME CONTEXT))
			      (LIST NAME (COND
				      ((EQ TMP (QUOTE *NIL*))
					NIL)
				      (T TMP]
			    ((GLGETFIELD NIL NAME CONTEXT))
			    ((GLIDTYPE NAME CONTEXT))
			    (DEFAULTFLG (LIST NAME NIL))
			    (T NIL)))
			((FIXP NAME)
			  (LIST NAME (QUOTE INTEGER)))
			((FLOATP NAME)
			  (LIST NAME (QUOTE REAL)))
			(T (GLERROR (QUOTE GLIDNAME)
				    (LIST NAME "is an illegal name."]
		    (T NAME])

(GLIDTYPE
  [LAMBDA (NAME CONTEXT)                                     (* edited: " 6-NOV-81 12:25")
                                                             (* "GSN: " "13-Aug-81 15:29")
                                                             (* 
							     
"Try to identify a name by either its referenced name or its type.")
    (PROG (CTXLEVELS CTXLEVEL CTXENTRY)
          (SETQ CTXLEVELS CONTEXT)
      LPA (COND
	    ((NULL CTXLEVELS)
	      (RETURN)))
          (SETQ CTXLEVEL (pop CTXLEVELS))
      LPB (COND
	    ((NULL CTXLEVEL)
	      (GO LPA)))
          (SETQ CTXENTRY (CAR CTXLEVEL))
          (SETQ CTXLEVEL (CDR CTXLEVEL))
          [COND
	    ([OR (EQ (CADR CTXENTRY)
		     NAME)
		 (EQ (CADDR CTXENTRY)
		     NAME)
		 (AND (LISTP (CADDR CTXENTRY))
		      (GL-A-AN? (CAADDR CTXENTRY))
		      (EQ NAME (CADR (CADDR CTXENTRY]
	      (RETURN (LIST (CAR CTXENTRY)
			    (CADDR CTXENTRY]
          (GO LPB])

(GLINIT
  [LAMBDA NIL                      (* lmm "17-FEB-82 22:38")
                                   (* Initialize things for GLISP)
    (PROG NIL
          [SETQ GLSEPBITTBL
	    (MAKEBITTABLE (QUOTE (: _ + - ' = ~ < > 42 / , ^]
          (SETQ GLUNITPKGS NIL)
          (SETQ GLSEPMINUS NIL)
          (SETQ GLQUIETFLG NIL)
          (SETQ GLSEPATOM NIL)
          (SETQ GLSEPPTR 0)
          (SETQ GLBREAKONERROR NIL])

(GLINITLAMBDATRAN
  [LAMBDA NIL                                                (* edited: "20-Oct-81 10:35")
                                                             (* "Initialize the LAMBDATRAN package.")
    (PROG NIL                                                (* 
							     
"Test whether this is INTERLISP-10 or INTERLISP-D, and load
the LAMBDATRAN package.")
          [COND
	    ((SMALLP 5000)
	      (LOAD (QUOTE LAMBDATRAN.DBYTE)))
	    (T (LOAD (QUOTE LAMBDATRAN.COM]
          (NCONC1 LAMBDASPLST (QUOTE GLAMBDA))
          (SETQ LAMBDATRANFNS (NCONC1 LAMBDATRANFNS (QUOTE (GLAMBDA GLAMBDATRAN EXPR NIL])

(GLLISPADJ
  [LAMBDA (ADJ)                                              (* edited: "16-DEC-81 11:58")
                                                             (* "GSN: " "24-Sep-81 16:41")
                                                             (* 
							     
"Test the word ADJ to see if it is a LISP adjective.  If so,
return the name of the function to test it.")
    (PROG (TMP)
          (RETURN (AND [SETQ TMP (FASSOC (U-CASE ADJ)
					 (QUOTE ((ATOMIC . ATOM)
						  (NULL . NULL)
						  (NIL . NULL)
						  (INTEGER . FIXP)
						  (REAL . FLOATP)
						  (SMALL . SMALLP)
						  (ZERO . ZEROP)
						  (NUMERIC . NUMBERP)
						  (NEGATIVE . MINUSP)
						  (MINUS . MINUSP]
		       (CDR TMP])

(GLLISPISA
  [LAMBDA (ISAWORD)                                          (* edited: " 9-NOV-81 14:52")
                                                             (* "GSN: " "24-Sep-81 16:43")
                                                             (* 
							     
"Test to see if ISAWORD is a LISP ISA word.  If so,
return the name of the function to test for it.")
    (PROG (TMP)
          (RETURN (AND [SETQ TMP (FASSOC (U-CASE ISAWORD)
					 (QUOTE ((ATOM . ATOM)
						  (LIST . LISTP)
						  (NUMBER . NUMBERP)
						  (INTEGER . FIXP)
						  (LITATOM . LITATOM]
		       (CDR TMP])

(GLMAKESTR
  [LAMBDA (TYPE EXPR)                                        (* edited: "26-JAN-82 10:10")
                                                             (* "GSN: " "14-Sep-81 13:22")
                                                             (* "GSN: " "13-Aug-81 14:17")
                                                             (* 
							     
"Compile code to create a structure in response to a statement
(A <structure> WITH <field> = <value> ...")
    (PROG (NEWSTR 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 (CONS (QUOTE LIST)
			    (MAPCAR EXPR (FUNCTION (LAMBDA (EXPR)
					(GLDOEXPR NIL CONTEXT T]
          (SETQ PAIRLIST (GLGETPAIRS EXPR))
          (RETURN (LIST (GLBUILDSTR STRDES PAIRLIST NIL)
			TYPE])

(GLMKLABEL
  [LAMBDA NIL                                                (* edited: " 4-JAN-82 10:06")
                                                             (* Make a variable name for GLCOMP functions.)
    (PROG NIL
          (SETQ GLNATOM (ADD1 GLNATOM))
          (RETURN (PACK (LIST (QUOTE GLLABEL)
			      GLNATOM])

(GLMKVAR
  [LAMBDA NIL                                                (* edited: "29-Sep-80 10:20")
                                                             (* Make a variable name for GLCOMP functions.)
    (PROG NIL
          (SETQ GLNATOM (ADD1 GLNATOM))
          (RETURN (PACK (LIST (QUOTE GLVAR)
			      GLNATOM])

(GLNCONCFN
  [LAMBDA (LHS RHS)                                          (* edited: "21-DEC-81 14:03")
                                                             (* "GSN: " " 2-Jun-81 14:18")
                                                             (* "GSN: " "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))
		  (GLADDSTR LHSCODE NIL (LIST (QUOTE LISTOF)
					      (CADR RHS))
			    CONTEXT]
	    [(EQ (CAR LHSDES)
		 (QUOTE LISTOF))
	      (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 TMP))
	    (T (RETURN)))
          (RETURN (GLPUTFN LHS (LIST NCCODE LHSDES])

(GLNEQUALFN
  [LAMBDA (LHS RHS)                                          (* "GSN: " " 6-Jan-81 16:11")
                                                             (* Produce code to test the two sides for inequality.)
    (PROG NIL
          (COND
	    [(OR (EQ (CADR LHS)
		     (QUOTE ATOM))
		 (EQ (CADR RHS)
		     (QUOTE ATOM)))
	      (RETURN (LIST (LIST (QUOTE NEQ)
				  (CAR LHS)
				  (CAR RHS))
			    (QUOTE BOOLEAN]
	    (T (RETURN (LIST (LIST (QUOTE NOT)
				   (LIST (COND
					   ((OR (EQ (CADR LHS)
						    (QUOTE INTEGER))
						(EQ (CADR RHS)
						    (QUOTE INTEGER)))
					     (QUOTE EQP))
					   (T (QUOTE EQUAL)))
					 (CAR LHS)
					 (CAR RHS)))
			     (QUOTE BOOLEAN])

(GLOKSTR?
  [LAMBDA (STR)                                              (* edited: "17-DEC-81 14:36")
                                                             (* "GSN: " "14-Sep-81 13:26")
                                                             (* "GSN: " " 2-Jun-81 10:07")
                                                             (* "GSN: " "24-Apr-81 12:12")
                                                             (* "GSN: " "21-Apr-81 11:31")
                                                             (* Check a structure description for legality.)
    (PROG [TEMP (DATATYPES (QUOTE (ATOM NUMBER BOOLEAN INTEGER REAL STRING NIL ANYTHING]
          (RETURN (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]
			       [CONS (AND (CDR STR)
					  (CDDR STR)
					  (NULL (CDDDR STR))
					  (GLOKSTR? (CADR STR))
					  (GLOKSTR? (CADDR STR]
			       [LIST (AND (CDR STR)
					  (EVERY (CDR STR)
						 (FUNCTION GLOKSTR?]
			       [(RECORD TYPERECORD ASSOCRECORD PROPRECORD ARRAYRECORD HASHLINK 
					DATATYPE ATOMRECORD)
				 (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 (AND (CDR STR)
					   (EVERY (CDR STR)
						  (FUNCTION (LAMBDA (X)
						      (AND (ATOM (CAR X))
							   (GLOKSTR? (CADR X]
			       (ATOM (GLATMSTR? STR))
			       (COND
				 ((AND (CDR STR)
				       (NULL (CDDR STR)))
				   (GLOKSTR? (CADR STR)))
				 (T NIL]
		    (T NIL])

(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)                                              (* edited: "22-DEC-81 13:24")
                                                             (* "GSN: " "14-Aug-81 14:19")
                                                             (* "GSN: " "20-Mar-81 14:46")
                                                             (* "GSN: " " 8-Jan-81 14:17")
                                                             (* Test if an atom is a GLISP operator)
    (FMEMB ATM
	   (QUOTE (_ __ __+ __- _+_ _+ +_ _- -_ = ~= AND And and OR Or or + - * / > < >= <= ^])

(GLORFN
  [LAMBDA (LHS RHS)                                          (* edited: "28-DEC-81 17:34")
                                                             (* "GSN: " " 8-Jan-81 17:05")
                                                             (* OR operator)
    (PROG NIL
          (RETURN (LIST (LIST (QUOTE OR)
			      (CAR LHS)
			      (CAR RHS))
			(COND
			  ((EQUAL (GLXTRTYPE (CADR LHS))
				  (GLXTRTYPE (CADR RHS)))
			    (CADR LHS))
			  (T NIL])

(GLPARSEXPR
  [LAMBDA NIL                                                (* edited: "26-JAN-82 10:16")
                                                             (* "GSN: " "23-Jun-81 14:35")
                                                             (* "GSN: " "14-Apr-81 12:25")
                                                             (* "GSN: " " 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)))
		  (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: "26-JAN-82 11: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)
			  (RETURN (LIST (KWOTE (pop EXPR))
					NIL)))
		    (T (RETURN]
		((MEMB FIRST (QUOTE (THE The the)))
		  (SETQ TMP (GLTHE))
		  (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 (QUOTE BOOLEAN)))
			 (T (GLIDNAME PREV T])

(GLPARSNFLD
  [LAMBDA NIL                                                (* edited: "29-DEC-81 14:33")
                                                             (* "GSN: " " 8-Jan-81 13:45")
                                                             (* Parse a field specification which may be preceded by 
							     a ~.)
    (PROG (TMP)
          (COND
	    [(EQ FIRST (QUOTE ~))
	      [COND
		((SETQ FIRST (GLSEPNXT))
		  (SETQ TMP (GLPARSFLD NIL)))
		((AND EXPR (ATOM (CAR EXPR)))
		  (GLSEPINIT (pop EXPR))
		  (SETQ TMP (GLPARSFLD NIL)))
		((AND EXPR (LISTP (CAR EXPR)))
		  (SETQ TMP (GLPUSHEXPR (pop EXPR)
					T CONTEXT T)))
		(T (RETURN (QUOTE (~ NIL]
	      (RETURN (LIST (GLBUILDNOT (CAR TMP))
			    (QUOTE BOOLEAN]
	    (T (RETURN (GLPARSFLD NIL])

(GLPLURAL
  [LAMBDA (WORD)                                             (* edited: "30-OCT-81 11:18")
                                                             (* "GSN: " "14-Apr-81 14:09")
                                                             (* Form the plural of a given word.)
    (PROG (TMP LASTCH UCASE)
          (COND
	    ((SETQ TMP (GETPROP WORD (QUOTE PLURAL)))
	      (RETURN TMP)))
          (SETQ LASTCH (NTHCHAR WORD -1))
          (SETQ UCASE (U-CASEP LASTCH))
          (COND
	    [[AND (MEMB LASTCH (QUOTE (Y y)))
		  (NOT (MEMB (NTHCHAR WORD -2)
			     (QUOTE (A a E e O o]
	      (RETURN (PACK* (SUBATOM WORD 1 -2)
			     (OR (AND UCASE (QUOTE IES))
				 (QUOTE ies]
	    [(MEMB LASTCH (QUOTE (S s X x)))
	      (RETURN (PACK* WORD (OR (AND UCASE (QUOTE ES))
				      (QUOTE es]
	    (T (RETURN (PACK* WORD (OR (AND UCASE (QUOTE S))
				       (QUOTE s])

(GLPOPFN
  [LAMBDA (LHS RHS)                                          (* edited: "21-DEC-81 14:02")
                                                             (* "GSN: " "23-Apr-81 13:24")
                                                             (* "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)))
	      (SETQ GETCODE (GLPUTFN LHS (LIST (LIST (QUOTE CAR)
						     (CAR RHS))
					       (CADR RHSDES]
	    ((EQ RHSDES (QUOTE BOOLEAN))
	      [SETQ POPCODE (GLPUTFN RHS (QUOTE (NIL NIL]
	      (SETQ GETCODE (GLPUTFN LHS RHS)))
	    ((SETQ TMP (GLDOMSG RHS (QUOTE -_)
				(LIST LHS)))
	      (RETURN TMP))
	    ([AND (SETQ STR (GLGETSTR RHSDES))
		  (SETQ TMP (GLPOPFN LHS (LIST (CAR RHS)
					       STR]
	      (RETURN TMP))
	    (T (RETURN)))
          (RETURN (LIST (LIST (QUOTE PROG1)
			      (CAR GETCODE)
			      (CAR POPCODE))
			(CADR GETCODE])

(GLPREC
  [LAMBDA (OP)                                               (* edited: "22-DEC-81 13:23")
                                                             (* "GSN: " "17-Sep-81 13:29")
                                                             (* "GSN: " "14-Aug-81 14:22")
                                                             (* "GSN: " "21-Apr-81 11:27")
                                                             (* Precedence numbers for operators)
    (PROG (TMP)
          (COND
	    ([SETQ TMP (FASSOC OP (QUOTE ((_ . 1)
					   (__ . 1)
					   (_+ . 2)
					   (__+ . 2)
					   (+_ . 2)
					   (_+_ . 2)
					   (_- . 2)
					   (__- . 2)
					   (-_ . 2)
					   (= . 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)                (* edited: "26-JAN-82 10:23")
                                                             (* "GSN: " " 5-Oct-81 12:38")
                                                             (* "GSN: " "24-Sep-81 17:46")
                                                             (* "GSN: " "18-Sep-81 13:04")
                                                             (* "GSN: " "17-Sep-81 13:25")
                                                             (* "GSN: " "14-Aug-81 14:25")
                                                             (* "GSN: " "23-Jun-81 14:40")
                                                             (* "GSN: " " 4-Jun-81 15:02")
                                                             (* "GSN: " " 2-Jun-81 16:11")
                                                             (* "GSN: " "24-Apr-81 12:03")
                                                             (* "GSN: " "21-Apr-81 17:13")

          (* 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))
    (PROG (NEWPRED SETNAME PROPERTY TMP NOTFLG UNITREC)
          [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)))
	      (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 SOURCE SETNAME (QUOTE ISASELF)))
		      (COND
			(ADDISATYPE (COND
				      ((ATOM (CAR SOURCE))
					(GLADDSTR (CAR SOURCE)
						  NIL SETNAME CONTEXT))
				      ((AND (LISTP (CAR SOURCE))
					    (MEMB (CAAR SOURCE)
						  (QUOTE (SETQ PROG1)))
					    (ATOM (CADAR SOURCE)))
					(GLADDSTR (CADAR SOURCE)
						  NIL SETNAME CONTEXT]
		    [(SETQ TMP (GLLISPISA SETNAME))
		      (SETQ NEWPRED (LIST (LIST TMP (CAR SOURCE))
					  (QUOTE BOOLEAN]
		    (T (GLERROR (QUOTE GLPREDICATE)
				(LIST "IS A property" SETNAME "could not be found for" (CAR SOURCE)
				      "whose type is"
				      (CADR SOURCE)))
		       (SETQ NEWPRED (LIST T (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 (LIST TMP (CAR SOURCE))
					   (QUOTE BOOLEAN]
		     (T (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T]
          (RETURN (COND
		    (NOTFLG (LIST (GLBUILDNOT (CAR NEWPRED))
				  (QUOTE BOOLEAN)))
		    (T NEWPRED])

(GLPRETTYPRINTSTRS
  [LAMBDA (LST)                                              (* edited: " 9-NOV-81 10:45")
                                                             (* Pretty-print GLISP structure definitions for file 
							     package output.)
    (PROG (TMP OBJ)
          (TERPRI)
          (TERPRI)
          (PRIN1 (QUOTE %[))
          (PRINT (QUOTE GLDEFSTRQ))
      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 (CADR REST]
		   (FUNCTION CDDR))
	      (printout NIL "  )")))
          (GO LP])

(GLPROGN
  [LAMBDA (EXPR CONTEXT)                                     (* edited: "26-JAN-82 10:24")
                                                             (* "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 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: "13-JAN-82 14:30")
                                                             (* 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 CAAR CADR CDAR CDDR ADD1 CADDR CADDDR])

(GLPUSHEXPR
  [LAMBDA (EXPR START CONTEXT VALBUSY)                       (* edited: "30-DEC-81 17:44")
                                                             (* "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 0))
          (RETURN (GLDOEXPR START CONTEXT VALBUSY])

(GLPUSHFN
  [LAMBDA (LHS RHS)                             (* edited: 
						"28-Jan-82 09:58")
                                                (* "GSN: " 
						" 2-Jun-81 14:19")
                                                (* "GSN: " 
						"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))
		  (GLADDSTR LHSCODE NIL (LIST (QUOTE LISTOF)
					      (CADR RHS))
			    CONTEXT]
	    ((EQ (CAR LHSDES)
		 (QUOTE 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 TMP))					       |
	    (T (RETURN)))					       |
          (RETURN (GLPUTFN LHS (LIST NCCODE LHSDES])

(GLPUTFN
  [LAMBDA (LHS RHS)                                          (* edited: "26-JAN-82 10:27")
                                                             (* "GSN: " " 2-Jun-81 14:16")
                                                             (* "GSN: " "24-Apr-81 12:05")
                                                             (* "GSN: " "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)
          (SETQ LHSD (CAR LHS))
          [COND
	    ((ATOM LHSD)
	      (RETURN (OR (GLDOMSG LHS (QUOTE _)
				   (LIST RHS))
			  (GLDOVARSETQ LHSD RHS]
          (SETQ LNAME (CAR LHSD))
          [COND
	    [(EQ LNAME (QUOTE CAR))
	      (SETQ RESULT (LIST (QUOTE CAR)
				 (LIST (QUOTE RPLACA)
				       (CADR LHSD)
				       (CAR RHS]
	    [(EQ LNAME (QUOTE CDR))
	      (SETQ RESULT (LIST (QUOTE CDR)
				 (LIST (QUOTE RPLACD)
				       (CADR LHSD)
				       (CAR RHS]
	    [[SETQ TMP (FASSOC LNAME (QUOTE ((CADR . CDR)
					      (CADDR . CDDR)
					      (CADDDR . CDDDR]
	      (SETQ RESULT (LIST LNAME (LIST (QUOTE RPLACA)
					     (LIST (CDR TMP)
						   (CADR LHSD))
					     (CAR RHS]
	    [(EQ LNAME (QUOTE GETPROP))
	      (SETQ RESULT (LIST (QUOTE PUTPROP)
				 (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))
	    ((SETQ TMP (GLDOMSG LHS (QUOTE _)
				(LIST RHS)))
	      (RETURN TMP))
	    (T (RETURN (GLERROR (QUOTE GLPUTFN)
				(LIST "Illegal assignment.  LHS =" LHS "RHS =" RHS]
      X   (RETURN (LIST RESULT (OR (CADR LHS)
				   (CADR RHS])

(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])

(GLPUTPROPS
  [LAMBDA (PROPLIS PREVLST)                                  (* edited: " 1-DEC-81 10:40")
                                                             (* "GSN: " "15-Sep-81 11:45")
                                                             (* "GSN: " "14-Sep-81 13:12")
                                                             (* 
							     
"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 (LIST (QUOTE PUTPROP)
				  (QUOTE ATOMNAME)
				  (KWOTE (CAR TMP))
				  TMPCODE]
          (GO A])

(GLREDUCE
  [LAMBDA NIL                                                (* edited: "22-DEC-81 13:31")
                                                             (* "GSN: " "14-Aug-81 12:25")
                                                             (* "GSN: " "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 TMP OPER)
          (SETQ RHS (pop OPNDS))
          (COND
	    ((MEMB (SETQ OPER (pop OPERS))
		   (QUOTE (_ _+ +_ _- -_ = ~= AND And and OR Or or __+ __ _+_ __-)))
	      (SETQ OPNDS (CONS (GLREDUCEOP OPER (pop OPNDS)
					    RHS)
				OPNDS)))
	    ((FMEMB OPER (QUOTE (+ - * / > < >= <= ^)))
	      (SETQ OPNDS (CONS (GLREDUCEARITH OPER (pop OPNDS)
					       RHS)
				OPNDS)))
	    (T (SETQ OPNDS (CONS (LIST (LIST OPER (CAR (pop OPNDS))
					     (CAR RHS))
				       NIL)
				 OPNDS])

(GLREDUCEARITH
  [LAMBDA (OP LHS RHS)                                       (* edited: "23-NOV-81 11:32")
                                                             (* "GSN: " "14-Aug-81 12:38")
                                                             (* "Reduce an arithmetic operator in an expression.")
    (PROG [TMP [OPLIST (QUOTE ((+ . PLUS)
				(- . DIFFERENCE)             (* . TIMES)
				(/ . QUOTIENT)
				(> . GREATERP)
				(< . LESSP)
				(>= . GEQ)
				(<= . LEQ)
				(^ . EXPT]
	       [IOPLIST (QUOTE ((+ . IPLUS)
				 (- . IDIFFERENCE)           (* . ITIMES)
				 (/ . IQUOTIENT)
				 (> . IGREATERP)
				 (< . ILESSP)
				 (>= . IGEQ)
				 (<= . ILEQ]
	       (NUMBERTYPES (QUOTE (INTEGER REAL NUMBER]
          (COND
	    [[OR (AND (EQ (CADR LHS)
			  (QUOTE INTEGER))
		      (EQ (CADR RHS)
			  (QUOTE INTEGER))
		      (SETQ TMP (FASSOC OP IOPLIST)))
		 (AND (MEMB (CADR LHS)
			    NUMBERTYPES)
		      (MEMB (CADR RHS)
			    NUMBERTYPES)
		      (SETQ TMP (FASSOC OP OPLIST]
	      (COND
		[(AND (NUMBERP (CAR LHS))
		      (NUMBERP (CAR RHS)))
		  (RETURN (LIST (APPLY* (CDR TMP)
					(CAR LHS)
					(CAR RHS))
				(CADR LHS]
		(T (RETURN (LIST (LIST (CDR TMP)
				       (CAR LHS)
				       (CAR RHS))
				 (CADR LHS]
	    ((SETQ TMP (GLDOMSG LHS OP (LIST RHS)))
	      (RETURN TMP))
	    [(SETQ TMP (FASSOC OP OPLIST))
	      (RETURN (LIST (LIST (CDR TMP)
				  (CAR LHS)
				  (CAR RHS))
			    (QUOTE NUMBER]
	    (T (RETURN (LIST (LIST OP (CAR LHS)
				   (CAR RHS))
			     (CADR RHS])

(GLREDUCEOP
  [LAMBDA (OP LHS RHS)                                       (* edited: "22-DEC-81 13:21")
                                                             (* Reduce the operator OP with operands LHS and RHS.)
    (PROG (TMP)
          (COND
	    ([SETQ TMP (FASSOC OP (QUOTE ((_ . GLPUTFN)
					   (_+ . GLNCONCFN)
					   (+_ . GLPUSHFN)
					   (_- . GLREMOVEFN)
					   (-_ . GLPOPFN)
					   (= . GLEQUALFN)
					   (~= . GLNEQUALFN)
					   (AND . GLANDFN)
					   (And . GLANDFN)
					   (and . GLANDFN)
					   (OR . GLORFN)
					   (Or . GLORFN)
					   (or . GLORFN]
	      (RETURN (APPLY* (CDR TMP)
			      LHS RHS)))
	    ((MEMB OP (QUOTE (__ __+ __- _+_)))
	      (RETURN (GLPUTUPFN OP LHS RHS)))
	    (T (ERROR (LIST (QUOTE GLREDUCEOP)
			    OP LHS RHS])

(GLREMOVEFN
  [LAMBDA (LHS RHS)                                          (* edited: "21-DEC-81 14:05")
                                                             (* "GSN: " " 2-Jun-81 14:20")
                                                             (* "GSN: " "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 DIFFERENCE)
				      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)
		 (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 TMP))
	    (T (RETURN)))
          (RETURN (GLPUTFN LHS (LIST NCCODE LHSDES])

(GLRESULTTYPE
  [LAMBDA (ATM ARGTYPES)                                     (* edited: "10-NOV-81 16:08")
                                                             (* "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)
          (COND
	    ((SETQ TYPE (GETPROP ATM (QUOTE GLRESULTTYPE)))
	      (RETURN TYPE)))
          (SETQ FNDEF (GLGETD ATM))
          (COND
	    ((OR (NLISTP FNDEF)
		 (NEQ (CAR FNDEF)
		      (QUOTE GLAMBDA)))
	      (RETURN)))
          (SETQ FNDEF (CDDR FNDEF))
      A   (COND
	    ((OR (NULL FNDEF)
		 (NLISTP (CAR FNDEF)))
	      (RETURN))
	    ([OR (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])

(GLSEPCLR
  [LAMBDA NIL                                                (* edited: "30-DEC-81 16:34")
    (SETQ GLSEPPTR 0])

(GLSEPINIT
  [LAMBDA (ATM)                                              (* "GSN: " "30-Dec-80 10:05")
                                                             (* Initialize the scanning function which breaks apart 
							     atoms containing embedded operators.)
    (PROG NIL
          (SETQ GLSEPATOM ATM)
          (SETQ GLSEPPTR 1])

(GLSEPNXT
  [LAMBDA NIL                                                (* edited: "30-DEC-81 17:21")
                                                             (* "GSN: " "14-Aug-81 14:27")
                                                             (* "GSN: " "23-Apr-81 10:10")

          (* 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)
          (COND
	    ((ZEROP GLSEPPTR)
	      (RETURN))
	    ((NULL GLSEPATOM)
	      (SETQ GLSEPPTR 0)
	      (RETURN (QUOTE *NIL*)))
	    ((NUMBERP GLSEPATOM)
	      (SETQ TMP GLSEPATOM)
	      (SETQ GLSEPPTR 0)
	      (RETURN TMP)))
          (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM GLSEPPTR))
      A   (COND
	    [(NULL END)
	      (RETURN (PROG1 (COND
			       ((EQP GLSEPPTR 1)
				 GLSEPATOM)
			       ((IGREATERP GLSEPPTR (NCHARS GLSEPATOM))
				 NIL)
			       (T (GLSUBATOM GLSEPATOM GLSEPPTR)))
			     (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 NIL GLSEPBITTBL)
		      (QUOTE -))
		  (NOT (EQ (NTHCHAR GLSEPATOM (ADD1 END)
				    NIL GLSEPBITTBL)
			   (QUOTE _]
	      (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END)))
	      (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                                                (* "GSN: " " 7-Jan-81 16:36")
                                                             (* Skip comments in GLEXPR.)
    (PROG NIL
      A   (COND
	    ((AND (LISTP GLEXPR)
		  (LISTP (CAR GLEXPR))
		  (EQ (CAAR GLEXPR)
		      (QUOTE *)))
	      (pop GLEXPR)
	      (GO A])

(GLSTRFN
  [LAMBDA (IND DES DESLIST)                                  (* edited: "16-DEC-81 12:52")
                                                             (* "GSN: " " 5-Oct-81 12:32")
                                                             (* "GSN: " "13-Aug-81 16:13")
                                                             (* "GSN: " " 2-Jun-81 11:23")
                                                             (* "GSN: " "24-Apr-81 12:09")
                                                             (* "GSN: " "21-Apr-81 11:29")

          (* 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 N NEW STR ALISTFLAG UNITREC RECNAME RECFLAG)
          (COND
	    ((FMEMB DES DESLIST)
	      (RETURN)))
          (SETQ DESLIST (CONS DES DESLIST))
          [COND
	    ((OR (NULL DES)
		 (NULL IND))
	      (RETURN))
	    ((ATOM DES)
	      (RETURN (COND
			((SETQ STR (GLGETSTR DES))
			  (GLSTRFN IND STR DESLIST))
			((SETQ UNITREC (GLUNIT? DES))
			  (GLGETFROMUNIT UNITREC IND DES))
			(T NIL]
          (SETQ DESIND (CAR DES))
          [COND
	    [(OR (EQ IND DES)
		 (EQ DESIND IND))
	      (RETURN (LIST NIL (CADR DES]
	    [(EQ DESIND (QUOTE CONS))
	      (RETURN (OR (GLSTRVALB IND (CADR DES)
				     (QUOTE (CAR *GL*)))
			  (GLSTRVALB IND (CADDR DES)
				     (QUOTE (CDR *GL*]
	    ((EQ DESIND (QUOTE LIST))
	      (GO L))
	    [(EQ DESIND (QUOTE ALIST))
	      (COND
		[(SETQ TMP (ASSOC IND (CDR DES)))
		  (RETURN (LIST (LIST (QUOTE GLGETASSOC)
				      (KWOTE IND)
				      (QUOTE *GL*))
				(CADR TMP]
		((SETQ ALISTFLAG T)
		  (GO P]
	    [(EQ DESIND (QUOTE PROPLIST))
	      (COND
		[(SETQ TMP (ASSOC IND (CDR DES)))
		  (RETURN (LIST (LIST (QUOTE GETPROP)
				      (QUOTE *GL*)
				      (KWOTE IND))
				(CADR TMP]
		(T (GO P]
	    [(AND (GL-A-AN? DESIND)
		  (ATOM (CADR DES)))
	      (COND
		((GLGETSTR (CADR DES))
		  (RETURN (GLSTRFN IND (CADR DES)
				   DESLIST)))
		((SETQ UNITREC (GLUNIT? (CADR DES)))
		  (RETURN (GLGETFROMUNIT UNITREC IND (CADR DES]
	    [(EQ DESIND (QUOTE ATOM))
	      (COND
		((AND (LISTP (CDR DES))
		      (EQ (CAADR DES)
			  (QUOTE PROPLIST))
		      (SETQ TMP (GLSTRFN IND (CADR DES)
					 DESLIST)))
		  (RETURN TMP))
		([AND (LISTP (CDR DES))
		      (EQ (CAADR DES)
			  (QUOTE BINDING))
		      (SETQ TMP (GLSTRVALB IND (CADADR DES)
					   (QUOTE (EVAL *GL*]
		  (RETURN TMP))
		((AND (CDR DES)
		      (LISTP (CDDR DES))
		      (EQ (CAADDR DES)
			  (QUOTE PROPLIST))
		      (SETQ TMP (GLSTRFN IND (CADDR DES)
					 DESLIST)))
		  (RETURN TMP))
		([AND (CDR DES)
		      (LISTP (CDDR DES))
		      (EQ (CAADDR DES)
			  (QUOTE BINDING))
		      (SETQ TMP (GLSTRVALB IND (CADR (CADDR DES))
					   (QUOTE (EVAL *GL*]
		  (RETURN TMP))
		(T (RETURN]
	    ((MEMB DESIND (QUOTE (RECORD TYPERECORD ASSOCRECORD PROPRECORD ARRAYRECORD HASHLINK 
					 DATATYPE ATOMRECORD)))
	      (COND
		((ATOM (CADR DES))
		  (SETQ RECNAME (CADR DES))
		  (pop DES)))
	      (SETQ RECFLAG T)
	      (GO P))
	    ((MEMB DESIND (QUOTE (INTERVAL ONEOF LISTOF RECORD BINDING MEMB)))
	      (RETURN)                                       (* Not implemented yet)
	      )
	    ((EQ DESIND (QUOTE TRANSPARENT))
	      (RETURN (GLVALUE (QUOTE *GL*)
			       IND
			       (CADR DES)
			       DESLIST)))
	    ([OR (NULL (CDR DES))
		 (ATOM (CADR DES))
		 (AND (LISTP (CADR DES))
		      (GL-A-AN? (CAADR DES]
	      (RETURN))
	    (T (RETURN (GLSTRFN IND (CADR DES)
				DESLIST]
      L                                                      (* Process LIST structure.)
          (SETQ N 1)
      C   (pop DES)
          [COND
	    ((NULL DES)
	      (RETURN))
	    ((SETQ TMP (GLSTRFN IND (CAR DES)
				DESLIST))
	      (RETURN (GLSTRVAL TMP (COND
				  [(ILESSP N 5)
				    (COPY (CAR (NTH (QUOTE ((CAR *GL*)
							     (CADR *GL*)
							     (CADDR *GL*)
							     (CADDDR *GL*)))
						    N]
				  (T (LIST (QUOTE CAR)
					   (LIST (QUOTE NTH)
						 (QUOTE *GL*)
						 N]
          (SETQ N (ADD1 N))
          (GO C)
      P                                                      (* Handle a PROPLIST by looking inside each property for
							     IND.)
          (pop DES)
          (COND
	    ((NULL DES)
	      (RETURN))
	    [(AND (LISTP (CAR DES))
		  (ATOM (CAAR DES))
		  (CDAR DES)
		  (SETQ TMP (GLSTRFN IND (CAR DES)
				     DESLIST)))
	      (RETURN (GLSTRVAL TMP (OR (AND ALISTFLAG (LIST (QUOTE GLGETASSOC)
							     (KWOTE (CAAR DES))
							     (QUOTE *GL*)))
					(AND RECFLAG (LIST (QUOTE fetch)
							   (OR (AND RECNAME (LIST RECNAME
										  (CAAR DES)))
							       (CAAR DES))
							   (QUOTE of)
							   (QUOTE *GL*)))
					(LIST (QUOTE GETPROP)
					      (QUOTE *GL*)
					      (KWOTE (CAAR DES]
	    (T (GO P])

(GLSTRPROP
  [LAMBDA (STR GLPROP PROP)                                  (* edited: " 6-JAN-82 13:53")
                                                             (* "GSN: " "17-Sep-81 14:07")

          (* 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)
          (SETQ STRB (GLXTRTYPE STR))
          (COND
	    ((AND STRB (SETQ GLPROPS (GETPROP STRB (QUOTE GLSTRUCTURE)))
		  (SETQ PROPL (LISTGET (CDR GLPROPS)
				       GLPROP))
		  (SETQ TMP (ASSOC PROP PROPL)))
	      (RETURN TMP))
	    ((AND STRB (SETQ UNITREC (GLUNIT? STRB))
		  (SETQ TMP (APPLY* (CADDDR UNITREC)
				    STRB GLPROP PROP)))
	      (RETURN TMP])

(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])

(GLSUBATOM
  [LAMBDA (X Y Z)                                            (* edited: "30-DEC-81 16:35")
    (OR (SUBATOM X Y Z)
	(QUOTE *NIL*])

(GLTHE
  [LAMBDA NIL                                                (* edited: "26-JAN-82 12:02")
                                                             (* "GSN: " "17-Apr-81 14:23")
                                                             (* EXPR begins with THE. Parse the expression and return
							     code.)
    (PROG (SOURCE SPECS NAME QUALFLG DTYPE NEWCONTEXT LOOPVAR LOOPCOND)
      A   (COND
	    ((NULL EXPR)
	      (GO B))
	    ((MEMB (CAR EXPR)
		   (QUOTE (THE The the)))
	      (pop EXPR)
	      [COND
		([OR (NULL EXPR)
		     (NOT (ATOM (CAR EXPR]
		  (RETURN (GLERROR (QUOTE GLTHE)
				   (LIST "The item following THE is not an atom:" (CAR EXPR]
	      (SETQ SPECS (CONS (pop EXPR)
				SPECS)))
	    ((ATOM (CAR EXPR))
	      (SETQ SPECS (CONS (pop EXPR)
				SPECS)))
	    (T (SETQ SOURCE (GLDOEXPR NIL CONTEXT T))
	       (GO B)))                                      (* SPECS contains a path specification.
							     See if there is any more.)
          (COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (OF Of of)))
	      (pop EXPR)
	      (GO A)))                                       (* Now trace the path specification.)
      B   [COND
	    ((NULL SPECS)
	      (COND
		((MEMB (CAR EXPR)
		       (QUOTE (IS Is is HAS Has has)))
		  (RETURN (GLPREDICATE SOURCE CONTEXT T NIL)))
		(T (RETURN SOURCE]                           (* If this is a definite reference to a qualified 
							     entity, make the name of the entity plural.)
          [COND
	    ([SETQ QUALFLG
		(AND (NULL (CDR SPECS))
		     EXPR
		     (MEMB (CAR EXPR)
			   (QUOTE (with With WITH who Who WHO which Which WHICH that That THAT]
	      (RPLACA SPECS (GLPLURAL (CAR SPECS]
          [COND
	    ((NULL SOURCE)
	      (SETQ SOURCE (GLIDNAME (SETQ NAME (pop SPECS))
				     NIL)))
	    (T (SETQ SOURCE (GLGETFIELD SOURCE (pop SPECS)
					CONTEXT]
          [COND
	    ((NULL SOURCE)
	      (RETURN (GLERROR (QUOTE GLTHE)
			       (LIST "The definite reference to" NAME "could not be found."]
          (COND
	    ((NULL QUALFLG)
	      (GO B)))
          (SETQ DTYPE (GLXTRTYPE (CADR SOURCE)))
          [COND
	    ((NEQ (CAR DTYPE)
		  (QUOTE LISTOF))
	      (OR (EQ [CAR (SETQ DTYPE (GLXTRTYPE (GLGETSTR 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))
          (SETQ LOOPVAR (GLMKVAR))
          (GLADDSTR LOOPVAR 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 SOURCE (LIST (SUBLIS (LIST (CONS (QUOTE <set>)
						 (CAR SOURCE))
					   (CONS (QUOTE <instance>)
						 LOOPVAR)
					   (CONS (QUOTE <predicate>)
						 (CAR LOOPCOND)))
				     [QUOTE (CAR (SOME <set> (FUNCTION (LAMBDA (<instance>)
							   <predicate>]
				     T)
			     (CADR DTYPE)))
          (GO B])

(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)                                              (* edited: "13-NOV-81 15:37")
                                                             (* Look for TRANSPARENT substructures for 
							     GLTRANSPARENTTYPES.)
    (COND
      ((NLISTP STR))
      ((EQ (CAR STR)
	   (QUOTE TRANSPARENT))
	(SETQ TTLIST (CONS STR TTLIST)))
      [(MEMB (CAR STR)
	     (QUOTE (LISTOF ALIST PROPLIST]
      (T (MAPC (CDR STR)
	       (FUNCTION GLTRANSPB])

(GLUNITOP
  [LAMBDA (LHS RHS OP)                                       (* edited: "20-Oct-81 10:12")
                                                             (* "GSN: " " 2-Jun-81 14:43")
                                                             (* 
							     
"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 '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])

(GLUNIT?
  [LAMBDA (STR)                                              (* edited: " 6-NOV-81 12:16")
                                                             (* "GSN: " " 2-Jun-81 12:30")
                                                             (* 
							     
"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])

(GLUNWRAP
  [LAMBDA (X BUSY)                                           (* edited: "25-JAN-82 15:51")
                                                             (* 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)
		       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 (CADR X]
			    (COND
			      (BUSY (GLEXPANDPROGN (CDDR X)))
			      (T (RPLACA X (QUOTE PROGN))
				 (GLEXPANDPROGN X)))
			    X)))
		(FUNCTION (RPLACA (CDR X)
				  (GLUNWRAP (CADR X)
					    BUSY))
			  [MAP (CDDR X)
			       (FUNCTION (LAMBDA (Y)
				   (RPLACA Y (GLUNWRAP (CAR Y)
						       T]
			  X)
		((MAP MAPC)
		  (RPLACA (CDR X)
			  (GLUNWRAP (CADR X)
				    T))
		  (RPLACA (CDDR X)
			  (GLUNWRAP (CADDR X)
				    NIL))                    (* INTERLISP DEPENDENT.)
		  X)
		[LAMBDA [MAP (CDDR X)
			     (FUNCTION (LAMBDA (Y)
				 (RPLACA Y (GLUNWRAP (CAR Y)
						     (AND BUSY (NULL (CDR Y]
			(GLEXPANDPROGN (CDDR X))
			X]
		(PROG (GLUNWRAPPROG X BUSY))
		(COND (GLUNWRAPCOND X BUSY))
		(SELECTQ (GLUNWRAPSELECTQ X BUSY))
		(COND
		  ((AND (NOT BUSY)
			(CDR X)
			(NULL (CDDR X))
			(GLPURE (CAR X)))
		    (GLUNWRAP (CADR X)
			      NIL))
		  ((AND (CDR X)
			(NULL (CDDR X)))
		    (RPLACA (CDR X)
			    (GLUNWRAP (CADR X)
				      T))
		    (COND
		      ((AND (LISTP (CADR X))
			    (GLCARCDR? (CAR X))
			    (GLCARCDR? (CAADR X))
			    (ILESSP (IPLUS (NCHARS (CAR X))
					   (NCHARS (CAADR X)))
				    9))
			(RPLACA X (PACK* (SUBSTRING (CAR X)
						    1 -2)
					 (SUBSTRING (CAADR X)
						    2)))
			(RPLACA (CDR X)
				(CADADR X))
			(GLUNWRAP X BUSY))
		      (T X)))
		  (T [MAP (CDR X)
			  (FUNCTION (LAMBDA (Y)
			      (RPLACA Y (GLUNWRAP (CAR Y)
						  T]
		     X])

(GLUNWRAPCOND
  [LAMBDA (X BUSY)                                           (* edited: "13-JAN-82 13:13")
                                                             (* Unwrap a COND expression.)
    [MAPC (CDR X)
	  (FUNCTION (LAMBDA (Y)
	      (RPLACA Y (GLUNWRAP (CAR Y)
				  T))
	      [MAP (CDR Y)
		   (FUNCTION (LAMBDA (Z)
		       (RPLACA Z (GLUNWRAP (CAR Z)
					   (AND BUSY (NULL (CDR Z]
	      (GLEXPANDPROGN (CDR Y]
    X])

(GLUNWRAPPROG
  [LAMBDA (X BUSY)                                           (* edited: "25-JAN-82 15:53")
                                                             (* Unwrap a PROG expression.)
    (PROG (LAST)                                             (* First see if the PROG is not busy and ends with a 
							     RETURN.)
          [COND
	    ((AND (NOT BUSY)
		  (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 (CDDR X))
          (RETURN X])

(GLUNWRAPSELECTQ
  [LAMBDA (X BUSY)                                           (* edited: "25-JAN-82 15:54")
                                                             (* Unwrap a SELECTQ expression.)
    (RPLACA (CDR X)
	    (GLUNWRAP (CADR X)
		      T))
    [MAP (CDDR X)
	 (FUNCTION (LAMBDA (Y)
	     (COND
	       ((CDR Y)
		 [MAP (CDAR Y)
		      (FUNCTION (LAMBDA (Z)
			  (RPLACA Z (GLUNWRAP (CAR Z)
					      (AND BUSY (NULL (CDR Z]
		 (GLEXPANDPROGN (CDAR Y)))
	       (T (RPLACA Y (GLUNWRAP (CAR Y)
				      BUSY]
    X])

(GLUSERFN
  [LAMBDA (EXPR)                                             (* edited: " 6-NOV-81 13:20")
                                                             (* "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))                           (* 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)
	      (RETURN (GLUSERFNB EXPR)))
	    ([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])

(GLUSERFNB
  [LAMBDA (EXPR)                                             (* edited: "26-JAN-82 10:44")
                                                             (* "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 (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])

(GLVALUE
  [LAMBDA (SOURCE PROP TYPE DESLIST)                         (* edited: "14-DEC-81 14:09")
                                                             (* "GSN: " "18-Sep-81 13:42")
                                                             (* 
							     
"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 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 RESTYPE)
          (COND
	    ((SETQ TMP (GLSTRFN PROP TYPE DESLIST))
	      (RETURN (GLSTRVAL TMP SOURCE)))
	    ((SETQ PROPL (GLSTRPROP TYPE (QUOTE PROP)
				    PROP))
	      (SETQ TMP (GLCOMPMSG (LIST SOURCE TYPE)
				   PROPL NIL CONTEXT))
	      (RETURN TMP))
	    (T (RETURN])

(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])

(GLXTRTYPE
  [LAMBDA (TYPE)                                             (* edited: "26-JAN-82 10:47")
                                                             (* Extract an atomic type name from a type spec which 
							     may be either <type> or (A <type>).)
    (COND
      ((ATOM TYPE)
	TYPE)
      ((AND (LISTP TYPE)
	    (OR (GL-A-AN? (CAR TYPE))
		(EQ (CAR TYPE)
		    (QUOTE TRANSPARENT)))
	    (CDR TYPE)
	    (ATOM (CADR TYPE)))
	(CADR TYPE))
      ((MEMB (CAR TYPE)
	     GLTYPENAMES)
	TYPE)
      ((AND (ATOM (CAR TYPE))
	    (CDR TYPE))
	(GLXTRTYPE (CADR TYPE)))
      (T (GLERROR (QUOTE GLXTRTYPE)
		  (LIST TYPE "is an illegal type specification."))
	 NIL])
)
(GLINIT)
(FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES)
	   LAMBDATRAN)

(ADDTOVAR LAMBDASPLST GLAMBDA)

(ADDTOVAR LAMBDATRANFNS (GLAMBDA GLAMBDATRAN EXPR NIL))
(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS 
	  GLTYPENAMES GLBREAKONERROR)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(SPECVARS CONTEXT START EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR 
	  GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR 
	  DESLIST EXPRSTACK)
)

(RPAQQ GLTYPENAMES (CONS LIST RECORD TYPERECORD ASSOCRECORD PROPRECORD 
			 ARRAYRECORD HASHLINK DATATYPE ATOMRECORD 
			 LISTOF ALIST ATOM))
[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))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA GLDEFSTRQ)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2272 128338 (GL-A-AN? 2284 . 2514) (GLADDRESULTTYPE 2518 
. 3056) (GLADDSTR 3060 . 3536) (GLADJ 3540 . 5081) (GLAMBDATRAN 5085 . 
5864) (GLANDFN 5868 . 6793) (GLATMSTR? 6797 . 7552) (GLBUILDALIST 7556 .
 8251) (GLBUILDCONS 8255 . 9062) (GLBUILDLIST 9066 . 9816) (GLBUILDNOT 
9820 . 10750) (GLBUILDSTR 10754 . 14016) (GLCARCDR? 14020 . 14340) (
GLCOMP 14344 . 16710) (GLCOMPCOMS 16714 . 17753) (GLCOMPILE 17757 . 
18173) (GLCOMPMSG 18177 . 20657) (GLCOMPOPEN 20661 . 24022) (GLCONST? 
24026 . 24452) (GLCONSTSTR? 24456 . 24877) (GLCONSTVAL 24881 . 25483) (
GLDECL 25487 . 28788) (GLDECLDS 28792 . 29125) (GLDEFPROP 29129 . 30067)
 (GLDEFSTR 30071 . 31540) (GLDEFSTRQ 31544 . 32061) (GLDEFUNITPKG 32065 
. 32970) (GLDELDEF 32974 . 33229) (GLDOA 33233 . 34037) (GLDOCOND 34041 
. 34360) (GLDOEXPR 34364 . 38541) (GLDOFOR 38545 . 42653) (GLDOIF 42657 
. 44136) (GLDOLAMBDA 44140 . 44889) (GLDOMAIN 44893 . 45676) (GLDOMSG 
45680 . 47064) (GLDOPROG 47068 . 48780) (GLDOPROGN 48784 . 49147) (
GLDOPROG1 49151 . 50193) (GLDOREPEAT 50197 . 51179) (GLDORETURN 51183 . 
51863) (GLDOSELECTQ 51867 . 52638) (GLDOSEND 52642 . 54004) (GLDOSETQ 
54008 . 54427) (GLDOTHE 54431 . 54923) (GLDOVARSETQ 54927 . 55494) (
GLDOWHILE 55498 . 56306) (GLED 56310 . 56652) (GLEQUALFN 56656 . 57617) 
(GLERR 57621 . 57806) (GLERROR 57810 . 58703) (GLEXPANDPROGN 58707 . 
59252) (GLFINDVARINCTX 59256 . 59598) (GLGETASSOC 59602 . 59956) (GLGETD
 59960 . 60338) (GLGETDEF 60342 . 60666) (GLGETFIELD 60670 . 62703) (
GLGETFROMUNIT 62707 . 63254) (GLGETPAIRS 63258 . 64081) (GLGETSTR 64085 
. 64635) (GLIDNAME 64639 . 65774) (GLIDTYPE 65778 . 66741) (GLINIT 66745
 . 67192) (GLINITLAMBDATRAN 67196 . 67833) (GLLISPADJ 67837 . 68574) (
GLLISPISA 68578 . 69189) (GLMAKESTR 69193 . 70237) (GLMKLABEL 70241 . 
70575) (GLMKVAR 70579 . 70909) (GLNCONCFN 70913 . 72973) (GLNEQUALFN 
72977 . 73701) (GLOKSTR? 73705 . 75638) (GLOPERAND 75642 . 76477) (
GLOPERATOR? 76481 . 77069) (GLORFN 77073 . 77553) (GLPARSEXPR 77557 . 
79716) (GLPARSFLD 79720 . 81071) (GLPARSNFLD 81075 . 81864) (GLPLURAL 
81868 . 82775) (GLPOPFN 82779 . 84154) (GLPREC 84158 . 85236) (
GLPREDICATE 85240 . 88644) (GLPRETTYPRINTSTRS 88648 . 89551) (GLPROGN 
89555 . 90351) (GLPURE 90355 . 90701) (GLPUSHEXPR 90705 . 91258) (
GLPUSHFN 91262 . 93378) (GLPUTFN 93382 . 95589) (GLPUTUPFN 95593 . 96677
) (GLPUTPROPS 96681 . 97482) (GLREDUCE 97486 . 98480) (GLREDUCEARITH 
98484 . 100058) (GLREDUCEOP 100062 . 100863) (GLREMOVEFN 100867 . 102610
) (GLRESULTTYPE 102614 . 103669) (GLSEPCLR 103673 . 103798) (GLSEPINIT 
103802 . 104150) (GLSEPNXT 104154 . 106102) (GLSKIPCOMMENTS 106106 . 
106470) (GLSTRFN 106474 . 111955) (GLSTRPROP 111959 . 112760) (GLSTRVAL 
112764 . 113374) (GLSTRVALB 113378 . 113876) (GLSUBATOM 113880 . 114024)
 (GLTHE 114028 . 117150) (GLTRANSPARENTTYPES 117154 . 117586) (GLTRANSPB
 117590 . 118066) (GLUNITOP 118070 . 119157) (GLUNIT? 119161 . 119838) (
GLUNWRAP 119842 . 122190) (GLUNWRAPCOND 122194 . 122643) (GLUNWRAPPROG 
122647 . 123671) (GLUNWRAPSELECTQ 123675 . 124227) (GLUSERFN 124231 . 
125244) (GLUSERFNB 125248 . 126204) (GLVALUE 126208 . 127129) (GLVARTYPE
 127133 . 127631) (GLXTRTYPE 127635 . 128335)))))
STOP