(FILECREATED " 4-Dec-83 17:17:15" <CS.NOVAK>GLISPB.LSP.4 81971  


     changes to:  GLISPBCOMS GLPREDICATE GLREDUCEARITH GLUNWRAPMAP

     previous date: "28-Aug-83 08:48:51" <CS.NOVAK>GLISPB.LSP.3)


(PRETTYCOMPRINT GLISPBCOMS)

(RPAQQ GLISPBCOMS [(* Copyright (c)				       |
		      1983 by Gordon S. Novak Jr.)		       |
	(* This file, GLISPB, is one of three GLISP files. The others  |
	   are GLISPA and GLISPR.)				       |
	(FNS GLLISPADJ GLLISPISA GLMAKEFORLOOP GLMAKEGLISPVERSION      |
	     GLMAKEGLISPVERSIONS GLMAKESTR GLMAKEVTYPE GLMATCH GLMATCHL 
	     GLMINUSFN GLMKLABEL GLMKVTYPE GLNCONCFN GLNEQUALFN        |
	     GLNOTESOURCETYPE GLNOTFN GLOCCURS GLOPERAND GLOPERATOR?   |
	     GLORFN GLOUTPUTFILTER GLPARSEXPR GLPARSFLD GLPARSNFLD     |
	     GLPLURAL GLPOPFN GLPREC GLPREDICATE GLPRETTYPRINTCONST    |
	     GLPRETTYPRINTGLOBALS GLPRETTYPRINTSTRS GLPROGN GLPURE     |
	     GLPUSHEXPR GLPUSHFN GLPUTPROPS GLPUTUPFN GLREDUCE 	       |
	     GLREDUCEARITH GLREDUCEOP GLREMOVEFN GLRESGLOBAL 	       |
	     GLSAVEFNTYPES GLSEPCLR GLSEPINIT GLSEPNXT GLSKIPCOMMENTS  |
	     GLSUBATOM GLSUBLIS GLSUBSTTYPE GLTHE GLTHESPECS 	       |
	     GLTRANSPROG GLUNCOMPILE GLUNSAVEDEF GLUNWRAP GLUNWRAPCOND |
	     GLUNWRAPINTERSECT GLUNWRAPLOG GLUNWRAPMAP GLUNWRAPPROG    |
	     GLUNWRAPSELECTQ GLUPDATEVARTYPE GLUSERFN GLUSERFNB        |
	     GLUSERGETARGS GLVALUE GLVARTYPE GLXTRFN GLXTRTYPEB        |
	     GLXTRTYPEC)					       |
	(FILEPKGCOMS GLISPCONSTANTS GLISPGLOBALS GLISPOBJECTS)	       |
	(ADDVARS (LAMBDASPLST GLAMBDA)				       |
		 (LAMBDATRANFNS (GLAMBDA GLAMBDATRAN EXPR NIL))	       |
		 (PRETTYEQUIVLST (GLAMBDA . LAMBDA)))		       |
	(GLOBALVARS GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS       |
		    GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES 	       |
		    GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG     |
		    GLLISPDIALECT GLBASICTYPES GLOBJECTNAMES 	       |
		    GLTYPESUSED GLNOSPLITATOMS GLGLSENDFLG 	       |
		    GEVUSERTYPENAMES)				       |
	(SPECVARS CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR      |
		  GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS |
		  GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST        |
		  ADDISATYPE GLFNSUBS GLNRECURSIONS PAIRS NEW N)       |
	(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS   |
		  (ADDVARS (NLAMA)				       |
			   (NLAML)				       |
			   (LAMA])
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Copyright (c)
     1983 by Gordon S. Novak Jr.)  ]

[DECLARE: DONTEVAL@LOAD DONTCOPY
(* This file, GLISPB, is one of three GLISP files. The others are 
     GLISPA and GLISPR.)  ]

(DEFINEQ

(GLLISPADJ
  [LAMBDA (ADJ)                                 (* GSN " 4-MAR-83 13:53"
)

          (* Test the word ADJ to see if it is a LISP 
	  adjective. If so, return the CONS of the name of the
	  function to test it and the type of the result.)


    (PROG (TMP)
          (RETURN (AND [SETQ TMP (FASSOC (U-CASE ADJ)
					 (QUOTE ((ATOMIC ATOM ATOM)
						  (NULL NULL NIL)
						  (NIL NULL NIL)
						  (INTEGER FIXP INTEGER)
						  (REAL FLOATP REAL)
						  (BOUND BOUNDP ATOM)
						  (ZERO ZEROP NUMBER)
						  (NUMERIC NUMBERP 
							   NUMBER)
						  (NEGATIVE MINUSP 
							    NUMBER)
						  (MINUS MINUSP NUMBER]
		       (CDR TMP])

(GLLISPISA
  [LAMBDA (ISAWORD)                             (* GSN " 4-MAR-83 13:54"
)

          (* Test to see if ISAWORD is a LISP ISA word.
	  If so, return the CONS of the name of the function 
	  to test for it and the type of the result if true.)


    (PROG (TMP)
          (COND
	    ([SETQ TMP (FASSOC (U-CASE ISAWORD)
			       (QUOTE ((ATOM ATOM ATOM)
					(LIST LISTP (LISTOF ANYTHING))
					(NUMBER NUMBERP NUMBER)
					(INTEGER FIXP INTEGER)
					(SYMBOL LITATOM ATOM)
					(ARRAY ARRAYP ARRAY)
					(STRING STRINGP STRING)
					(BIGNUM BIGP BIGNUM)
					(LITATOM LITATOM ATOM]
	      (RETURN (CDR TMP])

(GLMAKEFORLOOP
  [LAMBDA (LOOPVAR DOMAIN LOOPCONTENTS LOOPCOND COLLECTCODE)
                                                (* edited: 
						"24-AUG-82 17:36")
                                                (* edited: 
						"21-Apr-81 11:25")
                                                (* Compile code for a 
						FOR loop.)
    (COND
      ((NULL COLLECTCODE)
	(LIST
	  [GLGENCODE
	    (LIST (QUOTE MAPC)
		  (CAR DOMAIN)
		  (LIST (QUOTE FUNCTION)
			(LIST (QUOTE LAMBDA)
			      (LIST LOOPVAR)
			      (COND
				(LOOPCOND (LIST (QUOTE COND)
						(CONS (CAR LOOPCOND)
						      LOOPCONTENTS)))
				((NULL (CDR LOOPCONTENTS))
				  (CAR LOOPCONTENTS))
				(T (CONS (QUOTE PROGN)
					 LOOPCONTENTS]
	  NIL))
      (T
	(LIST
	  [COND
	    [LOOPCOND
	      (GLGENCODE
		(LIST (QUOTE MAPCONC)
		      (CAR DOMAIN)
		      (LIST (QUOTE FUNCTION)
			    (LIST (QUOTE LAMBDA)
				  (LIST LOOPVAR)
				  (LIST (QUOTE AND)
					(CAR LOOPCOND)
					(LIST (QUOTE CONS)
					      (CAR COLLECTCODE)
					      NIL]
	    [(AND (LISTP (CAR COLLECTCODE))
		  (ATOM (CAAR COLLECTCODE))
		  (CDAR COLLECTCODE)
		  (EQ (CADAR COLLECTCODE)
		      LOOPVAR)
		  (NULL (CDDAR COLLECTCODE)))
	      (GLGENCODE (LIST (QUOTE MAPCAR)
			       (CAR DOMAIN)
			       (LIST (QUOTE FUNCTION)
				     (CAAR COLLECTCODE]
	    (T (GLGENCODE (LIST (QUOTE MAPCAR)
				(CAR DOMAIN)
				(LIST (QUOTE FUNCTION)
				      (LIST (QUOTE LAMBDA)
					    (LIST LOOPVAR)
					    (CAR COLLECTCODE]
	  (LIST (QUOTE LISTOF)
		(CADR COLLECTCODE])

(GLMAKEGLISPVERSION
  [LAMBDA (OUTPUTDIALECT)                       (* GSN "26-JUL-83 14:55"
)                                               (* Make a version of 
						GLISP for another LISP 
						dialect.)
    (PROG (FNS COMS FILE EXT)
          (LOAD? (QUOTE LISPTRANS.LSP))
          [SETQ EXT (CDR (ASSOC OUTPUTDIALECT (QUOTE ((FRANZLISP . 
							 FRANZ)
						       (MACLISP . MAC)
						       (PSL . PSL)
						       (UCILISP . UCI]
                                                (* Make a list of the 
						functions to be 
						translated.)
          (SETQ FNS (APPEND [CDR (ASSOC OUTPUTDIALECT
					(QUOTE ((FRANZLISP 
						      GLFRANZLISPFN 
						 GLFRANZLISPTRANSFM)
						 (MACLISP GLMACLISPFN 
						   GLMACLISPTRANSFM)
						 (PSL GLPSLFN 
						      GLPSLTRANSFM)
						 (UCILISP GLUCILISPFN 
						   GLUCILISPTRANSFM]
			    (LDIFFERENCE (CDR (ASSOC (QUOTE FNS)
						     GLISPRCOMS))
					 GLSPECIALFNS)))
          (SETQ COMS (COPY GLISPRCOMS))
          (GLFIXCOMS COMS (QUOTE FNS)
		     FNS)
          [GLFIXCOMS COMS (QUOTE P)
		     (LIST (LIST (QUOTE SETQ)
				 (QUOTE GLLISPDIALECT)
				 (LIST (QUOTE QUOTE)
				       OUTPUTDIALECT))
			   (QUOTE (GLINIT]
          [GLFIXCOMS COMS (QUOTE VARS)
		     (LDIFFERENCE (CDR (ASSOC (QUOTE VARS)
					      GLISPRCOMS))
				  (QUOTE (GLLISPDIALECT GLSPECIALFNS]
          (PUTPROP (QUOTE GLLISPDIALECT)
		   (QUOTE LISPTRANSEVALWHENCONST)
		   T)
          (PUTPROP (QUOTE GLLISPDIALECT)
		   (QUOTE LISPTRANSCONSTANTVALUE)
		   OUTPUTDIALECT)
          (RETURN
	    (LIST (LTRANCOMS OUTPUTDIALECT (MKATOM (CONCAT "GLISPR." 
							   EXT))
			     COMS)
		  (LTRANCOMS OUTPUTDIALECT (MKATOM (CONCAT "GLISPA." 
							   EXT))
			     (GLFIXCOMS
			       (COPY GLISPACOMS)
			       (QUOTE FNS)
			       (LDIFFERENCE (CDR (ASSOC (QUOTE FNS)
							GLISPACOMS))
					    GLSPECIALFNS)))
		  (LTRANCOMS OUTPUTDIALECT (MKATOM (CONCAT "GLISPB." 
							   EXT))
			     (GLFIXCOMS
			       (COPY GLISPBCOMS)
			       (QUOTE FNS)
			       (LDIFFERENCE (CDR (ASSOC (QUOTE FNS)
							GLISPBCOMS))
					    GLSPECIALFNS])

(GLMAKEGLISPVERSIONS
  [LAMBDA NIL                                   (* GSN "25-JUL-83 14:41"
)
    (MAPC (QUOTE (MACLISP FRANZLISP PSL UCILISP))
	  (FUNCTION (LAMBDA (X)
	      (TERPRI)
	      (PRINT (GLMAKEGLISPVERSION X))
	      (TERPRI])

(GLMAKESTR
  [LAMBDA (TYPE EXPR)                           (* GSN " 1-MAR-83 11:36"
)                                               (* Compile code to 
						create a structure in 
						response to a statement 
						
"(A <structure> WITH <field> = <value> ...)")
    (PROG (PAIRLIST STRDES)
          (COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (WITH With with)))
	      (pop EXPR)))
          [COND
	    ((NULL (SETQ STRDES (GLGETSTR TYPE)))
	      (GLERROR (QUOTE GLMAKESTR)
		       (LIST "The type name" TYPE "is not defined."]
          [COND
	    ((EQ (CAR STRDES)
		 (QUOTE LISTOF))
	      (RETURN (LIST [CONS (QUOTE LIST)
				  (MAPCAR EXPR
					  (FUNCTION (LAMBDA (EXPR)
					      (GLDOEXPR NIL CONTEXT T]
			    TYPE]
          (SETQ PAIRLIST (GLGETPAIRS EXPR))
          (RETURN (LIST (GLBUILDSTR STRDES PAIRLIST (LIST TYPE))
			TYPE])

(GLMAKEVTYPE
  [LAMBDA (ORIGTYPE VLIST)                      (* GSN " 3-FEB-83 12:12"
)                                               (* Make a virtual type 
						for a view of the 
						original type.)
    (PROG (SUPER PL PNAME TMP VTYPE)
          (SETQ SUPER (CADR VLIST))
          (SETQ VLIST (CDDR VLIST))
          [COND
	    ((MEMB (CAR VLIST)
		   (QUOTE (with With WITH)))
	      (SETQ VLIST (CDR VLIST]
      LP  (COND
	    ((NULL VLIST)
	      (GO OUT)))
          (SETQ PNAME (CAR VLIST))
          (SETQ VLIST (CDR VLIST))
          [COND
	    ((EQ (CAR VLIST)
		 (QUOTE =))
	      (SETQ VLIST (CDR VLIST]
          (SETQ TMP NIL)
      LPB (COND
	    ([OR (NULL VLIST)
		 (EQ (CAR VLIST)
		     (QUOTE ,))
		 (AND (ATOM (CAR VLIST))
		      (CDR VLIST)
		      (EQ (CADR VLIST)
			  (QUOTE =]
	      (SETQ PL (CONS (LIST PNAME (DREVERSE TMP))
			     PL))
	      [COND
		((AND VLIST (EQ (CAR VLIST)
				(QUOTE ,)))
		  (SETQ VLIST (CDR VLIST]
	      (GO LP)))
          (SETQ TMP (CONS (CAR VLIST)
			  TMP))
          (SETQ VLIST (CDR VLIST))
          (GO LPB)
      OUT (SETQ VTYPE (GLMKVTYPE))
          (PUTPROP VTYPE (QUOTE GLSTRUCTURE)
		   (LIST (LIST (QUOTE TRANSPARENT)
			       ORIGTYPE)
			 (QUOTE PROP)
			 PL
			 (QUOTE SUPERS)
			 (LIST SUPER)))
          (RETURN VTYPE])

(GLMATCH
  [LAMBDA (TNEW TINTO)                          (* GSN "25-FEB-83 16:08"
)

          (* Test whether an item of type TNEW could be stored
	  into a slot of type TINTO.)


    (PROG (TMP RES)
          (RETURN (COND
		    ([OR (EQ TNEW TINTO)
			 (NULL TINTO)
			 (EQ TINTO (QUOTE ANYTHING))
			 [AND (MEMB TNEW (QUOTE (INTEGER REAL NUMBER)))
			      (MEMB TINTO (QUOTE (NUMBER ATOM]
			 (AND (EQ TNEW (QUOTE ATOM))
			      (LISTP TINTO)
			      (EQ (CAR TINTO)
				  (QUOTE ATOM]
		      TNEW)
		    ((AND (SETQ TMP (GLXTRTYPEC TNEW))
			  (SETQ RES (GLMATCH TMP TINTO)))
		      RES)
		    ((AND (SETQ TMP (GLXTRTYPEC TINTO))
			  (SETQ RES (GLMATCH TNEW TMP)))
		      RES)
		    (T NIL])

(GLMATCHL
  [LAMBDA (TELEM TLIST)                         (* GSN "25-FEB-83 16:03"
)

          (* Test whether two types match as an element type 
	  and a list type. The result is the resulting element
	  type.)


    (PROG (TMP RES)
          (RETURN (COND
		    ((AND (LISTP TLIST)
			  (EQ (CAR TLIST)
			      (QUOTE LISTOF))
			  (GLMATCH TELEM (CADR TLIST)))
		      TELEM)
		    [(AND (SETQ TMP (GLXTRTYPEC TLIST))
			  (SETQ RES (GLMATCHL TELEM TMP]
		    (T NIL])

(GLMINUSFN
  [LAMBDA (LHS)                                 (* GSN "22-JUL-83 13:57"
)                                               (* Construct the 
						negative of the argument
						LHS.)
    (OR (GLDOMSG LHS (QUOTE MINUS)
		 NIL)
	(GLUSERSTROP LHS (QUOTE MINUS)
		     NIL)
	(LIST [GLGENCODE (COND
			   ((NUMBERP (CAR LHS))
			     (MINUS (CAR LHS)))
			   ((EQ (GLXTRTYPE (CADR LHS))
				(QUOTE INTEGER))
			     (LIST (QUOTE IMINUS)
				   (CAR LHS)))
			   (T (LIST (QUOTE MINUS)
				    (CAR LHS]
	      (CADR LHS])

(GLMKLABEL
  [LAMBDA NIL                                   (* edited: 
						"27-MAY-82 11:02")
                                                (* Make a variable name 
						for GLCOMP functions.)
    (PROG NIL
          (SETQ GLNATOM (ADD1 GLNATOM))
          (RETURN (PACK (APPEND (QUOTE (G L L A B E L))
				(UNPACK GLNATOM])

(GLMKVTYPE
  [LAMBDA NIL                                   (* edited: 
						"18-NOV-82 11:58")
                                                (* Make a virtual type 
						name for GLCOMP 
						functions.)
    (GLMKATOM (QUOTE GLVIRTUALTYPE])

(GLNCONCFN
  [LAMBDA (LHS RHS)                             (* GSN "25-JAN-83 16:47"
)                                               (* edited: 
						" 2-Jun-81 14:18")
                                                (* edited: 
						"21-Apr-81 11:26")

          (* Produce a function to implement the _+ operator.
	  Code is produced to append the right-hand side to 
	  the left-hand side. Note: parts of the structure 
	  provided are used multiple times.)


    (PROG (LHSCODE LHSDES NCCODE TMP STR)
          (SETQ LHSCODE (CAR LHS))
          (SETQ LHSDES (GLXTRTYPE (CADR LHS)))
          (COND
	    [(EQ LHSDES (QUOTE INTEGER))
	      (COND
		((EQP (CAR RHS)
		      1)
		  (SETQ NCCODE (LIST (QUOTE ADD1)
				     LHSCODE)))
		[(OR (FIXP (CAR RHS))
		     (EQ (CADR RHS)
			 (QUOTE INTEGER)))
		  (SETQ NCCODE (LIST (QUOTE IPLUS)
				     LHSCODE
				     (CAR RHS]
		(T (SETQ NCCODE (LIST (QUOTE PLUS)
				      LHSCODE
				      (CAR RHS]
	    [(OR (EQ LHSDES (QUOTE NUMBER))
		 (EQ LHSDES (QUOTE REAL)))
	      (SETQ NCCODE (LIST (QUOTE PLUS)
				 LHSCODE
				 (CAR RHS]
	    [(EQ LHSDES (QUOTE BOOLEAN))
	      (SETQ NCCODE (LIST (QUOTE OR)
				 LHSCODE
				 (CAR RHS]
	    [(NULL LHSDES)
	      (SETQ NCCODE (LIST (QUOTE NCONC1)
				 LHSCODE
				 (CAR RHS)))
	      (COND
		((AND (ATOM LHSCODE)
		      (CADR RHS))
		  (GLUPDATEVARTYPE LHSCODE (LIST (QUOTE LISTOF)
						 (CADR RHS]
	    [[AND (LISTP LHSDES)
		  (EQ (CAR LHSDES)
		      (QUOTE LISTOF))
		  (NOT (EQUAL LHSDES (CADR RHS]
	      (SETQ NCCODE (LIST (QUOTE NCONC1)
				 LHSCODE
				 (CAR RHS]
	    ((SETQ TMP (GLUNITOP LHS RHS (QUOTE NCONC)))
	      (RETURN TMP))
	    ((SETQ TMP (GLDOMSG LHS (QUOTE _+)
				(LIST RHS)))
	      (RETURN TMP))
	    ((SETQ TMP (GLDOMSG LHS (QUOTE +)
				(LIST RHS)))
	      (SETQ NCCODE (CAR TMP)))
	    [(AND (SETQ STR (GLGETSTR LHSDES))
		  (SETQ TMP (GLNCONCFN (LIST (CAR LHS)
					     STR)
				       RHS)))
	      (RETURN (LIST (CAR TMP)
			    (CADR LHS]
	    ((SETQ TMP (GLUSERSTROP LHS (QUOTE _+)
				    RHS))
	      (RETURN TMP))
	    ((SETQ TMP (GLREDUCEARITH (QUOTE +)
				      LHS RHS))
	      (SETQ NCCODE (CAR TMP)))
	    (T (RETURN)))
          (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE)
				     LHSDES)
			   T])

(GLNEQUALFN
  [LAMBDA (LHS RHS)                             (* edited: 
						"23-DEC-82 10:49")
                                                (* edited: 
						" 6-Jan-81 16:11")
                                                (* Produce code to test 
						the two sides for 
						inequality.)
    (PROG (TMP)
          (COND
	    ((SETQ TMP (GLDOMSG LHS (QUOTE ~=)
				(LIST RHS)))
	      (RETURN TMP))
	    ((SETQ TMP (GLUSERSTROP LHS (QUOTE ~=)
				    RHS))
	      (RETURN TMP))
	    [(OR (GLATOMTYPEP (CADR LHS))
		 (GLATOMTYPEP (CADR RHS)))
	      (RETURN (LIST (GLGENCODE (LIST (QUOTE NEQ)
					     (CAR LHS)
					     (CAR RHS)))
			    (QUOTE BOOLEAN]
	    (T (RETURN (LIST [GLGENCODE (LIST (QUOTE NOT)
					      (CAR (GLEQUALFN LHS RHS]
			     (QUOTE BOOLEAN])

(GLNOTESOURCETYPE
  [LAMBDA (SOURCE TYPE ADDISATYPE)              (* GSN " 7-MAR-83 16:55"
)

          (* If SOURCE represents a variable name, add the 
	  TYPE of SOURCE to the CONTEXT.)


    (PROG (TMP)
          (RETURN (COND
		    (ADDISATYPE (COND
				  ((ATOM (CAR SOURCE))
				    (GLADDSTR (CAR SOURCE)
					      NIL TYPE CONTEXT))
				  ((AND (LISTP (CAR SOURCE))
					(MEMB (CAAR SOURCE)
					      (QUOTE (SETQ PROG1)))
					(ATOM (CADAR SOURCE)))
				    (GLADDSTR (CADAR SOURCE)
					      (COND
						((SETQ TMP
						    (GLFINDVARINCTX
						      (CAR SOURCE)
						      CONTEXT))
						  (CADR TMP)))
					      TYPE CONTEXT])

(GLNOTFN
  [LAMBDA (LHS)                                 (* edited: 
						" 3-MAY-82 14:35")
                                                (* Construct the NOT of 
						the argument LHS.)
    (OR (GLDOMSG LHS (QUOTE ~)
		 NIL)
	(GLUSERSTROP LHS (QUOTE ~)
		     NIL)
	(LIST (GLBUILDNOT (CAR LHS))
	      (QUOTE BOOLEAN])

(GLOCCURS
  [LAMBDA (X STR)                               (* edited: 
						" 3-JUN-82 11:02")
                                                (* See if X occurs in 
						STR, using EQ.)
    (COND
      ((EQ X STR)
	T)
      ((NLISTP STR)
	NIL)
      (T (OR (GLOCCURS X (CAR STR))
	     (GLOCCURS X (CDR STR])

(GLOPERAND
  [LAMBDA NIL                                   (* edited: 
						"30-DEC-81 16:41")
                                                (* "GSN: " 
						"17-Sep-81 14:00")
                                                (* "GSN: " 
						" 9-Apr-81 12:12")

          (* Get the next operand from the input list, EXPR 
	  (global). The operand may be an atom 
	  (possibly containing operators) or a list.)


    (PROG NIL
          (COND
	    ((SETQ FIRST (GLSEPNXT))
	      (RETURN (GLPARSNFLD)))
	    ((NULL EXPR)
	      (RETURN))
	    [(STRINGP (CAR EXPR))
	      (RETURN (LIST (pop EXPR)
			    (QUOTE STRING]
	    ((ATOM (CAR EXPR))
	      (GLSEPINIT (pop EXPR))
	      (SETQ FIRST (GLSEPNXT))
	      (RETURN (GLPARSNFLD)))
	    (T (RETURN (GLPUSHEXPR (pop EXPR)
				   T CONTEXT T])

(GLOPERATOR?
  [LAMBDA (ATM)                                 (* GSN " 4-MAR-83 14:26"
)                                               (* Test if an atom is a 
						GLISP operator)
    (FMEMB ATM
	   (QUOTE (_ := __ + - * / > < >= <= ^ _+ +_ _- -_ = ~= <> AND 
		     And and OR Or or __+ __- _+_])

(GLORFN
  [LAMBDA (LHS RHS)                             (* edited: 
						"26-DEC-82 15:48")
                                                (* "GSN: " 
						" 8-Jan-81 17:05")
                                                (* OR operator)
    (COND
      ((AND (LISTP (CADR LHS))
	    (EQ (CAADR LHS)
		(QUOTE LISTOF))
	    (EQUAL (CADR LHS)
		   (CADR RHS)))
	(LIST (LIST (QUOTE UNION)
		    (CAR LHS)
		    (CAR RHS))
	      (CADR LHS)))
      ((GLDOMSG LHS (QUOTE OR)
		(LIST RHS)))
      ((GLUSERSTROP LHS (QUOTE OR)
		    RHS))
      (T (LIST (LIST (QUOTE OR)
		     (CAR LHS)
		     (CAR RHS))
	       (COND
		 ((EQUAL (GLXTRTYPE (CADR LHS))
			 (GLXTRTYPE (CADR RHS)))
		   (CADR LHS))
		 (T NIL])

(GLOUTPUTFILTER
  [LAMBDA (PROPTYPE LST)                        (* GSN "10-FEB-83 16:13"
)                                               (* Remove unwanted 
						system properties from 
						LST for making an output
						file.)
    (COND
      [(MEMB PROPTYPE (QUOTE (PROP ADJ ISA MSG)))
	(MAPCONC
	  LST
	  (FUNCTION (LAMBDA (L)
	      (COND
		((LISTGET (CDDR L)
			  (QUOTE SPECIALIZATION))
		  NIL)
		(T
		  (LIST
		    (CONS
		      (CAR L)
		      (CONS (CADR L)
			    (MAPCON (CDDR L)
				    [FUNCTION (LAMBDA (PAIR)
					(COND
					  ((MEMB (CAR PAIR)
						 (QUOTE (VTYPE)))
					    NIL)
					  (T (LIST (CAR PAIR)
						   (CADR PAIR]
				    (FUNCTION CDDR]
      (T LST])

(GLPARSEXPR
  [LAMBDA NIL                                   (* edited: 
						"22-SEP-82 17:16")
                                                (* edited: 
						"23-Jun-81 14:35")
                                                (* edited: 
						"14-Apr-81 12:25")
                                                (* edited: 
						" 9-Apr-81 11:32")

          (* Subroutine of GLDOEXPR to parse a GLISP 
	  expression containing field specifications and/or 
	  operators. The global variable EXPR is used, and is 
	  modified to reflect the amount of the expression 
	  which has been parsed.)


    (PROG (OPNDS OPERS FIRST LHSP RHSP)         (* Get the initial part 
						of the expression, i.e.,
						variable or field 
						specification.)
      L   (SETQ OPNDS (CONS (GLOPERAND)
			    OPNDS))
      M   [COND
	    [(NULL FIRST)
	      (COND
		([OR (NULL EXPR)
		     (NOT (ATOM (CAR EXPR]
		  (GO B)))
	      (GLSEPINIT (CAR EXPR))
	      (COND
		((GLOPERATOR? (SETQ FIRST (GLSEPNXT)))
		  (pop EXPR)
		  (GO A))
		[(MEMB FIRST (QUOTE (IS Is is HAS Has has)))
		  (COND
		    ((AND OPERS (IGREATERP (GLPREC (CAR OPERS))
					   5))
		      (GLREDUCE)
		      (SETQ FIRST NIL)
		      (GO M))
		    (T (SETQ OPNDS
			 (CONS (GLPREDICATE (pop OPNDS)
					    CONTEXT T
					    (AND (BOUNDP (QUOTE 
							 ADDISATYPE))
						 ADDISATYPE))
			       OPNDS))
		       (SETQ FIRST NIL)
		       (GO M]
		(T (GLSEPCLR)
		   (GO B]
	    ((GLOPERATOR? FIRST)
	      (GO A))
	    (T (GLERROR (QUOTE GLPARSEXPR)
			(LIST FIRST 
		      "appears illegally or cannot be interpreted."]
                                                (* FIRST now contains an
						operator)
      A                                         (* While top operator < 
						top of stack in 
						precedence, reduce.)
          (COND
	    ([NOT (OR (NULL OPERS)
		      (ILESSP (SETQ LHSP (GLPREC (CAR OPERS)))
			      (SETQ RHSP (GLPREC FIRST)))
		      (AND (EQP LHSP RHSP)
			   (MEMB FIRST (QUOTE (_ ^ :=]
	      (GLREDUCE)
	      (GO A)))                          (* Push new operator 
						onto the operator 
						stack.)
          (SETQ OPERS (CONS FIRST OPERS))
          (GO L)
      B   (COND
	    (OPERS (GLREDUCE)
		   (GO B)))
          (RETURN (CAR OPNDS])

(GLPARSFLD
  [LAMBDA (PREV)                                (* edited: 
						"30-DEC-82 10:55")
                                                (* "GSN: " 
						"23-Jun-81 15:28")
                                                (* "GSN: " 
						"21-Apr-81 11:26")

          (* Parse a field specification of the form 
	  var:field:field... Var may be missing, and there may
	  be zero or more fields. The variable FIRST is used 
	  globally; it contains the first atom of the group on
	  entry, and the next atom on exit.)


    (PROG (FIELD TMP)
          [COND
	    ((NULL PREV)
	      (COND
		[(EQ FIRST (QUOTE '))
		  (COND
		    [(SETQ TMP (GLSEPNXT))
		      (SETQ FIRST (GLSEPNXT))
		      (RETURN (LIST (KWOTE TMP)
				    (QUOTE ATOM]
		    [EXPR (SETQ FIRST NIL)
			  (SETQ TMP (pop EXPR))
			  (RETURN (LIST (KWOTE TMP)
					(GLCONSTANTTYPE TMP]
		    (T (RETURN]
		((MEMB FIRST (QUOTE (THE The the)))
		  (SETQ TMP (GLTHE NIL))
		  (SETQ FIRST NIL)
		  (RETURN TMP))
		((NEQ FIRST (QUOTE :))
		  (SETQ PREV FIRST)
		  (SETQ FIRST (GLSEPNXT]
      A   (COND
	    [(EQ FIRST (QUOTE :))
	      (COND
		((SETQ FIELD (GLSEPNXT))
		  (SETQ PREV (GLGETFIELD PREV FIELD CONTEXT))
		  (SETQ FIRST (GLSEPNXT))
		  (GO A]
	    (T (RETURN (COND
			 ((EQ PREV (QUOTE *NIL*))
			   (LIST NIL NIL))
			 (T (GLIDNAME PREV T])

(GLPARSNFLD
  [LAMBDA NIL                                   (* edited: 
						"20-MAY-82 11:30")
                                                (* "GSN: " 
						" 8-Jan-81 13:45")
                                                (* Parse a field 
						specification which may 
						be preceded by a ~.)
    (PROG (TMP UOP)
          (COND
	    [(OR (EQ FIRST (QUOTE ~))
		 (EQ FIRST (QUOTE -)))
	      (SETQ UOP FIRST)
	      [COND
		((SETQ FIRST (GLSEPNXT))
		  (SETQ TMP (GLPARSFLD NIL)))
		((AND EXPR (ATOM (CAR EXPR)))
		  (GLSEPINIT (pop EXPR))
		  (SETQ FIRST (GLSEPNXT))
		  (SETQ TMP (GLPARSFLD NIL)))
		((AND EXPR (LISTP (CAR EXPR)))
		  (SETQ TMP (GLPUSHEXPR (pop EXPR)
					T CONTEXT T)))
		(T (RETURN (LIST UOP NIL]
	      (RETURN (COND
			((EQ UOP (QUOTE ~))
			  (GLNOTFN TMP))
			(T (GLMINUSFN TMP]
	    (T (RETURN (GLPARSFLD NIL])

(GLPLURAL
  [LAMBDA (WORD)                                (* edited: 
						"27-MAY-82 10:42")
                                                (* Form the plural of a 
						given word.)
    (PROG (TMP LST UCASE ENDING)
          (COND
	    ((SETQ TMP (GETPROP WORD (QUOTE PLURAL)))
	      (RETURN TMP)))
          (SETQ LST (DREVERSE (UNPACK WORD)))
          (SETQ UCASE (U-CASEP (CAR LST)))
          [COND
	    [[AND (MEMB (CAR LST)
			(QUOTE (Y y)))
		  (NOT (MEMB (CADR LST)
			     (QUOTE (A a E e O o U u]
	      (SETQ LST (CDR LST))
	      (SETQ ENDING (OR (AND UCASE (QUOTE (S E I)))
			       (QUOTE (s e i]
	    [(MEMB (CAR LST)
		   (QUOTE (S s X x)))
	      (SETQ ENDING (OR (AND UCASE (QUOTE (S E)))
			       (QUOTE (s e]
	    (T (SETQ ENDING (OR (AND UCASE (QUOTE (S)))
				(QUOTE (s]
          (RETURN (PACK (DREVERSE (APPEND ENDING LST])

(GLPOPFN
  [LAMBDA (LHS RHS)                             (* edited: 
						"29-DEC-82 12:40")
                                                (* "GSN: " 
						"20-Mar-81 14:44")

          (* Produce a function to implement the -_ 
	  (pop) operator. Code is produced to remove one 
	  element from the right-hand side and assign it to 
	  the left-hand side.)


    (PROG (RHSCODE RHSDES POPCODE GETCODE TMP STR)
          (SETQ RHSCODE (CAR RHS))
          (SETQ RHSDES (GLXTRTYPE (CADR RHS)))
          [COND
	    ((AND (LISTP RHSDES)
		  (EQ (CAR RHSDES)
		      (QUOTE LISTOF)))
	      (SETQ POPCODE (GLPUTFN RHS (LIST (LIST (QUOTE CDR)
						     RHSCODE)
					       RHSDES)
				     T))
	      (SETQ GETCODE (GLPUTFN LHS (LIST (LIST (QUOTE CAR)
						     (CAR RHS))
					       (CADR RHSDES))
				     NIL)))
	    ((EQ RHSDES (QUOTE BOOLEAN))
	      (SETQ POPCODE (GLPUTFN RHS (QUOTE (NIL NIL))
				     NIL))
	      (SETQ GETCODE (GLPUTFN LHS RHS NIL)))
	    ((SETQ TMP (GLDOMSG RHS (QUOTE -_)
				(LIST LHS)))
	      (RETURN TMP))
	    ([AND (SETQ STR (GLGETSTR RHSDES))
		  (SETQ TMP (GLPOPFN LHS (LIST (CAR RHS)
					       STR]
	      (RETURN TMP))
	    ((SETQ TMP (GLUSERSTROP RHS (QUOTE -_)
				    LHS))
	      (RETURN TMP))
	    ((OR (GLATOMTYPEP RHSDES)
		 (AND (NEQ RHSDES (QUOTE ANYTHING))
		      (MEMB (GLXTRTYPEB RHSDES)
			    GLBASICTYPES)))
	      (RETURN))
	    (T                                  (* If all else fails, 
						assume a list.)
	       (SETQ POPCODE (GLPUTFN RHS (LIST (LIST (QUOTE CDR)
						      RHSCODE)
						RHSDES)
				      T))
	       (SETQ GETCODE (GLPUTFN LHS (LIST (LIST (QUOTE CAR)
						      (CAR RHS))
						(CADR RHSDES))
				      NIL]
          (RETURN (LIST (LIST (QUOTE PROG1)
			      (CAR GETCODE)
			      (CAR POPCODE))
			(CADR GETCODE])

(GLPREC
  [LAMBDA (OP)                                  (* edited: 
						"30-OCT-82 14:36")
                                                (* edited: 
						"17-Sep-81 13:29")
                                                (* edited: 
						"14-Aug-81 14:22")
                                                (* edited: 
						"21-Apr-81 11:27")
                                                (* Precedence numbers 
						for operators)
    (PROG (TMP)
          (COND
	    ([SETQ TMP (FASSOC OP (QUOTE ((_ . 1)
					   (:= . 1)
					   (__ . 1)
					   (_+ . 2)
					   (__+ . 2)
					   (+_ . 2)
					   (_+_ . 2)
					   (_- . 2)
					   (__- . 2)
					   (-_ . 2)
					   (= . 5)
					   (~= . 5)
					   (<> . 5)
					   (AND . 4)
					   (And . 4)
					   (and . 4)
					   (OR . 3)
					   (Or . 3)
					   (or . 3)
					   (/ . 7)
					   (+ . 6)
					   (- . 6)
					   (> . 5)
					   (< . 5)
					   (>= . 5)
					   (<= . 5)
					   (^ . 8]
	      (RETURN (CDR TMP)))
	    ((EQ OP (QUOTE *))
	      (RETURN 7))
	    (T (RETURN 10])

(GLPREDICATE
  [LAMBDA (SOURCE CONTEXT VERBFLG ADDISATYPE)   (* "GSN: " 
						" 4-Dec-83 17:03")

          (* Get a predicate specification from the EXPR 
	  (referenced globally) and return code to test the 
	  SOURCE for that predicate. VERBFLG is true if a verb
	  is expected as the top of EXPR.)


    (DECLARE (SPECVARS NOTFLG ADDISATYPE))
    (PROG (NEWPRED SETNAME PROPERTY TMP NOTFLG)
          [COND
	    ((NULL VERBFLG)
	      (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T)))
	    ((NULL SOURCE)
	      (GLERROR (QUOTE GLPREDICATE)
		       (LIST 
		   "The object to be tested was not found.  EXPR ="
			     EXPR)))
	    ((MEMB (CAR EXPR)
		   (QUOTE (HAS Has has)))
	      (pop EXPR)
	      (COND
		((MEMB (CAR EXPR)
		       (QUOTE (NO No no)))
		  (SETQ NOTFLG T)
		  (pop EXPR)))
	      (SETQ NEWPRED (GLDOEXPR NIL CONTEXT T)))
	    ((MEMB (CAR EXPR)
		   (QUOTE (IS Is is ARE Are are)))
	      (pop EXPR)
	      (COND
		((MEMB (CAR EXPR)
		       (QUOTE (NOT Not not)))
		  (SETQ NOTFLG T)
		  (pop EXPR)))
	      (COND
		[(GL-A-AN? (CAR EXPR))
		  (pop EXPR)
		  (SETQ SETNAME (pop EXPR))
		                                (* The condition is to 
						test whether SOURCE IS A
						SETNAME.)
		  (COND
		    [(SETQ NEWPRED (GLADJ SOURCE SETNAME (QUOTE ISA]
		    ((SETQ NEWPRED (GLADJ (LIST (CAR SOURCE)
						SETNAME)
					  SETNAME
					  (QUOTE ISASELF)))
		      (GLNOTESOURCETYPE SOURCE SETNAME ADDISATYPE))
		    ((SETQ TMP (GLLISPISA SETNAME))
		      (SETQ NEWPRED (LIST (GLGENCODE
					    (LIST (CAR TMP)
						  (CAR SOURCE)))
					  (QUOTE BOOLEAN)))
		      (GLNOTESOURCETYPE SOURCE (CADR TMP)
					ADDISATYPE))
		    ((GLCLASSP SETNAME)
		      (SETQ NEWPRED (LIST (LIST (QUOTE GLCLASSMEMP)
						(CAR SOURCE)
						(KWOTE SETNAME))
					  (QUOTE BOOLEAN)))
		      (GLNOTESOURCETYPE SOURCE SETNAME ADDISATYPE))    |
		    (T (GLERROR (QUOTE GLPREDICATE)
				(LIST "IS A adjective" SETNAME 
				      "could not be found for"
				      (CAR SOURCE)
				      "whose type is"
				      (CADR SOURCE)))
		       (SETQ NEWPRED (LIST (LIST (QUOTE GLERR)
						 (CAR SOURCE)
						 (QUOTE IS)
						 (QUOTE A)
						 SETNAME)
					   (QUOTE BOOLEAN]
		(T (SETQ PROPERTY (CAR EXPR))
		                                (* The condition to test
						is whether SOURCE is 
						PROPERTY.)
		   (COND
		     ((SETQ NEWPRED (GLADJ SOURCE PROPERTY
					   (QUOTE ADJ)))
		       (pop EXPR))
		     ((SETQ TMP (GLLISPADJ PROPERTY))
		       (pop EXPR)
		       (SETQ NEWPRED (LIST (GLGENCODE
					     (LIST (CAR TMP)
						   (CAR SOURCE)))
					   (QUOTE BOOLEAN)))
		       (GLNOTESOURCETYPE SOURCE (CADR TMP)
					 ADDISATYPE))
		     (T (GLERROR (QUOTE GLPREDICATE)
				 (LIST "The adjective" PROPERTY 
				       "could not be found for"
				       (CAR SOURCE)
				       "whose type is"
				       (CADR SOURCE)))
			(pop EXPR)
			(SETQ NEWPRED (LIST (LIST (QUOTE GLERR)
						  (CAR SOURCE)
						  (QUOTE IS)
						  PROPERTY)
					    (QUOTE BOOLEAN]
          (RETURN (COND
		    (NOTFLG (LIST (GLBUILDNOT (CAR NEWPRED))
				  (QUOTE BOOLEAN)))
		    (T NEWPRED])

(GLPRETTYPRINTCONST
  [LAMBDA (LST)                                 (* edited: 
						"21-APR-82 16:06")
    (PROG NIL
          (TERPRI)
          (TERPRI)
          (PRIN1 (QUOTE %[))
          (PRIN1 (QUOTE GLISPCONSTANTS))
          [MAPC LST
		(FUNCTION (LAMBDA (X)
		    (printout NIL T T "(" .FONT LAMBDAFONT X .FONT 
			      DEFAULTFONT .SP 3 .PPV
			      (GETPROP X (QUOTE GLISPORIGCONSTVAL))
			      .SP 3 .PPV (GETPROP X (QUOTE 
						  GLISPCONSTANTTYPE))
			      "  )"]
          (TERPRI)
          (PRIN1 (QUOTE %]))
          (TERPRI)
          (TERPRI])

(GLPRETTYPRINTGLOBALS
  [LAMBDA (LST)                                 (* edited: 
						"23-APR-82 16:53")
    (PROG NIL
          (TERPRI)
          (TERPRI)
          (PRIN1 (QUOTE %[))
          (PRIN1 (QUOTE GLISPGLOBALS))
          [MAPC LST
		(FUNCTION (LAMBDA (X)
		    (printout NIL T T "(" .FONT LAMBDAFONT X .FONT 
			      DEFAULTFONT .SP 3 .PPV
			      (GETPROP X (QUOTE GLISPGLOBALVARTYPE))
			      "  )"]
          (TERPRI)
          (PRIN1 (QUOTE %]))
          (TERPRI)
          (TERPRI])

(GLPRETTYPRINTSTRS
  [LAMBDA (LST)                                 (* GSN "10-FEB-83 16:14"
)                                               (* Pretty-print GLISP 
						structure definitions 
						for file package 
						output.)
    (PROG (TMP OBJ)
          (TERPRI)
          (TERPRI)
          (PRIN1 (QUOTE %[))
          (PRINT (QUOTE GLISPOBJECTS))
      LP  (COND
	    ((NULL LST)
	      (TERPRI)
	      (PRIN1 (QUOTE %]))
	      (TERPRI)
	      (TERPRI)
	      (RETURN)))
          (SETQ OBJ (pop LST))
          (COND
	    ((SETQ TMP (GETPROP OBJ (QUOTE GLSTRUCTURE)))
	      (printout NIL T T "(" .FONT LAMBDAFONT OBJ .FONT 
			DEFAULTFONT T T 3 .PPV (CAR TMP))
	      (MAP (CDR TMP)
		   [FUNCTION (LAMBDA (REST)
		       (printout NIL T T 3 (CAR REST)
				 10 .PPV (GLOUTPUTFILTER (CAR REST)
							 (CADR REST]
		   (FUNCTION CDDR))
	      (printout NIL "  )")))
          (GO LP])

(GLPROGN
  [LAMBDA (EXPR CONTEXT)                        (* edited: 
						"25-MAY-82 16:09")
                                                (* "GSN: " 
						"13-Aug-81 14:23")
                                                (* "GSN: " 
						"21-Apr-81 11:28")
                                                (* Compile an implicit 
						PROGN, that is, a list 
						of items.)
    (PROG (RESULT TMP TYPE GLSEPATOM GLSEPPTR)
          (SETQ GLSEPPTR 0)
      A   (COND
	    ((NULL EXPR)
	      (RETURN (LIST (DREVERSE RESULT)
			    TYPE)))
	    ((SETQ TMP (GLDOEXPR NIL CONTEXT VALBUSY))
	      (SETQ RESULT (CONS (CAR TMP)
				 RESULT))
	      (SETQ TYPE (CADR TMP))
	      (GO A))
	    (T (GLERROR (QUOTE GLPROGN)
			(LIST 
		  "Illegal item appears in implicit PROGN.  EXPR ="
			      EXPR])

(GLPURE
  [LAMBDA (X)                                   (* edited: 
						" 4-JUN-82 13:37")

          (* Test if the function X is a pure computation, 
	  i.e., can be eliminated if the result is not used.)


    (FMEMB X
	   (QUOTE (CAR CDR CXR CAAR CADR CDAR CDDR ADD1 SUB1 CADDR 
		       CADDDR])

(GLPUSHEXPR
  [LAMBDA (EXPR START CONTEXT VALBUSY)          (* edited: 
						"25-MAY-82 16:10")
                                                (* "GSN: " 
						"17-Sep-81 13:59")
                                                (* "GSN: " 
						" 7-Apr-81 10:33")

          (* This function serves to call GLDOEXPR with a new 
	  expression, rebinding the global variable EXPR.)


    (PROG (GLSEPATOM GLSEPPTR)
          (SETQ GLSEPPTR 0)
          (RETURN (GLDOEXPR START CONTEXT VALBUSY])

(GLPUSHFN
  [LAMBDA (LHS RHS)                             (* GSN "25-JAN-83 16:48"
)                                               (* edited: 
						" 2-Jun-81 14:19")
                                                (* edited: 
						"21-Apr-81 11:28")

          (* Produce a function to implement the +_ operator.
	  Code is produced to push the right-hand side onto 
	  the left-hand side. Note: parts of the structure 
	  provided are used multiple times.)


    (PROG (LHSCODE LHSDES NCCODE TMP STR)
          (SETQ LHSCODE (CAR LHS))
          (SETQ LHSDES (GLXTRTYPE (CADR LHS)))
          (COND
	    [(EQ LHSDES (QUOTE INTEGER))
	      (COND
		((EQP (CAR RHS)
		      1)
		  (SETQ NCCODE (LIST (QUOTE ADD1)
				     LHSCODE)))
		[(OR (FIXP (CAR RHS))
		     (EQ (CADR RHS)
			 (QUOTE INTEGER)))
		  (SETQ NCCODE (LIST (QUOTE IPLUS)
				     LHSCODE
				     (CAR RHS]
		(T (SETQ NCCODE (LIST (QUOTE PLUS)
				      LHSCODE
				      (CAR RHS]
	    [(OR (EQ LHSDES (QUOTE NUMBER))
		 (EQ LHSDES (QUOTE REAL)))
	      (SETQ NCCODE (LIST (QUOTE PLUS)
				 LHSCODE
				 (CAR RHS]
	    [(EQ LHSDES (QUOTE BOOLEAN))
	      (SETQ NCCODE (LIST (QUOTE OR)
				 LHSCODE
				 (CAR RHS]
	    [(NULL LHSDES)
	      (SETQ NCCODE (LIST (QUOTE CONS)
				 (CAR RHS)
				 LHSCODE))
	      (COND
		((AND (ATOM LHSCODE)
		      (CADR RHS))
		  (GLUPDATEVARTYPE LHSCODE (LIST (QUOTE LISTOF)
						 (CADR RHS]
	    ([AND (LISTP LHSDES)
		  (MEMB (CAR LHSDES)
			(QUOTE (LIST CONS LISTOF]
	      (SETQ NCCODE (LIST (QUOTE CONS)
				 (CAR RHS)
				 LHSCODE)))
	    ((SETQ TMP (GLUNITOP LHS RHS (QUOTE PUSH)))
	      (RETURN TMP))
	    ((SETQ TMP (GLDOMSG LHS (QUOTE +_)
				(LIST RHS)))
	      (RETURN TMP))
	    ((SETQ TMP (GLDOMSG LHS (QUOTE +)
				(LIST RHS)))
	      (SETQ NCCODE (CAR TMP)))
	    [(AND (SETQ STR (GLGETSTR LHSDES))
		  (SETQ TMP (GLPUSHFN (LIST (CAR LHS)
					    STR)
				      RHS)))
	      (RETURN (LIST (CAR TMP)
			    (CADR LHS]
	    ((SETQ TMP (GLUSERSTROP LHS (QUOTE +_)
				    RHS))
	      (RETURN TMP))
	    ((SETQ TMP (GLREDUCEARITH (QUOTE +)
				      RHS LHS))
	      (SETQ NCCODE (CAR TMP)))
	    (T (RETURN)))
          (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE)
				     LHSDES)
			   T])

(GLPUTPROPS
  [LAMBDA (PROPLIS PREVLST)                     (* edited: 
						"27-MAY-82 13:07")

          (* This function appends PUTPROP calls to the list 
	  PROGG (global) so that ATOMNAME has its property 
	  list built.)


    (PROG (TMP TMPCODE)
      A   (COND
	    ((NULL PROPLIS)
	      (RETURN)))
          (SETQ TMP (pop PROPLIS))
          [COND
	    ((SETQ TMPCODE (GLBUILDSTR TMP PAIRLIST PREVLST))
	      (NCONC1 PROGG (GLGENCODE (LIST (QUOTE PUTPROP)
					     (QUOTE ATOMNAME)
					     (KWOTE (CAR TMP))
					     TMPCODE]
          (GO A])

(GLPUTUPFN
  [LAMBDA (OP LHS RHS)                          (* edited: 
						"26-JAN-82 10:29")

          (* This function implements the __ operator, which 
	  is interpreted as assignment to the source of a 
	  variable (usually "self") outside an open-compiled 
	  function. Any other use of __ is illegal.)


    (PROG (TMP TMPOP)
          (OR [SETQ TMPOP (ASSOC OP (QUOTE ((__ . _)
					     (__+ . _+)
					     (__- . _-)
					     (_+_ . +_]
	      (ERROR (LIST (QUOTE GLPUTUPFN)
			   OP)
		     " Illegal operator."))
          (COND
	    ((AND (ATOM (CAR LHS))
		  (BOUNDP (QUOTE GLPROGLST))
		  (SETQ TMP (ASSOC (CAR LHS)
				   GLPROGLST)))
	      (RETURN (GLREDUCEOP (CDR TMPOP)
				  (LIST (CADR TMP)
					(CADR LHS))
				  RHS)))
	    ((AND (LISTP (CAR LHS))
		  (EQ (CAAR LHS)
		      (QUOTE PROG1))
		  (ATOM (CADAR LHS)))
	      (RETURN (GLREDUCEOP (CDR TMPOP)
				  (LIST (CADAR LHS)
					(CADR LHS))
				  RHS)))
	    (T (RETURN (GLERROR (QUOTE GLPUTUPFN)
				(LIST 
	 "A self-assignment __ operator is used improperly.  LHS ="
				      LHS])

(GLREDUCE
  [LAMBDA NIL                                   (* edited: 
						"30-OCT-82 14:38")
                                                (* edited: 
						"14-Aug-81 12:25")
                                                (* edited: 
						"21-Apr-81 11:28")

          (* Reduce the operator on OPERS and the operands on 
	  OPNDS (in GLPARSEXPR) and put the result back on 
	  OPNDS)


    (PROG (RHS OPER)
          (SETQ RHS (pop OPNDS))
          (SETQ OPNDS
	    (CONS (COND
		    ((MEMB (SETQ OPER (pop OPERS))
			   (QUOTE (_ := _+ +_ _- -_ = ~= <> AND And and 
				     OR Or or __+ __ _+_ __-)))
		      (GLREDUCEOP OPER (pop OPNDS)
				  RHS))
		    ((FMEMB OPER
			    (QUOTE (+ - * / > < >= <= ^)))
		      (GLREDUCEARITH OPER (pop OPNDS)
				     RHS))
		    ((EQ OPER (QUOTE MINUS))
		      (GLMINUSFN RHS))
		    ((EQ OPER (QUOTE ~))
		      (GLNOTFN RHS))
		    (T (LIST (GLGENCODE (LIST OPER (CAR (pop OPNDS))
					      (CAR RHS)))
			     NIL)))
		  OPNDS])

(GLREDUCEARITH
  [LAMBDA (OP LHS RHS)                          (* "GSN: " 
						" 4-Dec-83 17:06")
                                                (* edited: 
						"14-Aug-81 12:38")
                                                (* 
						
"Reduce an arithmetic operator in an expression.")
    (PROG (TMP OPLIST IOPLIST PREDLIST NUMBERTYPES LHSTP RHSTP)
          [SETQ OPLIST (QUOTE ((+ . PLUS)
				(- . DIFFERENCE)
				                (* . TIMES)
				(/ . QUOTIENT)
				(> . GREATERP)
				(< . LESSP)
				(>= . GEQ)
				(<= . LEQ)
				(^ . EXPT]
          [SETQ IOPLIST (QUOTE ((+ . IPLUS)
				 (- . IDIFFERENCE)
				                (* . ITIMES)
				 (/ . IQUOTIENT)
				 (> . IGREATERP)
				 (< . ILESSP)
				 (>= . IGEQ)
				 (<= . ILEQ]
          (SETQ PREDLIST
	    (QUOTE (GREATERP LESSP GEQ LEQ IGREATERP ILESSP IGEQ ILEQ)))
          (SETQ NUMBERTYPES (QUOTE (INTEGER REAL NUMBER)))
          (SETQ LHSTP (GLXTRTYPE (CADR LHS)))
          (SETQ RHSTP (GLXTRTYPE (CADR RHS)))
          [COND
	    ([OR (AND (EQ LHSTP (QUOTE INTEGER))
		      (EQ RHSTP (QUOTE INTEGER))
		      (SETQ TMP (FASSOC OP IOPLIST)))
		 (AND (MEMB LHSTP NUMBERTYPES)
		      (MEMB RHSTP NUMBERTYPES)
		      (SETQ TMP (FASSOC OP OPLIST]
	      (RETURN
		(LIST [COND
			[(AND (NUMBERP (CAR LHS))
			      (NUMBERP (CAR RHS)))
			  (EVAL (GLGENCODE (LIST (CDR TMP)
						 (CAR LHS)
						 (CAR RHS]
			(T (GLGENCODE (COND
					((AND (EQ (CDR TMP)
						  (QUOTE IPLUS))
					      (EQP (CAR RHS)
						   1))
					  (LIST (QUOTE ADD1)
						(CAR LHS)))
					((AND (EQ (CDR TMP)
						  (QUOTE IDIFFERENCE))
					      (EQP (CAR RHS)
						   1))
					  (LIST (QUOTE SUB1)
						(CAR LHS)))
					(T (LIST (CDR TMP)
						 (CAR LHS)
						 (CAR RHS]
		      (COND
			((MEMB (CDR TMP)
			       PREDLIST)
			  (QUOTE BOOLEAN))
			((OR (EQ LHSTP (QUOTE INTEGER))
			     (EQ RHSTP (QUOTE REAL)))
			  RHSTP)
			(T LHSTP]
          (COND
	    [(AND (EQ LHSTP (QUOTE STRING))			       |
		  (EQ RHSTP (QUOTE STRING)))			       |
	      (COND						       |
		[[SETQ TMP (FASSOC OP (QUOTE ((+ CONCAT STRING)	       |
					       (> GLSTRGREATERP BOOLEAN)
					       (>= GLSTRGEP BOOLEAN)   |
					       (< GLSTRLESSP BOOLEAN)  |
					       (<= ALPHORDER BOOLEAN]  |
		  (RETURN (LIST (GLGENCODE (LIST (CADR TMP)	       |
						 (CAR LHS)	       |
						 (CAR RHS)))	       |
				(CADDR TMP]			       |
		(T (RETURN (GLERROR (QUOTE GLREDUCEARITH)	       |
				    (LIST OP 			       |
			     "is an illegal operation for strings."]   |
	    [(EQ LHSTP (QUOTE BOOLEAN))
	      (COND
		[(NEQ RHSTP (QUOTE BOOLEAN))
		  (RETURN (GLERROR (QUOTE GLREDUCEARITH)
				   (LIST 
			     "Operation on Boolean and non-Boolean"]
		[(MEMB OP (QUOTE (+ * -)))
		  (RETURN
		    (LIST
		      (GLGENCODE
			(SELECTQ OP
				 (+ (LIST (QUOTE OR)
					  (CAR LHS)
					  (CAR RHS)))
                                                (* (LIST (QUOTE AND) 
						(CAR LHS) (CAR RHS)))
				 [- (LIST (QUOTE AND)
					  (CAR LHS)
					  (LIST (QUOTE NOT)
						(CAR RHS]
				 NIL))
		      (QUOTE BOOLEAN]
		(T (RETURN (GLERROR (QUOTE GLREDUCEARITH)
				    (LIST OP 
			    "is an illegal operation for Booleans."]
	    [(AND (LISTP LHSTP)
		  (EQ (CAR LHSTP)
		      (QUOTE LISTOF)))
	      (COND
		[(AND (LISTP RHSTP)
		      (EQ (CAR RHSTP)
			  (QUOTE LISTOF)))
		  [COND
		    ((NOT (EQUAL (CADR LHSTP)
				 (CADR RHSTP)))
		      (RETURN (GLERROR (QUOTE GLREDUCEARITH)
				       (LIST 
			   "Operations on lists of different types"
					     (CADR LHSTP)
					     (CADR RHSTP]
		  (COND
		    [[SETQ TMP (FASSOC OP (QUOTE ((+ UNION)
						   (- LDIFFERENCE)
						   
                                                (* INTERSECTION)]
		      (RETURN (LIST (GLGENCODE (LIST (CADR TMP)
						     (CAR LHS)
						     (CAR RHS)))
				    (CADR LHS]
		    (T (RETURN (GLERROR (QUOTE GLREDUCEARITH)
					(LIST "Illegal operation" OP 
					      "on lists."]
		[[AND (GLMATCH RHSTP (CADR LHSTP))
		      (FMEMB OP (QUOTE (+ - >=]
		  (RETURN
		    (LIST (GLGENCODE (LIST [COND
					     ((EQ OP (QUOTE +))
					       (QUOTE CONS))
					     ((EQ OP (QUOTE -))
					       (QUOTE REMOVE))
					     ((EQ OP (QUOTE >=))
					       (COND
						 ((GLATOMTYPEP RHSTP)
						   (QUOTE MEMB))
						 (T (QUOTE MEMBER]
					   (CAR RHS)
					   (CAR LHS)))
			  (CADR LHS]
		(T (RETURN (GLERROR (QUOTE GLREDUCEARITH)
				    (LIST "Illegal operation on list."]
	    [(AND (FMEMB OP (QUOTE (+ <=)))
		  (GLMATCHL LHSTP RHSTP))
	      (RETURN (COND
			((EQ OP (QUOTE +))
			  (LIST (GLGENCODE (LIST (QUOTE CONS)
						 (CAR LHS)
						 (CAR RHS)))
				(CADR RHS)))
			((EQ OP (QUOTE <=))
			  (LIST (GLGENCODE
				  (LIST (COND
					  ((GLATOMTYPEP LHSTP)
					    (QUOTE MEMB))
					  (T (QUOTE MEMBER)))
					(CAR LHS)
					(CAR RHS)))
				(QUOTE BOOLEAN]
	    [(AND (FMEMB OP (QUOTE (+ - >=)))
		  (SETQ TMP (GLMATCHL LHSTP RHSTP)))
	      (RETURN (GLREDUCEARITH (LIST (CAR LHS)
					   (LIST (QUOTE LISTOF)
						 TMP))
				     OP
				     (LIST (CAR RHS)
					   TMP]
	    ((SETQ TMP (GLDOMSG LHS OP (LIST RHS)))
	      (RETURN TMP))
	    ((SETQ TMP (GLUSERSTROP LHS OP RHS))
	      (RETURN TMP))
	    ((SETQ TMP (GLXTRTYPEC LHSTP))
	      [SETQ TMP (GLREDUCEARITH OP (LIST (CAR LHS)
						TMP)
				       (LIST (CAR RHS)
					     (OR (GLXTRTYPEC RHSTP)
						 RHSTP]
	      (RETURN (LIST (CAR TMP)
			    LHSTP)))
	    [(SETQ TMP (FASSOC OP OPLIST))
	      (AND LHSTP RHSTP (GLERROR (QUOTE GLREDUCEARITH)
					(LIST 
 "Warning: Arithmetic operation on non-numeric arguments of types:"
					      LHSTP RHSTP)))
	      (RETURN (LIST (GLGENCODE (LIST (CDR TMP)
					     (CAR LHS)
					     (CAR RHS)))
			    (COND
			      ((MEMB (CDR TMP)
				     PREDLIST)
				(QUOTE BOOLEAN))
			      (T (QUOTE NUMBER]
	    (T (ERROR (LIST (QUOTE GLREDUCEARITH)
			    OP LHS RHS])

(GLREDUCEOP
  [LAMBDA (OP LHS RHS)                          (* edited: 
						"29-DEC-82 12:20")
                                                (* Reduce the operator 
						OP with operands LHS and
						RHS.)
    (PROG (TMP RESULT)
          (COND
	    ((FMEMB OP (QUOTE (_ :=)))
	      (RETURN (GLPUTFN LHS RHS NIL)))
	    [[SETQ TMP (FASSOC OP (QUOTE ((_+ . GLNCONCFN)
					   (+_ . GLPUSHFN)
					   (_- . GLREMOVEFN)
					   (-_ . GLPOPFN)
					   (= . GLEQUALFN)
					   (~= . GLNEQUALFN)
					   (<> . GLNEQUALFN)
					   (AND . GLANDFN)
					   (And . GLANDFN)
					   (and . GLANDFN)
					   (OR . GLORFN)
					   (Or . GLORFN)
					   (or . GLORFN]
	      (COND
		((SETQ RESULT (APPLY* (CDR TMP)
				      LHS RHS))
		  (RETURN RESULT))
		(T (GLERROR (QUOTE GLREDUCEOP)
			    (LIST "The operator" OP 
			   "could not be interpreted for arguments"
				  LHS "and" RHS]
	    ((MEMB OP (QUOTE (__ __+ __- _+_)))
	      (RETURN (GLPUTUPFN OP LHS RHS)))
	    (T (ERROR (LIST (QUOTE GLREDUCEOP)
			    OP LHS RHS])

(GLREMOVEFN
  [LAMBDA (LHS RHS)                             (* GSN "25-JAN-83 16:50"
)                                               (* edited: 
						" 2-Jun-81 14:20")
                                                (* edited: 
						"21-Apr-81 11:29")

          (* Produce a function to implement the _- operator.
	  Code is produced to remove the right-hand side from 
	  the left-hand side. Note: parts of the structure 
	  provided are used multiple times.)


    (PROG (LHSCODE LHSDES NCCODE TMP STR)
          (SETQ LHSCODE (CAR LHS))
          (SETQ LHSDES (GLXTRTYPE (CADR LHS)))
          (COND
	    [(EQ LHSDES (QUOTE INTEGER))
	      (COND
		((EQP (CAR RHS)
		      1)
		  (SETQ NCCODE (LIST (QUOTE SUB1)
				     LHSCODE)))
		(T (SETQ NCCODE (LIST (QUOTE IDIFFERENCE)
				      LHSCODE
				      (CAR RHS]
	    [(OR (EQ LHSDES (QUOTE NUMBER))
		 (EQ LHSDES (QUOTE REAL)))
	      (SETQ NCCODE (LIST (QUOTE DIFFERENCE)
				 LHSCODE
				 (CAR RHS]
	    [(EQ LHSDES (QUOTE BOOLEAN))
	      (SETQ NCCODE (LIST (QUOTE AND)
				 LHSCODE
				 (LIST (QUOTE NOT)
				       (CAR RHS]
	    ([OR (NULL LHSDES)
		 (AND (LISTP LHSDES)
		      (EQ (CAR LHSDES)
			  (QUOTE LISTOF]
	      (SETQ NCCODE (LIST (QUOTE REMOVE)
				 (CAR RHS)
				 LHSCODE)))
	    ((SETQ TMP (GLUNITOP LHS RHS (QUOTE REMOVE)))
	      (RETURN TMP))
	    ((SETQ TMP (GLDOMSG LHS (QUOTE _-)
				(LIST RHS)))
	      (RETURN TMP))
	    ((SETQ TMP (GLDOMSG LHS (QUOTE -)
				(LIST RHS)))
	      (SETQ NCCODE (CAR TMP)))
	    [(AND (SETQ STR (GLGETSTR LHSDES))
		  (SETQ TMP (GLREMOVEFN (LIST (CAR LHS)
					      STR)
					RHS)))
	      (RETURN (LIST (CAR TMP)
			    (CADR LHS]
	    ((SETQ TMP (GLUSERSTROP LHS (QUOTE _-)
				    RHS))
	      (RETURN TMP))
	    (T (RETURN)))
          (RETURN (GLPUTFN LHS (LIST (GLGENCODE NCCODE)
				     LHSDES)
			   T])

(GLRESGLOBAL
  [LAMBDA NIL                                   (* GSN "26-JAN-83 13:41"
)

          (* Get GLOBAL and RESULT declarations for the GLISP 
	  compiler. The property GLRESULTTYPE is the RESULT 
	  declaration, if specified; GLGLOBALS is a list of 
	  global variables referenced and their types.)


    (COND
      ((LISTP (CAR GLEXPR))
	(COND
	  [(MEMB (CAAR GLEXPR)
		 (QUOTE (RESULT Result result)))
	    (COND
	      ((AND (GLOKSTR? (CADAR GLEXPR))
		    (NULL (CDDAR GLEXPR)))
		(PUTPROP GLAMBDAFN (QUOTE GLRESULTTYPE)
			 (SETQ RESULTTYPE (GLSUBSTTYPE
			     (GLEVALSTR (CADAR GLEXPR)
					GLTOPCTX)
			     GLTYPESUBS)))
		(pop GLEXPR))
	      (T (GLERROR (QUOTE GLCOMP)
			  (LIST "Bad RESULT structure declaration:"
				(CAR GLEXPR)))
		 (pop GLEXPR]
	  ((MEMB (CAAR GLEXPR)
		 (QUOTE (GLOBAL Global global)))
	    (SETQ GLGLOBALVARS (GLDECL (CDAR GLEXPR)
				       (QUOTE (NIL NIL))
				       GLTOPCTX NIL NIL))
	    (PUTPROP GLAMBDAFN (QUOTE GLGLOBALS)
		     GLGLOBALVARS)
	    (pop GLEXPR])

(GLSAVEFNTYPES
  [LAMBDA (GLAMBDAFN TYPELST)                   (* GSN "28-JAN-83 09:55"
)
    (PROG (Y)
          (MAPC TYPELST (FUNCTION (LAMBDA (X)
		    (COND
		      ([NOT (FMEMB GLAMBDAFN (SETQ Y
				     (GETPROP X (QUOTE GLFNSUSEDIN]
			(PUTPROP X (QUOTE GLFNSUSEDIN)
				 (CONS GLAMBDAFN Y])

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

(GLSEPINIT
  [LAMBDA (ATM)                                 (* GSN " 9-FEB-83 17:24"
)                                               (* "GSN: " 
						"30-Dec-80 10:05")
                                                (* Initialize the 
						scanning function which 
						breaks apart atoms 
						containing embedded 
						operators.)
    (COND
      ((AND (ATOM ATM)
	    (NOT (STRINGP ATM)))
	(SETQ GLSEPATOM ATM)
	(SETQ GLSEPPTR 1))
      (T (SETQ GLSEPATOM NIL)
	 (SETQ GLSEPPTR 0])

(GLSEPNXT
  [LAMBDA NIL                                   (* GSN " 6-JUN-83 16:08"
)

          (* Get the next sub-atom from the atom which was 
	  previously given to GLSEPINIT.
	  Sub-atoms are defined by splitting the given atom at
	  the occurrence of operators.
	  Operators which are defined are : _ _+ __ +_ _- -_ '
	  = ~= <> > <)


    (PROG (END TMP FOUNDSLASH)
          (COND
	    ((ZEROP GLSEPPTR)
	      (RETURN))
	    ((NULL GLSEPATOM)
	      (SETQ GLSEPPTR 0)
	      (RETURN (QUOTE *NIL*)))
	    ((NUMBERP GLSEPATOM)
	      (SETQ TMP GLSEPATOM)
	      (SETQ GLSEPPTR 0)
	      (RETURN TMP))
	    (GLNOSPLITATOMS (SETQ GLSEPPTR 0)
			    (RETURN GLSEPATOM)))
          (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM GLSEPPTR))
      A   (COND
	    [(NULL END)
	      (RETURN (PROG1 [COND
			       ((AND (EQP GLSEPPTR 1)
				     FOUNDSLASH)
				 (GLSUBATOM GLSEPATOM 1 -1))
			       ((EQP GLSEPPTR 1)
				 GLSEPATOM)
			       ((IGREATERP GLSEPPTR (NCHARS GLSEPATOM))
				 NIL)
			       (T (GLSUBATOM GLSEPATOM GLSEPPTR
					     (NCHARS GLSEPATOM]
			     (SETQ GLSEPPTR 0]
	    ((MEMB (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR
					(IPLUS GLSEPPTR 2)))
		   (QUOTE (__+ __- _+_)))
	      (SETQ GLSEPPTR (IPLUS GLSEPPTR 3))
	      (RETURN TMP))
	    ((MEMB (SETQ TMP (GLSUBATOM GLSEPATOM GLSEPPTR
					(ADD1 GLSEPPTR)))
		   (QUOTE (:= __ _+ +_ _- -_ ~= <> >= <=)))
	      (SETQ GLSEPPTR (IPLUS GLSEPPTR 2))
	      (RETURN TMP))
	    ([AND (NOT GLSEPMINUS)
		  (EQ (NTHCHAR GLSEPATOM END)
		      (QUOTE -))
		  (NOT (EQ (NTHCHAR GLSEPATOM (ADD1 END))
			   (QUOTE _]
	      (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END)))
	      (GO A))
	    ((AND (IGREATERP END 1)
		  (EQ (NTHCHAR GLSEPATOM (SUB1 END))
		      (QUOTE \)))
	      (SETQ END (STRPOSL GLSEPBITTBL GLSEPATOM (ADD1 END)))
	      (SETQ FOUNDSLASH T)
	      (GO A))
	    [(IGREATERP END GLSEPPTR)
	      (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR
					(SUB1 END))
			     (SETQ GLSEPPTR END]
	    (T (RETURN (PROG1 (GLSUBATOM GLSEPATOM GLSEPPTR GLSEPPTR)
			      (SETQ GLSEPPTR (ADD1 GLSEPPTR])

(GLSKIPCOMMENTS
  [LAMBDA NIL                                   (* edited: 
						"26-MAY-82 16:17")
                                                (* "GSN: " 
						" 7-Jan-81 16:36")
                                                (* Skip comments in 
						GLEXPR.)
    (PROG NIL
      A   (COND
	    ([AND (LISTP GLEXPR)
		  (LISTP (CAR GLEXPR))
		  (OR (AND (EQ GLLISPDIALECT (QUOTE INTERLISP))
			   (EQ (CAAR GLEXPR)
			       (QUOTE *)))
		      (EQ (CAAR GLEXPR)
			  (QUOTE COMMENT]
	      (pop GLEXPR)
	      (GO A])

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

(GLSUBLIS
  [LAMBDA (PAIRS EXPR)                          (* GSN "22-JAN-83 16:27"
)                                               (* Same as SUBLIS, but 
						allows first elements in
						PAIRS to be non-atomic.)
    (PROG (TMP)
          (RETURN (COND
		    ((SETQ TMP (ASSOC EXPR PAIRS))
		      (CDR TMP))
		    ((NLISTP EXPR)
		      EXPR)
		    (T (CONS (GLSUBLIS PAIRS (CAR EXPR))
			     (GLSUBLIS PAIRS (CDR EXPR])

(GLSUBSTTYPE
  [LAMBDA (TYPE SUBS)                           (* edited: 
						"30-AUG-82 10:29")
                                                (* Make subtype 
						substitutions within 
						TYPE according to 
						GLTYPESUBS.)
    (SUBLIS SUBS TYPE])

(GLTHE
  [LAMBDA (PLURALFLG)                           (* GSN "16-FEB-83 11:56"
)                                               (* edited: 
						"17-Apr-81 14:23")
                                                (* EXPR begins with THE.
						Parse the expression and
						return code.)
    (DECLARE (SPECVARS SOURCE SPECS))
    (PROG (SOURCE SPECS NAME QUALFLG DTYPE NEWCONTEXT LOOPVAR LOOPCOND 
		  TMP)                          (* Now trace the path 
						specification.)
          (GLTHESPECS)
          [SETQ QUALFLG
	    (AND EXPR
		 (MEMB (CAR EXPR)
		       (QUOTE (with With WITH who Who WHO which Which 
				    WHICH that That THAT]
      B   [COND
	    [(NULL SPECS)
	      (COND
		((MEMB (CAR EXPR)
		       (QUOTE (IS Is is HAS Has has ARE Are are)))
		  (RETURN (GLPREDICATE SOURCE CONTEXT T NIL)))
		(QUALFLG (GO C))
		(T (RETURN SOURCE]
	    ((AND QUALFLG (NOT PLURALFLG)
		  (NULL (CDR SPECS)))

          (* If this is a definite reference to a qualified 
	  entity, make the name of the entity plural.)


	      (SETQ NAME (CAR SPECS))
	      (RPLACA SPECS (GLPLURAL (CAR SPECS]

          (* Try to find the next name on the list of SPECS 
	  from SOURCE.)


          [COND
	    [(NULL SOURCE)
	      (OR (SETQ SOURCE (GLIDNAME (SETQ NAME (pop SPECS))
					 NIL))
		  (RETURN (GLERROR (QUOTE GLTHE)
				   (LIST "The definite reference to" 
					 NAME "could not be found."]
	    (SPECS (SETQ SOURCE (GLGETFIELD SOURCE (pop SPECS)
					    CONTEXT]
          (GO B)
      C   [COND
	    ([ATOM (SETQ DTYPE (GLXTRTYPE (CADR SOURCE]
	      (SETQ DTYPE (GLXTRTYPE (GLGETSTR DTYPE]
          [COND
	    ((OR (NLISTP DTYPE)
		 (NEQ (CAR DTYPE)
		      (QUOTE LISTOF)))
	      (GLERROR (QUOTE GLTHE)
		       (LIST "The group name" NAME "has type" DTYPE 
			     "which is not a legal group type."]
          (SETQ NEWCONTEXT (CONS NIL CONTEXT))
          (GLADDSTR (SETQ LOOPVAR (GLMKVAR))
		    NAME
		    (CADR DTYPE)
		    NEWCONTEXT)
          (SETQ LOOPCOND
	    (GLPREDICATE (LIST LOOPVAR (CADR DTYPE))
			 NEWCONTEXT
			 (MEMB (pop EXPR)
			       (QUOTE (who Who WHO which Which WHICH 
					   that That THAT)))
			 NIL))
          [SETQ TMP (GLGENCODE (LIST (COND
				       (PLURALFLG (QUOTE SUBSET))
				       (T (QUOTE SOME)))
				     (CAR SOURCE)
				     (LIST (QUOTE FUNCTION)
					   (LIST (QUOTE LAMBDA)
						 (LIST LOOPVAR)
						 (CAR LOOPCOND]
          (RETURN (COND
		    (PLURALFLG (LIST TMP (CADR SOURCE)))
		    (T (LIST (LIST (QUOTE CAR)
				   TMP)
			     (CADR DTYPE])

(GLTHESPECS
  [LAMBDA NIL                                   (* edited: 
						"20-MAY-82 17:19")
                                                (* "GSN: " 
						"17-Apr-81 14:23")

          (* EXPR begins with THE. Parse the expression and 
	  return code in SOURCE and path names in SPECS.)


    (PROG NIL
      A   [COND
	    ((NULL EXPR)
	      (RETURN))
	    ((MEMB (CAR EXPR)
		   (QUOTE (THE The the)))
	      (pop EXPR)
	      (COND
		((NULL EXPR)
		  (RETURN (GLERROR (QUOTE GLTHE)
				   (LIST "Nothing following THE"]
          (COND
	    [(ATOM (CAR EXPR))
	      (GLSEPINIT (CAR EXPR))
	      (COND
		((EQ (GLSEPNXT)
		     (CAR EXPR))
		  (SETQ SPECS (CONS (pop EXPR)
				    SPECS)))
		(T (GLSEPCLR)
		   (SETQ SOURCE (GLDOEXPR NIL CONTEXT T))
		   (RETURN]
	    (T (SETQ SOURCE (GLDOEXPR NIL CONTEXT T))
	       (RETURN)))                       (* SPECS contains a path
						specification.
						See if there is any 
						more.)
          (COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (OF Of of)))
	      (pop EXPR)
	      (GO A])

(GLTRANSPROG
  [LAMBDA (X)                                   (* edited: 
						"29-APR-83 11:56")

          (* Translate places where a PROG variable is 
	  initialized to a value as allowed by Interlisp.
	  This is done by adding a SETQ to set the value of 
	  each PROG variable which is initialized.
	  In some cases, a change of variable name is required
	  to preserve the same semantics.)


    (PROG (TMP ARGVALS SETVARS REST)
          [MAP
	    (CADR X)
	    (FUNCTION (LAMBDA (Y)
		(COND
		  ((LISTP (CAR Y))              (* If possible, use the 
						same variable;
						otherwise, make a new 
						one.)
		    [SETQ TMP
		      (COND
			([OR [SOME (CADR X)
				   (FUNCTION (LAMBDA (Z)
				       (AND (LISTP Z)
					    (GLOCCURS (CAR Z)
						      (CADAR Y]
			     (SOME ARGVALS (FUNCTION (LAMBDA (Z)
				       (GLOCCURS (CAAR Y)
						 Z]
			  (GLMKVAR))
			(T (CAAR Y]
		    [SETQ SETVARS (NCONC1 SETVARS (LIST (QUOTE SETQ)
							TMP
							(CADAR Y]
		    (SETQ REST (DSUBST TMP (CAAR Y)
				       (CDDR X)))
		    (SETQ ARGVALS (CONS (CADAR Y)
					ARGVALS))
		    (RPLACA Y TMP]
          [COND
	    (SETVARS (RPLACD (CDR X)
			     (NCONC SETVARS REST]
          (RETURN X])

(GLUNCOMPILE
  [LAMBDA (GLAMBDAFN)                           (* GSN " 6-JUN-83 16:00"
)                                               (* Remove the 
						GLISP-compiled 
						definition and 
						properties of GLAMBDAFN)
    (PROG (SPECS SPECLST STR LST TMP)
          (OR (GETPROP GLAMBDAFN (QUOTE GLCOMPILED))
	      (SETQ SPECS (GETPROP GLAMBDAFN (QUOTE GLSPECIALIZATION)))
	      (RETURN))
          (COND
	    ((NOT GLQUIETFLG)
	      (PRIN1 "uncompiling ")
	      (PRIN1 GLAMBDAFN)
	      (TERPRI)))
          (PUTPROP GLAMBDAFN (QUOTE GLCOMPILED)
		   NIL)
          (PUTPROP GLAMBDAFN (QUOTE GLRESULTTYPE)
		   NIL)
          (GLUNSAVEDEF GLAMBDAFN)
          [MAPC (GETPROP GLAMBDAFN (QUOTE GLTYPESUSED))
		(FUNCTION (LAMBDA (Y)
		    (PUTPROP Y (QUOTE GLFNSUSEDIN)
			     (DREMOVE GLAMBDAFN (GETPROP Y
							 (QUOTE 
							GLFNSUSEDIN]
          (PUTPROP GLAMBDAFN (QUOTE GLTYPESUSED)
		   NIL)
          (OR SPECS (RETURN))                   (* Uncompile a 
						specialization of a 
						generic function.)
      A   (COND
	    ((NULL SPECS)
	      (RETURN)))
          (SETQ SPECLST (pop SPECS))
          [PUTPROP (CAR SPECLST)
		   (QUOTE GLINSTANCEFNS)
		   (DREMOVE GLAMBDAFN (GETPROP (CAR SPECLST)
					       (QUOTE GLINSTANCEFNS]
                                                (* Remove the 
						specialization entry in 
						the datatype where it 
						was created.)
          (OR (SETQ STR (GETPROP (CADR SPECLST)
				 (QUOTE GLSTRUCTURE)))
	      (GO A))
          (SETQ LST (CDR STR))
      LP  (COND
	    ((NULL LST)
	      (GO A))
	    ((EQ (CAR LST)
		 (CADDR SPECLST))
	      [COND
		((AND (SETQ TMP (ASSOC (CADDDR SPECLST)
				       (CADR LST)))
		      (EQ (CADR TMP)
			  GLAMBDAFN))
		  (RPLACA (CDR LST)
			  (DREMOVE TMP (CADR LST]
	      (GO A))
	    (T (SETQ LST (CDDR LST))
	       (GO LP])

(GLUNSAVEDEF
  [LAMBDA (GLAMBDAFN)                           (* GSN "28-JAN-83 11:15"
)                                               (* Remove the 
						GLISP-compiled 
						definition of GLAMBDAFN)
    (SELECTQ GLLISPDIALECT
	     (INTERLISP (PUTD GLAMBDAFN (GETPROP GLAMBDAFN
						 (QUOTE EXPR)))
			(PUTHASH (GETD GLAMBDAFN)
				 NIL CLISPARRAY))
	     [FRANZLISP (PUTD GLAMBDAFN (GETPROP GLAMBDAFN
						 (QUOTE GLORIGINALEXPR]
	     ((MACLISP UCILISP PSL)
	       (GLPUTHOOK GLAMBDAFN))
	     (ERROR])

(GLUNWRAP
  [LAMBDA (X BUSY)                              (* GSN "22-JUL-83 14:20"
)                                               (* Unwrap an expression 
						X by removing extra 
						stuff inserted during 
						compilation.)
    (COND
      ((NLISTP X)
	X)
      ((NOT (ATOM (CAR X)))
	(ERROR (QUOTE GLUNWRAP)
	       X))
      ((SELECTQ
	  (CAR X)
	  ((QUOTE GO)
	    X)
	  [(PROG2 PROGN)
	    (COND
	      ((NULL (CDDR X))
		(GLUNWRAP (CADR X)
			  BUSY))
	      (T [MAP (CDR X)
		      (FUNCTION (LAMBDA (Y)
			  (RPLACA Y (GLUNWRAP
				    (CAR Y)
				    (AND BUSY (NULL (CDR Y]
		 (GLEXPANDPROGN X BUSY NIL)
		 (COND
		   ((NULL (CDDR X))
		     (CADR X))
		   (T X]
	  [PROG1
	    (COND
	      ((NULL (CDDR X))
		(GLUNWRAP (CADR X)
			  BUSY))
	      (T [MAP (CDR X)
		      (FUNCTION (LAMBDA (Y)
			  (RPLACA Y (GLUNWRAP
				    (CAR Y)
				    (AND BUSY (EQ Y (CDR X]
		 (COND
		   (BUSY (GLEXPANDPROGN (CDR X)
					BUSY NIL))
		   (T (RPLACA X (QUOTE PROGN))
		      (GLEXPANDPROGN X BUSY NIL)))
		 (COND
		   ((NULL (CDDR X))
		     (CADR X))
		   (T X]
	  (FUNCTION (RPLACA (CDR X)
			    (GLUNWRAP (CADR X)
				      BUSY))
		    [MAP (CDDR X)
			 (FUNCTION (LAMBDA (Y)
			     (RPLACA Y (GLUNWRAP (CAR Y)
						 T]
		    X)
	  ((MAP MAPC MAPCAR MAPCONC SUBSET SOME EVERY)
	    (GLUNWRAPMAP X BUSY))
	  [LAMBDA [MAP (CDDR X)
		       (FUNCTION (LAMBDA (Y)
			   (RPLACA Y (GLUNWRAP
				     (CAR Y)
				     (AND BUSY (NULL (CDR Y]
		  (GLEXPANDPROGN (CDR X)
				 BUSY NIL)
		  X]
	  ((PROG RESETVARS)
	    (GLUNWRAPPROG X BUSY))
	  (COND (GLUNWRAPCOND X BUSY))
	  ((SELECTQ CASEQ)
	    (GLUNWRAPSELECTQ X BUSY))
	  ((UNION INTERSECTION LDIFFERENCE)
	    (GLUNWRAPINTERSECT X))
	  (COND
	    ((AND (EQ (CAR X)
		      (QUOTE *))
		  (EQ GLLISPDIALECT (QUOTE INTERLISP)))
	      X)
	    ((AND (NOT BUSY)
		  (CDR X)
		  (NULL (CDDR X))
		  (GLPURE (CAR X)))
	      (GLUNWRAP (CADR X)
			NIL))
	    (T
	      [MAP (CDR X)
		   (FUNCTION (LAMBDA (Y)
		       (RPLACA Y (GLUNWRAP (CAR Y)
					   T]
	      (COND
		((AND (CDR X)
		      (NULL (CDDR X))
		      (LISTP (CADR X))
		      (GLCARCDR? (CAR X))
		      (GLCARCDR? (CAADR X))
		      (ILESSP (IPLUS (NCHARS (CAR X))
				     (NCHARS (CAADR X)))
			      9))
		  [RPLACA
		    X
		    (PACK
		      (CONS (QUOTE C)
			    (DREVERSE
			      (CONS (QUOTE R)
				    (NCONC (GLANYCARCDR? (CAADR X))
					   (GLANYCARCDR? (CAR X]
		  (RPLACA (CDR X)
			  (CADADR X))
		  (GLUNWRAP X BUSY))
		([AND (GETPROP (CAR X)
			       (QUOTE GLEVALWHENCONST))
		      (EVERY (CDR X)
			     (FUNCTION GLCONST?))
		      (OR (NOT (GETPROP (CAR X)
					(QUOTE GLARGSNUMBERP)))
			  (EVERY (CDR X)
				 (FUNCTION NUMBERP]
		  (EVAL X))
		((FMEMB (CAR X)
			(QUOTE (AND OR)))
		  (GLUNWRAPLOG X))
		(T X])

(GLUNWRAPCOND
  [LAMBDA (X BUSY)                              (* GSN "27-JAN-83 13:57"
)                                               (* Unwrap a COND 
						expression.)
    (PROG (RESULT)
          (SETQ RESULT X)
      A   (COND
	    ((NULL (CDR RESULT))
	      (GO B)))
          (RPLACA (CADR RESULT)
		  (GLUNWRAP (CAADR RESULT)
			    T))
          (COND
	    ((EQ (CAADR RESULT)
		 NIL)
	      (RPLACD RESULT (CDDR RESULT))
	      (GO A))
	    (T [MAP (CDADR RESULT)
		    (FUNCTION (LAMBDA (Y)
			(RPLACA Y (GLUNWRAP (CAR Y)
					    (AND BUSY
						 (NULL (CDR Y]
	       (GLEXPANDPROGN (CADR RESULT)
			      BUSY NIL)))
          (COND
	    ((EQ (CAADR RESULT)
		 T)
	      (RPLACD (CDR RESULT)
		      NIL)))
          (SETQ RESULT (CDR RESULT))
          (GO A)
      B   (COND
	    [(AND (NULL (CDDR X))
		  (EQ (CAADR X)
		      T))
	      (RETURN (CONS (QUOTE PROGN)
			    (CDADR X]
	    (T (RETURN X])

(GLUNWRAPINTERSECT
  [LAMBDA (CODE)                                (* GSN "17-FEB-83 13:40"
)

          (* Optimize intersections and unions of subsets of 
	  the same set: (INTERSECT (SUBSET S P) 
	  (SUBSET S Q)) -> (SUBSET S (AND P Q)))


    (PROG (LHS RHS P Q QQ SA SB)
          (SETQ LHS (GLUNWRAP (CADR CODE)
			      T))
          (SETQ RHS (GLUNWRAP (CADDR CODE)
			      T))
          (OR (AND (LISTP LHS)
		   (LISTP RHS)
		   (EQ (CAR LHS)
		       (QUOTE SUBSET))
		   (EQ (CAR RHS)
		       (QUOTE SUBSET)))
	      (GO OUT))
          (SELECTQ GLLISPDIALECT
		   ((INTERLISP PSL)
		     (SETQ SA (GLUNWRAP (CADR LHS)
					T))
		     (SETQ SB (GLUNWRAP (CADR RHS)
					T)))
		   ((MACLISP FRANZLISP UCILISP)
		     (SETQ SA (GLUNWRAP (CADDR LHS)
					T))
		     (SETQ SB (GLUNWRAP (CADDR RHS)
					T)))
		   (ERROR))                     (* Make sure the sets 
						are the same.)
          (OR (EQUAL SA SB)
	      (GO OUT))
          (SELECTQ GLLISPDIALECT
		   [(INTERLISP PSL)
		     (SETQ P (GLXTRFN (CADDR LHS)))
		     (SETQ Q (GLXTRFN (CADDR RHS]
		   [(MACLISP FRANZLISP UCILISP)
		     (SETQ P (GLXTRFN (CADR LHS)))
		     (SETQ Q (GLXTRFN (CADR RHS]
		   (ERROR))
          (SETQ QQ (SUBST (CAR P)
			  (CAR Q)
			  (CADR Q)))
          [RETURN
	    (GLGENCODE
	      (LIST
		(QUOTE SUBSET)
		SA
		(LIST
		  (QUOTE FUNCTION)
		  (LIST
		    (QUOTE LAMBDA)
		    (LIST (CAR P))
		    (GLUNWRAP (SELECTQ
				(CAR CODE)
				(INTERSECTION (LIST (QUOTE AND)
						    (CADR P)
						    QQ))
				(UNION (LIST (QUOTE OR)
					     (CADR P)
					     QQ))
				(LDIFFERENCE
				  (LIST (QUOTE AND)
					(CADR P)
					(LIST (QUOTE NOT)
					      QQ)))
				(ERROR))
			      T]
      OUT [MAP (CDR CODE)
	       (FUNCTION (LAMBDA (Y)
		   (RPLACA Y (GLUNWRAP (CAR Y)
				       T]
          (RETURN CODE])

(GLUNWRAPLOG
  [LAMBDA (X)                                   (* GSN "16-MAR-83 10:50"
)

          (* Unwrap a logical expression by performing 
	  constant transformations and splicing in sublists of
	  the same type, e.g., (AND X 
	  (AND Y Z)) -> (AND X Y Z).)


    (PROG (Y LAST)
          (SETQ Y (CDR X))
          (SETQ LAST X)
      LP  [COND
	    ((NULL Y)
	      (GO OUT))
	    ([OR (AND (NULL (CAR Y))
		      (EQ (CAR X)
			  (QUOTE AND)))
		 (AND (EQ (CAR Y)
			  T)
		      (EQ (CAR X)
			  (QUOTE OR]
	      (RPLACD Y NIL))
	    ([OR (AND (NULL (CAR Y))
		      (EQ (CAR X)
			  (QUOTE OR)))
		 (AND (EQ (CAR Y)
			  T)
		      (EQ (CAR X)
			  (QUOTE AND]
	      (SETQ Y (CDR Y))
	      (RPLACD LAST Y)
	      (GO LP))
	    ((AND (LISTP (CAR Y))
		  (EQ (CAAR Y)
		      (CAR X)))
	      (RPLACD (LAST (CAR Y))
		      (CDR Y))
	      (RPLACD Y (CDDAR Y))
	      (RPLACA Y (CADAR Y]
          (SETQ Y (CDR Y))
          (SETQ LAST (CDR LAST))
          (GO LP)
      OUT [COND
	    [(NULL (CDR X))
	      (RETURN (EQ (CAR X)
			  (QUOTE AND]
	    ((NULL (CDDR X))
	      (RETURN (CADR X]
          (RETURN X])

(GLUNWRAPMAP
  [LAMBDA (X BUSY)                              (* "GSN: " 
						" 4-Dec-83 17:17")
                                                (* Unwrap and optimize 
						mapping-type functions.)
    (PROG (LST FN OUTSIDE INSIDE OUTFN INFN NEWFN NEWMAP TMPVAR NEWLST 
	       CDRFN)
          (SELECTQ
	    GLLISPDIALECT
	    [(INTERLISP UTLISP PSL)
	      (SETQ LST (GLUNWRAP (CADR X)
				  T))
	      [SETQ FN (GLUNWRAP (CADDR X)
				 (NOT (MEMB (CAR X)
					    (QUOTE (MAPC MAP]
	      (SETQ CDRFN (AND (CDDDR X)
			       (LIST (GLUNWRAP (CADDDR X)
					       T]
	    [(MACLISP UCILISP)					       |
	      (SETQ LST (GLUNWRAP (CADDR X)			       |
				  T))				       |
	      (SETQ FN (GLUNWRAP (CADR X)			       |
				 (NOT (MEMB (CAR X)		       |
					    (QUOTE (MAPC MAP]	       |
	    [FRANZLISP						       |
	      (COND						       |
		[(MEMB (CAR X)					       |
		       (QUOTE (SOME EVERY)))			       |
		  (SETQ LST (GLUNWRAP (CADR X)			       |
				      T))			       |
		  (SETQ FN (GLUNWRAP (CADDR X)			       |
				     T))			       |
		  (SETQ CDRFN (AND (CDDDR X)			       |
				   (LIST (GLUNWRAP (CADDDR X)	       |
						   T]		       |
		(T (SETQ LST (GLUNWRAP (CADDR X)		       |
				       T))			       |
		   (SETQ FN (GLUNWRAP				       |
		       (CADR X)					       |
		       (NOT (MEMB (CAR X)			       |
				  (QUOTE (MAPC MAP]		       |
	    (ERROR))						       |
          (COND
	    ((OR [NOT (MEMB (SETQ OUTFN (CAR X))
			    (QUOTE (SUBSET MAPCAR MAPC MAPCONC]
		 [NOT (AND (LISTP LST)
			   (MEMB (SETQ INFN (CAR LST))
				 (QUOTE (SUBSET MAPCAR]
		 CDRFN)
	      (GO OUT)))

          (* Optimize compositions of mapping functions to 
	  avoid construction of lists of intermediate 
	  results.)



          (* These optimizations are not correct if the 
	  mapping functions have interdependent side-effects.
	  However, these are likely to be very rare, so we do 
	  it anyway.)


          (SETQ OUTSIDE (GLXTRFN FN))
          [SETQ INSIDE (GLXTRFN (SELECTQ GLLISPDIALECT
					 ((INTERLISP PSL)
					   (SETQ NEWLST (CADR LST))
					   (CADDR LST))
					 ((MACLISP FRANZLISP UCILISP)
					   (SETQ NEWLST (CADDR LST))
					   (CADR LST))
					 (ERROR]
          (SELECTQ
	    INFN
	    (SUBSET (SELECTQ
		      OUTFN
		      [(SUBSET MAPCONC)
			(SETQ NEWMAP OUTFN)
			(SETQ NEWFN (LIST (QUOTE AND)
					  (CADR INSIDE)
					  (SUBST (CAR INSIDE)
						 (CAR OUTSIDE)
						 (CADR OUTSIDE]
		      [MAPCAR (SETQ NEWMAP (QUOTE MAPCONC))
			      (SETQ NEWFN
				(LIST (QUOTE AND)
				      (CADR INSIDE)
				      (LIST (QUOTE CONS)
					    (SUBST (CAR INSIDE)
						   (CAR OUTSIDE)
						   (CADR OUTSIDE))
					    NIL]
		      [MAPC (SETQ NEWMAP (QUOTE MAPC))
			    (SETQ NEWFN (LIST (QUOTE AND)
					      (CADR INSIDE)
					      (SUBST (CAR INSIDE)
						     (CAR OUTSIDE)
						     (CADR OUTSIDE]
		      (ERROR)))
	    (MAPCAR [SETQ NEWFN (LIST (QUOTE PROG)
				      (LIST (SETQ TMPVAR (GLMKVAR)))
				      (LIST (QUOTE SETQ)
					    TMPVAR
					    (CADR INSIDE))
				      (LIST (QUOTE RETURN)
					    (QUOTE *GLCODE*]
		    (SELECTQ
		      OUTFN
		      (SUBSET (SETQ NEWMAP (QUOTE MAPCONC))
			      (SETQ NEWFN
				(SUBST (LIST (QUOTE AND)
					     (SUBST TMPVAR
						    (CAR OUTSIDE)
						    (CADR OUTSIDE))
					     (LIST (QUOTE CONS)
						   TMPVAR NIL))
				       (QUOTE *GLCODE*)
				       NEWFN)))
		      (MAPCAR (SETQ NEWMAP (QUOTE MAPCAR))
			      (SETQ NEWFN (SUBST (SUBST TMPVAR
							(CAR OUTSIDE)
							(CADR OUTSIDE))
						 (QUOTE *GLCODE*)
						 NEWFN)))
		      (MAPC (SETQ NEWMAP (QUOTE MAPC))
			    (SETQ NEWFN (SUBST (SUBST TMPVAR
						      (CAR OUTSIDE)
						      (CADR OUTSIDE))
					       (QUOTE *GLCODE*)
					       NEWFN)))
		      (ERROR)))
	    (ERROR))
          (RETURN
	    (GLUNWRAP [GLGENCODE
			(LIST NEWMAP NEWLST
			      (LIST (QUOTE FUNCTION)
				    (LIST (QUOTE LAMBDA)
					  (LIST (CAR INSIDE))
					  NEWFN]
		      BUSY))
      OUT (RETURN (GLGENCODE (CONS OUTFN (CONS LST (CONS FN CDRFN])

(GLUNWRAPPROG
  [LAMBDA (X BUSY)                              (* GSN "22-JUL-83 14:21"
)                                               (* Unwrap a PROG 
						expression.)
    (PROG (LAST)
          (COND
	    ((NEQ GLLISPDIALECT (QUOTE INTERLISP))
	      (GLTRANSPROG X)))

          (* First see if the PROG is not busy and ends with a
	  RETURN.)


          [COND
	    ((AND (NOT BUSY)
		  (EQ (CAR X)
		      (QUOTE PROG))
		  (SETQ LAST (LAST X))
		  (LISTP (CAR LAST))
		  (EQ (CAAR LAST)
		      (QUOTE RETURN)))          (* Remove the RETURN.
						If atomic, remove the 
						atom also.)
	      (COND
		((ATOM (CADAR LAST))
		  (RPLACD (NLEFT X 2)
			  NIL))
		(T (RPLACA LAST (CADAR LAST]    (* Do any 
						initializations of PROG 
						variables.)
          [MAPC (CADR X)
		(FUNCTION (LAMBDA (Y)
		    (COND
		      ((LISTP Y)
			(RPLACA (CDR Y)
				(GLUNWRAP (CADR Y)
					  T]
          [MAP (CDDR X)
	       (FUNCTION (LAMBDA (Y)
		   (RPLACA Y (GLUNWRAP (CAR Y)
				       NIL]
          (GLEXPANDPROGN (CDR X)
			 BUSY T)
          (RETURN X])

(GLUNWRAPSELECTQ
  [LAMBDA (X BUSY)                              (* GSN "27-JAN-83 13:57"
)                                               (* Unwrap a SELECTQ or 
						CASEQ expression.)
    (PROG (L SELECTOR)                          (* First unwrap the 
						component expressions.)
          (RPLACA (CDR X)
		  (GLUNWRAP (CADR X)
			    T))
          [MAP
	    (CDDR X)
	    (FUNCTION (LAMBDA (Y)
		(COND
		  ((OR (CDR Y)
		       (EQ (CAR X)
			   (QUOTE CASEQ)))
		    [MAP (CDAR Y)
			 (FUNCTION (LAMBDA (Z)
			     (RPLACA Z
				     (GLUNWRAP
				       (CAR Z)
				       (AND BUSY (NULL (CDR Z]
		    (GLEXPANDPROGN (CAR Y)
				   BUSY NIL))
		  (T (RPLACA Y (GLUNWRAP (CAR Y)
					 BUSY]
                                                (* Test if the selector 
						is a compile-time 
						constant.)
          (COND
	    ((NOT (GLCONST? (CADR X)))
	      (RETURN X)))                      (* Evaluate the 
						selection at compile 
						time.)
          (SETQ SELECTOR (GLCONSTVAL (CADR X)))
          (SETQ L (CDDR X))
      LP  [COND
	    ((NULL L)
	      (RETURN NIL))
	    ((AND (NULL (CDR L))
		  (EQ (CAR X)
		      (QUOTE SELECTQ)))
	      (RETURN (CAR L)))
	    ((AND (EQ (CAR X)
		      (QUOTE CASEQ))
		  (EQ (CAAR L)
		      T))
	      (RETURN (GLUNWRAP (CONS (QUOTE PROGN)
				      (CDAR L))
				BUSY)))
	    ([OR (EQ SELECTOR (CAAR L))
		 (AND (LISTP (CAAR L))
		      (MEMB SELECTOR (CAAR L]
	      (RETURN (GLUNWRAP (CONS (QUOTE PROGN)
				      (CDAR L))
				BUSY]
          (SETQ L (CDR L))
          (GO LP])

(GLUPDATEVARTYPE
  [LAMBDA (VAR TYPE)                            (* edited: 
						" 5-MAY-82 15:49")
                                                (* "GSN: " 
						"25-Jan-81 18:00")
                                                (* Update the type of 
						VAR to be TYPE.)
    (PROG (CTXENT)
          (COND
	    ((NULL TYPE))
	    [(SETQ CTXENT (GLFINDVARINCTX VAR CONTEXT))
	      (COND
		((NULL (CADDR CTXENT))
		  (RPLACA (CDDR CTXENT)
			  TYPE]
	    (T (GLADDSTR VAR NIL TYPE CONTEXT])

(GLUSERFN
  [LAMBDA (EXPR)                                (* GSN "23-JAN-83 15:31"
)                                               (* "GSN: " 
						" 7-Apr-81 10:44")

          (* Process a user-function, i.e., any function which
	  is not specially compiled by GLISP.
	  The function is tested to see if it is one which a 
	  unit package wants to compile specially;
	  if not, the function is compiled by GLUSERFNB.)


    (PROG (FNNAME TMP UPS)
          (SETQ FNNAME (CAR EXPR))

          (* First see if a user structure-name package wants 
	  to intercept this function call.)


          (SETQ UPS GLUSERSTRNAMES)
      LPA [COND
	    ((NULL UPS)
	      (GO B))
	    ([SETQ TMP (ASSOC FNNAME (CAR (CDDDDR (CAR UPS]
	      (RETURN (APPLY* (CDR TMP)
			      EXPR CONTEXT]
          (SETQ UPS (CDR UPS))
          (GO LPA)
      B   

          (* Test the function name to see if it is a function
	  which some unit package would like to intercept and 
	  compile specially.)


          (SETQ UPS GLUNITPKGS)
      LP  [COND
	    ((NULL UPS)
	      (GO C))
	    ([AND [MEMB FNNAME (CAR (CDDDDR (CAR UPS]
		  (SETQ TMP (ASSOC (QUOTE UNITFN)
				   (CADDR (CAR UPS]
	      (RETURN (APPLY* (CDR TMP)
			      EXPR CONTEXT]
          (SETQ UPS (CDR UPS))
          (GO LP)
      C   (COND
	    [(AND (BOUNDP (QUOTE GLFNSUBS))
		  (SETQ TMP (ASSOC FNNAME GLFNSUBS)))
	      (RETURN (GLUSERFNB (CONS (CDR TMP)
				       (CDR EXPR]
	    (T (RETURN (GLUSERFNB EXPR])

(GLUSERFNB
  [LAMBDA (EXPR)                                (* GSN "23-JAN-83 15:54"
)                                               (* "GSN: " 
						" 7-Apr-81 10:44")

          (* Parse an arbitrary function by getting the 
	  function name and then calling GLDOEXPR to get the 
	  arguments.)


    (PROG (ARGS ARGTYPES FNNAME TMP)
          (SETQ FNNAME (pop EXPR))
      A   (COND
	    [(NULL EXPR)
	      (SETQ ARGS (DREVERSE ARGS))
	      (SETQ ARGTYPES (DREVERSE ARGTYPES))
	      (RETURN (COND
			((AND (GETPROP FNNAME (QUOTE GLEVALWHENCONST))
			      (EVERY ARGS (FUNCTION GLCONST?)))
			  (LIST (EVAL (CONS FNNAME ARGS))
				(GLRESULTTYPE FNNAME ARGTYPES)))
			(T (LIST (CONS FNNAME ARGS)
				 (GLRESULTTYPE FNNAME ARGTYPES]
	    ([SETQ TMP (OR (GLDOEXPR NIL CONTEXT T)
			   (PROG1 (GLERROR (QUOTE GLUSERFNB)
					   (LIST 
		     "Function call contains illegal item.  EXPR ="
						 EXPR))
				  (SETQ EXPR NIL]
	      (SETQ ARGS (CONS (CAR TMP)
			       ARGS))
	      (SETQ ARGTYPES (CONS (CADR TMP)
				   ARGTYPES))
	      (GO A])

(GLUSERGETARGS
  [LAMBDA (EXPR CONTEXT)                        (* edited: 
						"24-AUG-82 17:40")
                                                (* edited: 
						" 7-Apr-81 10:44")

          (* Get the arguments to an function call for use by 
	  a user compilation function.)


    (PROG (ARGS TMP)
          (pop EXPR)
      A   (COND
	    ((NULL EXPR)
	      (RETURN (DREVERSE ARGS)))
	    ([SETQ TMP (OR (GLDOEXPR NIL CONTEXT T)
			   (PROG1 (GLERROR (QUOTE GLUSERFNB)
					   (LIST 
		     "Function call contains illegal item.  EXPR ="
						 EXPR))
				  (SETQ EXPR NIL]
	      (SETQ ARGS (CONS TMP ARGS))
	      (GO A])

(GLVALUE
  [LAMBDA (SOURCE PROP TYPE DESLIST)            (* GSN "10-FEB-83 12:57"
)

          (* Get the value of the property PROP from SOURCE, 
	  whose type is given by TYPE.
	  The property may be a field in the structure, or may
	  be a PROP virtual field.)



          (* DESLIST is a list of object types which have 
	  previously been tried, so that a compiler loop can 
	  be prevented.)


    (PROG (TMP PROPL TRANS FETCHCODE)
          (COND
	    ((FMEMB TYPE DESLIST)
	      (RETURN))
	    ((SETQ TMP (GLSTRFN PROP TYPE DESLIST))
	      (RETURN (GLSTRVAL TMP SOURCE)))
	    ((SETQ PROPL (GLSTRPROP TYPE (QUOTE PROP)
				    PROP NIL))
	      (SETQ TMP (GLCOMPMSGL (LIST SOURCE TYPE)
				    (QUOTE PROP)
				    PROPL NIL CONTEXT))
	      (RETURN TMP)))                    (* See if the value can 
						be found in a 
						TRANSPARENT subobject.)
          (SETQ TRANS (GLTRANSPARENTTYPES TYPE))
      B   (COND
	    ((NULL TRANS)
	      (RETURN))
	    ((SETQ TMP (GLVALUE (QUOTE *GL*)
				PROP
				(GLXTRTYPE (CAR TRANS))
				(CONS (CAR TRANS)
				      DESLIST)))
	      (SETQ FETCHCODE (GLSTRFN (CAR TRANS)
				       TYPE NIL))
	      (GLSTRVAL TMP (CAR FETCHCODE))
	      (GLSTRVAL TMP SOURCE)
	      (RETURN TMP))
	    ((SETQ TMP (CDR TMP))
	      (GO B])

(GLVARTYPE
  [LAMBDA (VAR CONTEXT)                         (* edited: 
						"16-DEC-81 12:00")
                                                (* "GSN: " 
						"21-Apr-81 11:30")
                                                (* Get the 
						structure-description 
						for a variable in the 
						specified context.)
    (PROG (TMP)
          (RETURN (COND
		    ((SETQ TMP (GLFINDVARINCTX VAR CONTEXT))
		      (OR (CADDR TMP)
			  (QUOTE *NIL*)))
		    (T NIL])

(GLXTRFN
  [LAMBDA (FNLST)                               (* edited: 
						" 3-DEC-82 10:24")

          (* Extract the code and variable from a FUNCTION 
	  list. If there is no variable, a new one is created.
	  The result is a list of the variable and code.)


    (PROG (TMP)                                 (* If only the function 
						name is specified, make 
						a LAMBDA form.)
          [COND
	    ((ATOM (CADR FNLST))
	      (RPLACA (CDR FNLST)
		      (LIST (QUOTE LAMBDA)
			    (LIST (SETQ TMP (GLMKVAR)))
			    (LIST (CADR FNLST)
				  TMP]
          [COND
	    ((CDDDR (CADR FNLST))
	      (RPLACD (CDADR FNLST)
		      (LIST (CONS (QUOTE PROGN)
				  (CDDADR FNLST]
          (RETURN (LIST (CAADR (CADR FNLST))
			(CADDR (CADR FNLST])

(GLXTRTYPEB
  [LAMBDA (TYPE)                                (* edited: 
						"26-JUL-82 14:02")
                                                (* Extract a -real- type
						from a type spec.)
    (COND
      ((NULL TYPE)
	NIL)
      [(ATOM TYPE)
	(COND
	  ((MEMB TYPE GLBASICTYPES)
	    TYPE)
	  (T (GLXTRTYPEB (GLGETSTR TYPE]
      ((NLISTP TYPE)
	NIL)
      ((MEMB (CAR TYPE)
	     GLTYPENAMES)
	TYPE)
      ((ASSOC (CAR TYPE)
	      GLUSERSTRNAMES)
	TYPE)
      ((AND (ATOM (CAR TYPE))
	    (CDR TYPE))
	(GLXTRTYPEB (CADR TYPE)))
      (T (GLERROR (QUOTE GLXTRTYPE)
		  (LIST TYPE "is an illegal type specification."))
	 NIL])

(GLXTRTYPEC
  [LAMBDA (TYPE)                                (* edited: 
						" 1-NOV-82 16:38")
                                                (* Extract a -real- type
						from a type spec.)
    (AND (ATOM TYPE)
	 (NOT (MEMB TYPE GLBASICTYPES))
	 (GLXTRTYPE (GLGETSTR TYPE])
)
[FILEPKGCOM (QUOTE GLISPCONSTANTS)
	    (QUOTE MACRO)
	    (QUOTE (GLISPCONSTANTS (E (GLPRETTYPRINTCONST (QUOTE 
						     GLISPCONSTANTS]
(FILEPKGTYPE (QUOTE GLISPCONSTANTS)
	     (QUOTE DESCRIPTION)
	     (QUOTE "GLISP compile-time constants")
	     (QUOTE GETDEF)
	     (QUOTE GLGETCONSTDEF))
[FILEPKGCOM (QUOTE GLISPGLOBALS)
	    (QUOTE MACRO)
	    (QUOTE (GLISPGLOBALS (E (GLPRETTYPRINTGLOBALS (QUOTE 
						       GLISPGLOBALS]
(FILEPKGTYPE (QUOTE GLISPGLOBALS)
	     (QUOTE DESCRIPTION)
	     (QUOTE "GLISP global variables")
	     (QUOTE GETDEF)
	     (QUOTE GLGETGLOBALDEF))
[FILEPKGCOM (QUOTE GLISPOBJECTS)
	    (QUOTE MACRO)
	    (QUOTE (GLISPOBJECTS (E (GLPRETTYPRINTSTRS (QUOTE 
						       GLISPOBJECTS]
(FILEPKGTYPE (QUOTE GLISPOBJECTS)
	     (QUOTE DESCRIPTION)
	     (QUOTE "GLISP Object Definitions")
	     (QUOTE GETDEF)
	     (QUOTE GLGETDEF)
	     (QUOTE DELDEF)
	     (QUOTE GLDELDEF))

(ADDTOVAR LAMBDASPLST GLAMBDA)

(ADDTOVAR LAMBDATRANFNS (GLAMBDA GLAMBDATRAN EXPR NIL))

(ADDTOVAR PRETTYEQUIVLST (GLAMBDA . LAMBDA))
(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS 
	  GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES GLLASTFNCOMPILED 
	  GLLASTSTREDITED GLCAUTIOUSFLG GLLISPDIALECT GLBASICTYPES 
	  GLOBJECTNAMES GLTYPESUSED GLNOSPLITATOMS GLGLSENDFLG 
	  GEVUSERTYPENAMES)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(SPECVARS CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR GLTOPCTX 
	  RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS GLEXPR DESLIST 
	  EXPRSTACK GLTYPESUBS GLPROGLST ADDISATYPE GLFNSUBS 
	  GLNRECURSIONS PAIRS NEW N)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA )

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2599 80225 (GLLISPADJ 2609 . 3263) (GLLISPISA 3265 . 3882) (GLMAKEFORLOOP 3884 . 5404) 
(GLMAKEGLISPVERSION 5406 . 7512) (GLMAKEGLISPVERSIONS 7514 . 7755) (GLMAKESTR 7757 . 8604) (
GLMAKEVTYPE 8606 . 9910) (GLMATCH 9912 . 10615) (GLMATCHL 10617 . 11091) (GLMINUSFN 11093 . 11619) (
GLMKLABEL 11621 . 11950) (GLMKVTYPE 11952 . 12197) (GLNCONCFN 12199 . 14445) (GLNEQUALFN 14447 . 15225
) (GLNOTESOURCETYPE 15227 . 15875) (GLNOTFN 15877 . 16201) (GLOCCURS 16203 . 16513) (GLOPERAND 16515
 . 17313) (GLOPERATOR? 17315 . 17613) (GLORFN 17615 . 18322) (GLOUTPUTFILTER 18324 . 19012) (
GLPARSEXPR 19014 . 21267) (GLPARSFLD 21269 . 22593) (GLPARSNFLD 22595 . 23444) (GLPLURAL 23446 . 24302
) (GLPOPFN 24304 . 26111) (GLPREC 26113 . 27159) (GLPREDICATE 27161 . 30253) (GLPRETTYPRINTCONST 30255
 . 30828) (GLPRETTYPRINTGLOBALS 30830 . 31337) (GLPRETTYPRINTSTRS 31339 . 32235) (GLPROGN 32237 . 
33038) (GLPURE 33040 . 33342) (GLPUSHEXPR 33344 . 33839) (GLPUSHFN 33841 . 36054) (GLPUTPROPS 36056 . 
36617) (GLPUTUPFN 36619 . 37685) (GLREDUCE 37687 . 38670) (GLREDUCEARITH 38672 . 44504) (GLREDUCEOP 
44506 . 45528) (GLREMOVEFN 45530 . 47360) (GLRESGLOBAL 47362 . 48380) (GLSAVEFNTYPES 48382 . 48681) (
GLSEPCLR 48683 . 48800) (GLSEPINIT 48802 . 49291) (GLSEPNXT 49293 . 51371) (GLSKIPCOMMENTS 51373 . 
51901) (GLSUBATOM 51903 . 52038) (GLSUBLIS 52040 . 52466) (GLSUBSTTYPE 52468 . 52726) (GLTHE 52728 . 
55248) (GLTHESPECS 55250 . 56296) (GLTRANSPROG 56298 . 57501) (GLUNCOMPILE 57503 . 59344) (GLUNSAVEDEF
 59346 . 59856) (GLUNWRAP 59858 . 62620) (GLUNWRAPCOND 62622 . 63543) (GLUNWRAPINTERSECT 63545 . 65367
) (GLUNWRAPLOG 65369 . 66495) (GLUNWRAPMAP 66497 . 70527) (GLUNWRAPPROG 70529 . 71594) (
GLUNWRAPSELECTQ 71596 . 73142) (GLUPDATEVARTYPE 73144 . 73643) (GLUSERFN 73645 . 75114) (GLUSERFNB 
75116 . 76166) (GLUSERGETARGS 76168 . 76800) (GLVALUE 76802 . 78079) (GLVARTYPE 78081 . 78552) (
GLXTRFN 78554 . 79309) (GLXTRTYPEB 79311 . 79943) (GLXTRTYPEC 79945 . 80223)))))
STOP
)))))
STOP