(FILECREATED "22-Dec-83 10:44:11" <CS.NOVAK>GLISPR.LSP.4 80158  


     changes to:  GLOKSTR?

     previous date: "12-Dec-83 11:37:32" <CS.NOVAK>GLISPR.LSP.3)


(PRETTYCOMPRINT GLISPRCOMS)

(RPAQQ GLISPRCOMS [(* Copyright (c)
		      1983 by Gordon S. Novak Jr.)
	(* This is the runtime subset of GLISP, GLISPR. The other two 
	   GLISP files, GLISPA and GLISPB, are added to this file to 
	   form the complete compiler.)
	(FNS A AN GL-A-AN? GLADDPROP GLADDTOOBJECT GLADDTOOBJECTS 
	     GLAINTERPRETER GLANYCARCDR? GLAPPLY GLAQR GLAQRB 
	     GLAQRLISTOF GLAQRRD GLAQRSTR GLATMSTR? GLATOMSTRFN 
	     GLCARCDRRESULTTYPE GLCARCDRRESULTTYPEB GLCLASS GLCLASSMEMP 
	     GLCLASSP GLCLASSSEND GLCOMPPROP GLCOMPPROPL GLDEFAULTVALUE 
	     GLDEFFNRESULTTYPES GLDEFFNRESULTTYPEFNS GLDEFPROP GLDEFSTR 
	     GLDEFSTRNAMES GLDEFSTRQ GLDEFSYSSTRQ GLDEFUNITPKG GLDELDEF 
	     GLDESCENDANTP GLDOEXPRC GLED GLEDS GLERR GLERROR 
	     GLEXPENSIVE? GLGENCODE GLGETASSOC GLGETD GLGETDB GLGETDEF 
	     GLGETFROMUNIT GLGETPAIRS GLGETSTR GLGETSUPERS 
	     GLIFSTRCHANGED GLINIT GLISPCONSTANTS GLISPCP GLISPGLOBALS 
	     GLISPOBJECTS GLLISTRESULTTYPEFN GLLISTSTRFN GLMKATOM 
	     GLMKRECORD GLMKSTR GLMKVAR GLNOTICETYPE GLNTHRESULTTYPEFN 
	     GLOKSTR? GLP GLPROPSTRFN GLPUTARITH GLPUTFN GLRESULTTYPE 
	     GLSEND GLSENDB GLSENDC GLSENDPROP GLSENDPROPC GLSTRCHANGED 
	     GLSTRFN GLSTRPROP GLSTRPROPB GLSTRVAL GLSTRVALB GLSUPERS 
	     GLTRANSPARENTTYPES GLTRANSPB GLTYPEMATCH GLUNIT? GLUNITOP 
	     GLUNWRAPC GLUSERSTROP GLXTRTYPE GLYESP SEND SENDC SENDPROP 
	     SENDPROPC)
	(VARS GLBASICTYPES GLLISPDIALECT GLSPECIALFNS GLTYPENAMES
	      (GLOBJECTNAMES NIL))
	(PROP GLSTRUCTURE GLTYPE GLPROPENTRY GLPROPFNENTRY GLFUNCTION)
	(GLOBALVARS GLQUIETFLG GLSEPBITTBL GLUNITPKGS GLSEPMINUS 
		    GLTYPENAMES GLBREAKONERROR GLUSERSTRNAMES 
		    GLLASTFNCOMPILED GLLASTSTREDITED GLCAUTIOUSFLG 
		    GLLISPDIALECT GLBASICTYPES GLOBJECTNAMES 
		    GLTYPESUSED GLNOSPLITATOMS GLGLSENDFLG 
		    GEVUSERTYPENAMES)
	(SPECVARS CONTEXT EXPR VALBUSY FAULTFN GLSEPATOM GLSEPPTR 
		  GLTOPCTX RESULTTYPE RESULT GLNATOM FIRST OPNDS OPERS 
		  GLEXPR DESLIST EXPRSTACK GLTYPESUBS GLPROGLST 
		  ADDISATYPE GLFNSUBS GLNRECURSIONS PAIRS NEW N)
	(P (GLINIT))
	(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
		  (ADDVARS (NLAMA SENDPROPC SENDPROP SENDC SEND 
				  GLSENDPROPC GLSENDPROP GLSENDC GLSEND 
				  GLISPOBJECTS GLISPGLOBALS 
				  GLISPCONSTANTS GLERR GLDEFSYSSTRQ 
				  GLDEFSTRQ GLDEFSTRNAMES 
				  GLADDTOOBJECTS AN A)
			   (NLAML)
			   (LAMA])
[DECLARE: DONTEVAL@LOAD DONTCOPY
(* Copyright (c)
     1983 by Gordon S. Novak Jr.)  ]

[DECLARE: DONTEVAL@LOAD DONTCOPY
(* This is the runtime subset of GLISP, GLISPR. The other two GLISP 
     files, GLISPA and GLISPB, are added to this file to form the 
     complete compiler.)  ]

(DEFINEQ

(A
  [NLAMBDA L                                    (* edited: 
						"18-NOV-82 11:47")
    (GLAINTERPRETER L])

(AN
  [NLAMBDA L                                    (* edited: 
						"18-NOV-82 11:47")
    (GLAINTERPRETER L])

(GL-A-AN?
  [LAMBDA (X)                                   (* edited: 
						"29-OCT-81 14:25")
                                                (* "GSN: " 
						"20-Mar-81 10:34")
    (FMEMB X (QUOTE (A AN a an An])

(GLADDPROP
  [LAMBDA (STRNAME PROPTYPE LST)                (* GSN "16-FEB-83 12:39"
)                                               (* Add a PROPerty entry 
						of type PROPTYPE to 
						structure STRNAME.)
    (PROG (PL SUBPL)
          (COND
	    ([NOT (AND (ATOM STRNAME)
		       (SETQ PL (GETPROP STRNAME (QUOTE GLSTRUCTURE]
	      (ERROR (LIST STRNAME " has no structure definition.")))
	    ((SETQ SUBPL (LISTGET (CDR PL)
				  PROPTYPE))
	      (NCONC SUBPL (LIST LST)))
	    (T (NCONC PL (LIST PROPTYPE (LIST LST])

(GLADDTOOBJECT
  [LAMBDA (LST)                                 (* GSN "30-APR-83 15:43"
)                                               (* Add properties to an 
						object description which
						already exists.)
    (PROG (OBJNAME PROPNAME PROPL TMP OBJDES PROPS)
          (SETQ OBJNAME (CAR LST))
          (SETQ LST (CDR LST))
      LP  (COND
	    ((NULL LST)
	      (RETURN))
	    ([OR [NOT (ATOM (SETQ PROPNAME (CAR LST]
		 (NOT (MEMB PROPNAME (QUOTE (PROP ADJ ISA MSG]
	      (ERROR "Improper args to GLADDTOOBJECT" OBJNAME))
	    ([NULL (SETQ OBJDES (GETPROP OBJNAME (QUOTE GLSTRUCTURE]
	      (ERROR "No object description exists for " OBJNAME)))
                                                (* Find or make a list 
						for this property name.)
          (COND
	    ((NULL (SETQ PROPL (LISTGET (CDR OBJDES)
					PROPNAME)))
	      (NCONC OBJDES (LIST PROPNAME (CADR LST)))
	      (SETQ LST (CDDR LST))
	      (GO LP)))
          (SETQ PROPS (CADR LST))
          (SETQ LST (CDDR LST))
      LPB [COND
	    ((NULL PROPS)
	      (GO LP))
	    ((SETQ TMP (ASSOC (CAAR PROPS)
			      PROPL))
	      (RPLACD TMP (CDAR PROPS)))
	    (T (NCONC1 PROPL (CAR PROPS]
          (SETQ PROPS (CDR PROPS))
          (GO LPB])

(GLADDTOOBJECTS
  [NLAMBDA ARGS                                 (* GSN "30-APR-83 15:19"
)                                               (* Add properties to an 
						already-existing object 
						description.)
    (MAPC ARGS (FUNCTION GLADDTOOBJECT])

(GLAINTERPRETER
  [LAMBDA (EXPR)                                (* GSN "26-JUL-83 13:58"
)
    (PROG (GLNATOM FAULTFN CONTEXT VALBUSY GLSEPATOM GLSEPPTR EXPRSTACK 
		   GLTOPCTX GLGLOBALVARS GLNRECURSIONS TYPE STR PAIRS 
		   UNITREC TMP)
          (SETQ GLNATOM 0)
          (SETQ GLNRECURSIONS 0)
          (SETQ FAULTFN (QUOTE GLAINTERPRETER))
          (SETQ VALBUSY T)
          (SETQ GLSEPPTR 0)
          (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL)))
          (SETQ TYPE (CAR EXPR))
          [COND
	    ((SETQ STR (GLGETSTR TYPE))
	      (SETQ EXPR (CDR EXPR)))
	    [[AND (SETQ UNITREC (GLUNIT? TYPE))
		  (SETQ TMP (ASSOC (QUOTE A)
				   (CADDR UNITREC]
	      (RETURN (APPLY* (CDR TMP)
			      (CONS (QUOTE A)
				    EXPR]
	    (T (GLERROR (QUOTE GLAINTERPRETER)
			(LIST "The type" TYPE "is not defined."]
          (COND
	    ((FMEMB (CAR EXPR)
		    (QUOTE (WITH With with)))
	      (pop EXPR)))
          (SETQ PAIRS (GLGETPAIRS EXPR))
          (RETURN (GLMKSTR STR TYPE PAIRS NIL])

(GLANYCARCDR?
  [LAMBDA (ATM)                                 (* edited: 
						"19-MAY-82 13:54")

          (* Test if ATM is the name of any CAR/CDR 
	  combination. If so, the value is a list of the 
	  intervening letters in reverse order.)


    (PROG (RES N NMAX TMP)
          (OR (AND (EQ (NTHCHAR ATM 1)
		       (QUOTE C))
		   (EQ (NTHCHAR ATM -1)
		       (QUOTE R)))
	      (RETURN))
          (SETQ NMAX (SUB1 (NCHARS ATM)))
          (SETQ N 2)
      A   (COND
	    ((IGREATERP N NMAX)
	      (RETURN RES))
	    ((OR (EQ (SETQ TMP (NTHCHAR ATM N))
		     (QUOTE D))
		 (EQ TMP (QUOTE A)))
	      (SETQ RES (CONS TMP RES))
	      (SETQ N (ADD1 N))
	      (GO A))
	    (T (RETURN])

(GLAPPLY
  [LAMBDA (FN ARGS)                             (* GSN " 6-JUN-83 15:42"
)
    (APPLY FN ARGS])

(GLAQR
  [LAMBDA (STR)                                 (* Acquire an instance 
						of a data type based on 
						its description.)
    (GLAQRB STR NIL 0 NIL])

(GLAQRB
  [LAMBDA (STR NAME LEVEL PREV)                 (* GSN "25-JUL-83 14:08"
)

          (* Acquire an instance of a data type based on its 
	  descripttion. str is the structure description of 
	  the data, name is the name of the structure, or nil,
	  level is the depth level in the structure tree.)


    (PROG (RES NEW N)
          (COND
	    ((FMEMB STR PREV)
	      (RETURN NIL)))
          (SETQ PREV (CONS STR PREV))
          (RETURN
	    (COND
	      ((NULL STR)
		NIL)
	      [(ATOM STR)
		(PRIN1 "(")
		(PRIN1 STR)
		(PRIN1 ")")
		(COND
		  ((FMEMB STR GLBASICTYPES)
		    (GLAQRRD STR))
		  (T (GLAQRSTR STR LEVEL PREV]
	      ((NLISTP STR)
		(ERROR (LIST "Invalid structure:" STR)))
	      [(FMEMB (CAR STR)
		      GLTYPENAMES)
		(COND
		  ((EQ (CAR STR)
		       (QUOTE ATOM))
		    [SETQ NEW (GLMKATOM (OR NAME (QUOTE GLAQR]
		    [MAPC
		      (CDR STR)
		      (FUNCTION (LAMBDA (Y)
			  (COND
			    [(EQ (CAR Y)
				 (QUOTE PROPLIST))
			      (MAPC (CDR Y)
				    (FUNCTION (LAMBDA (X)
					(PUTPROP NEW (CAR X)
						 (GLAQRB X NIL
							 (ADD1 LEVEL)
							 PREV]
			    ((EQ (CAR Y)
				 (QUOTE BINDING))
			      (SET NEW (GLAQRB (CADR Y)
					       NIL
					       (ADD1 LEVEL)
					       PREV]
		    NEW)
		  ((EQ (CAR STR)
		       (QUOTE LISTOF))
		    (GLAQRLISTOF (CADR STR)
				 PREV))
		  (T
		    [MAPC (COND
			    ((AND (EQ (CAR STR)
				      (QUOTE RECORD))
				  (ATOM (CADR STR)))
			      (CDDR STR))
			    (T (CDR STR)))
			  (FUNCTION (LAMBDA (X)
			      (SETQ RES
				(CONS (CONS (AND (LISTP X)
						 (CAR X))
					    (GLAQRB X NIL (ADD1 LEVEL)
						    PREV))
				      RES]
		    (SETQ RES (DREVERSE RES))
		    (SELECTQ
		      (CAR STR)
		      (CONS (CONS (CDAR RES)
				  (CDADR RES)))
		      (LIST (MAPCAR RES (FUNCTION CDR)))
		      (ALIST RES)
		      [PROPLIST (MAPCONC RES (FUNCTION (LAMBDA (X)
					     (LIST (CAR X)
						   (CDR X]
		      (ATOMOBJECT [SETQ NEW (GLMKATOM
				      (OR NAME (QUOTE GLAQR]
				  (PUTPROP NEW (QUOTE CLASS)
					   NAME)
				  [MAPC RES (FUNCTION (LAMBDA (X)
					    (PUTPROP NEW (CAR X)
						     (CDR X]
				  NEW)
		      ((OBJECT RECORD)
			[SETQ NEW
			  (GLMKRECORD [COND
					[(EQ (CAR STR)
					     (QUOTE OBJECT))
					  (ADD1 (LENGTH (CDR STR]
					((ATOM (CADR STR))
					  (LENGTH (CDDR STR)))
					(T (LENGTH (CDR STR]
				      (AND (ATOM (CADR STR))
					   (CADR STR]
			(SETQ N 0)
			[COND
			  ((EQ (CAR STR)
			       (QUOTE OBJECT))
			    [SELECTQ GLLISPDIALECT
				     [INTERLISP (COND
						  ((LISTP NEW)
						    (RPLACA NEW NAME]
				     (PSL (PUTV NEW 0 NAME))
				     ((MACLISP FRANZLISP)
				       (RPLACX 0 NEW NAME))
				     (COND
				       ((LISTP NEW)
					 (RPLACA NEW NAME]
			    (SETQ N (ADD1 N]
			[MAPC
			  RES
			  (FUNCTION (LAMBDA (X)
			      [SELECTQ
				GLLISPDIALECT
				[INTERLISP
				  (COND
				    ((LISTP NEW)
				      (RPLACA (NTH NEW (ADD1 N))
					      (CDR X]
				(PSL (PUTV NEW N (CDR X)))
				((MACLISP FRANZLISP)
				  (RPLACX N NEW (CDR X)))
				(COND
				  ((LISTP NEW)
				    (RPLACA (NTH NEW (ADD1 N))
					    (CDR X]
			      (SETQ N (ADD1 N]
			NEW)
		      [LISTOBJECT (CONS NAME
					(MAPCAR RES
						(FUNCTION CDR]
		      NIL]
	      ((EQ (CAR STR)
		   (QUOTE TRANSPARENT))
		(GLAQRB (CADR STR)
			NIL
			(ADD1 LEVEL)
			PREV))
	      (T (SPACES (PLUS LEVEL LEVEL))
		 (PRIN1 (CAR STR))
		 (PRIN1 ":")
		 (SPACES 1)
		 (GLAQRB (CADR STR)
			 (CAR STR)
			 (ADD1 LEVEL)
			 PREV])

(GLAQRLISTOF
  [LAMBDA (STR PREV)                            (* GSN "25-JUL-83 14:08"
)                                               (* Acquire a list of 
						items.)
    (PROG (RES)
          (PRIN1 "(")
          (PRIN1 (QUOTE LISTOF))
          (PRIN1 " ")
          (PRIN1 STR)
          (PRIN1 ")")
          (TERPRI)
      LP  (COND
	    ((GLYESP "MORE?")
	      (SETQ RES (CONS (GLAQRB STR NIL 0 PREV)
			      RES))
	      (GO LP))
	    (T (RETURN (DREVERSE RES])

(GLAQRRD
  [LAMBDA (STR)                                 (* Read in a single 
						item)
    (PROG (INP)
          (SETQ INP (READ))
          (RETURN INP])

(GLAQRSTR
  [LAMBDA (STR LEVEL PREV)                      (* GSN "26-JUL-83 13:50"
)
    (TERPRI)
    (COND
      ((OR (EQUAL LEVEL 0)
	   (GLYESP "Acquire a new value"))
	(GLAQRB (CAR (GETPROP STR (QUOTE GLSTRUCTURE)))
		STR
		(ADD1 LEVEL)
		PREV))
      (T (SELECTQ GLLISPDIALECT
		  (INTERLISP (PRIN1 "Enter existing value:"))
		  (PRINC "Enter existing value:"))
	 (EVAL (READ])

(GLATMSTR?
  [LAMBDA (STR)                                 (* GSN " 1-FEB-83 16:35"
)                                               (* "GSN: " 
						"14-Sep-81 12:45")
                                                (* Test whether STR is a
						legal ATOM structure.)
    (PROG (TMP)
          (COND
	    ([OR (AND (CDR STR)
		      (OR (NLISTP (CADR STR))
			  (AND (CDDR STR)
			       (OR (NLISTP (CADDR STR))
				   (CDDDR STR]
	      (RETURN)))
          [COND
	    ((SETQ TMP (ASSOC (QUOTE BINDING)
			      (CDR STR)))
	      (COND
		([OR (CDDR TMP)
		     (NULL (GLOKSTR? (CADR TMP]
		  (RETURN]
          [COND
	    ((SETQ TMP (ASSOC (QUOTE PROPLIST)
			      (CDR STR)))
	      (RETURN (EVERY (CDR TMP)
			     (FUNCTION (LAMBDA (X)
				 (AND (ATOM (CAR X))
				      (GLOKSTR? (CADR X]
          (RETURN T])

(GLATOMSTRFN
  [LAMBDA (IND DES DESLIST)                     (* edited: 
						"26-OCT-82 15:26")
                                                (* Try to get indicator 
						IND from an ATOM 
						structure.)
    (PROG (TMP)
          (RETURN (OR (AND (SETQ TMP (ASSOC (QUOTE PROPLIST)
					    (CDR DES)))
			   (GLPROPSTRFN IND TMP DESLIST T))
		      (AND (SETQ TMP (ASSOC (QUOTE BINDING)
					    (CDR DES)))
			   (GLSTRVALB IND (CADR TMP)
				      (QUOTE (EVAL *GL*])

(GLCARCDRRESULTTYPE
  [LAMBDA (LST STR)                             (* edited: 
						"14-MAR-83 16:59")

          (* Find the result type for a CAR/CDR function 
	  applied to a structure whose description is STR.
	  LST is a list of A and D in application order.)


    (COND
      ((NULL LST)
	STR)
      ((NULL STR)
	NIL)
      ((MEMB STR GLBASICTYPES)
	NIL)
      ((ATOM STR)
	(GLCARCDRRESULTTYPE LST (GLGETSTR STR)))
      ((NLISTP STR)
	(ERROR))
      (T (GLCARCDRRESULTTYPEB LST (GLXTRTYPE STR])

(GLCARCDRRESULTTYPEB
  [LAMBDA (LST STR)                             (* edited: 
						"19-MAY-82 14:41")

          (* Find the result type for a CAR/CDR function 
	  applied to a structure whose description is STR.
	  LST is a list of A and D in application order.)


    (COND
      ((NULL STR)
	NIL)
      ((ATOM STR)
	(GLCARCDRRESULTTYPE LST STR))
      ((NLISTP STR)
	(ERROR))
      ((AND (ATOM (CAR STR))
	    (NOT (MEMB (CAR STR)
		       GLTYPENAMES))
	    (CDR STR)
	    (NULL (CDDR STR)))
	(GLCARCDRRESULTTYPE LST (CADR STR)))
      ((EQ (CAR LST)
	   (QUOTE A))
	(COND
	  ((OR (EQ (CAR STR)
		   (QUOTE LISTOF))
	       (EQ (CAR STR)
		   (QUOTE CONS))
	       (EQ (CAR STR)
		   (QUOTE LIST)))
	    (GLCARCDRRESULTTYPE (CDR LST)
				(CADR STR)))
	  (T NIL)))
      [(EQ (CAR LST)
	   (QUOTE D))
	(COND
	  ((EQ (CAR STR)
	       (QUOTE CONS))
	    (GLCARCDRRESULTTYPE (CDR LST)
				(CADDR STR)))
	  ((EQ (CAR STR)
	       (QUOTE LIST))
	    (COND
	      [(CDDR STR)
		(GLCARCDRRESULTTYPE (CDR LST)
				    (CONS (QUOTE LIST)
					  (CDDR STR]
	      (T NIL)))
	  ((EQ (CAR STR)
	       (QUOTE LISTOF))
	    (GLCARCDRRESULTTYPE (CDR LST)
				STR]
      (T (ERROR])

(GLCLASS
  [LAMBDA (OBJ)                                 (* GSN "22-JUL-83 13:45"
)                                               (* Get the Class of 
						object OBJ.)
    (PROG (CLASS)
          (RETURN (AND (SETQ CLASS (COND
			   ((SELECTQ GLLISPDIALECT
				     ((MACLISP FRANZLISP)
				       (HUNKP OBJ))
				     (PSL (VectorP OBJ))
				     NIL)
			     (SELECTQ GLLISPDIALECT
				      ((MACLISP FRANZLISP)
					(CXR 0 OBJ))
				      (PSL (GetV OBJ 0))
				      NIL))
			   ((ATOM OBJ)
			     (GETPROP OBJ (QUOTE CLASS)))
			   ((LISTP OBJ)
			     (CAR OBJ))
			   ((AND (GETD (QUOTE GLUSERGETCLASS))
				 (GLUSERGETCLASS OBJ)))
			   (T NIL)))
		       (GLCLASSP CLASS)
		       CLASS])

(GLCLASSMEMP
  [LAMBDA (OBJ CLASS)                           (* edited: 
						"11-NOV-82 11:23")
                                                (* Test whether the 
						object OBJ is a member 
						of class CLASS.)
    (GLDESCENDANTP (GLCLASS OBJ)
		   CLASS])

(GLCLASSP
  [LAMBDA (CLASS)                               (* GSN "22-JUL-83 13:48"
)                                               (* See if CLASS is a 
						Class name.)
    (AND (ATOM CLASS)
	 (GETPROP CLASS (QUOTE GLSTRUCTURE])

(GLCLASSSEND
  [LAMBDA (CLASS SELECTOR ARGS PROPNAME)        (* GSN " 9-FEB-83 16:58"
)

          (* Execute a message to CLASS with selector SELECTOR
	  and arguments ARGS. PROPNAME is one of MSG, ADJ, 
	  ISA, PROP.)


    (PROG (FNCODE)
          [COND
	    ((SETQ FNCODE (GLCOMPPROP CLASS SELECTOR PROPNAME))
	      (RETURN
		(SELECTQ
		  GLLISPDIALECT
		  ((INTERLISP FRANZLISP)
		    (APPLY FNCODE ARGS))
		  (COND
		    [(ATOM FNCODE)
		      (EVAL (CONS FNCODE (MAPCAR
				    ARGS
				    (FUNCTION KWOTE]
		    (T (APPLY FNCODE ARGS]
          (RETURN (QUOTE GLSENDFAILURE])

(GLCOMPPROP
  [LAMBDA (STR PROPNAME PROPTYPE)               (* edited: 
						" 3-Dec-83 13:27")

          (* Compile a LAMBDA expression to compute the 
	  property PROPNAME of type PROPTYPE for structure 
	  STR. The property type STR is allowed for structure 
	  access.)


    (PROG (CODE PL SUBPL PROPENT)               (* See if the property 
						has already been 
						compiled.)
          [COND
	    ((NOT (ATOM STR))
	      (RETURN))
	    ([AND (SETQ PL (GETPROP STR (QUOTE GLPROPFNS)))
		  (SETQ SUBPL (ASSOC PROPTYPE PL))
		  (SETQ PROPENT (ASSOC PROPNAME (CDR SUBPL]
	      (RETURN (CADR PROPENT]            (* Compile code for this
						property and save it.)
          (COND
	    ([NOT (MEMB PROPTYPE (QUOTE (STR ADJ ISA PROP MSG]
	      (ERROR)))
          (OR (SETQ CODE (GLCOMPPROPL STR PROPNAME PROPTYPE))
	      (RETURN))
          [COND
	    ((NOT PL)
	      [PUTPROP STR (QUOTE GLPROPFNS)
		       (SETQ PL (COPY (QUOTE ((STR)
					       (PROP)
					       (ADJ)
					       (ISA)
					       (MSG]
	      (SETQ SUBPL (ASSOC PROPTYPE PL]
          (RPLACD SUBPL (CONS (CONS PROPNAME CODE)
			      (CDR SUBPL)))
          (RETURN (CAR CODE])

(GLCOMPPROPL
  [LAMBDA (STR PROPNAME PROPTYPE)               (* GSN "25-JUL-83 11:12"
)

          (* Compile a message as a closed form, i.e., 
	  function name or LAMBDA form.)


    (PROG (CODE MSGL TRANS TMP FETCHCODE NEWVAR GLNATOM CONTEXT VALBUSY 
		GLSEPATOM GLSEPPTR EXPRSTACK GLTOPCTX GLGLOBALVARS 
		GLTYPESUBS FAULTFN GLNRECURSIONS)
          (SETQ FAULTFN (QUOTE GLCOMPPROPL))
          (SETQ GLNRECURSIONS 0)
          (SETQ GLNATOM 0)
          (SETQ VALBUSY T)
          (SETQ GLSEPPTR 0)
          (SETQ CONTEXT (SETQ GLTOPCTX (LIST NIL)))
          (COND
	    [(EQ PROPTYPE (QUOTE STR))
	      (COND
		[(SETQ CODE (GLSTRFN PROPNAME STR NIL))
		  (RETURN (LIST (LIST (QUOTE LAMBDA)
				      (LIST (QUOTE self))
				      (GLUNWRAPC (DSUBST (QUOTE self)
							 (QUOTE *GL*)
							 (CAR CODE))
						 T))
				(CADR CODE]
		(T (RETURN]
	    [(SETQ MSGL (GLSTRPROP STR PROPTYPE PROPNAME NIL))
	      (COND
		[(ATOM (CADR MSGL))
		  (COND
		    ((AND (GLISPCP)
			  (LISTGET (CDDR MSGL)
				   (QUOTE OPEN)))
		      (SETQ CODE (GLCOMPOPEN (CADR MSGL)
					     T
					     (LIST STR)
					     NIL NIL)))
		    (T (SETQ CODE (LIST (CADR MSGL)
					(GLRESULTTYPE (CADR MSGL)
						      NIL]
		((AND (GLISPCP)
		      (SETQ CODE (GLADJ (LIST (QUOTE self)
					      STR)
					PROPNAME PROPTYPE)))
		  (SETQ CODE (LIST (LIST (QUOTE LAMBDA)
					 (LIST (QUOTE self))
					 (GLUNWRAPC (CAR CODE)
						    T))
				   (CADR CODE]
	    ((SETQ TRANS (GLTRANSPARENTTYPES STR))
	      (GO B))
	    (T (RETURN)))
          [RETURN (LIST (GLUNWRAPC (CAR CODE)
				   T)
			(OR (CADR CODE)
			    (LISTGET (CDDR MSGL)
				     (QUOTE RESULT]
                                                (* Look for the message 
						in a contained 
						TRANSPARENT type.)
      B   (COND
	    ((NULL TRANS)
	      (RETURN))
	    [(SETQ TMP (GLCOMPPROPL (GLXTRTYPE (CAR TRANS))
				    PROPNAME PROPTYPE))
	      (COND
		((ATOM (CAR TMP))
		  (GLERROR (QUOTE GLCOMPPROPL)
			   (LIST "GLISP cannot currently" 
			       "handle inheritance of the property"
				 PROPNAME 
			    "which is specified as a function name"
				 "in a TRANSPARENT subtype.  Sorry."))
		  (RETURN)))
	      (SETQ FETCHCODE (GLSTRFN (CAR TRANS)
				       STR NIL))
	      (SETQ NEWVAR (GLMKVAR))
	      (GLSTRVAL FETCHCODE NEWVAR)
	      (RETURN
		(LIST (GLUNWRAPC
			[LIST (QUOTE LAMBDA)
			      (CONS NEWVAR (CDADAR TMP))
			      (LIST (QUOTE PROG)
				    (LIST (LIST (CAADAR TMP)
						(CAR FETCHCODE)))
				    (LIST (QUOTE RETURN)
					  (CADDAR TMP]
			T)
		      (CADR TMP]
	    (T (SETQ TRANS (CDR TRANS))
	       (GO B])

(GLDEFAULTVALUE
  [LAMBDA (STR)                                 (* GSN "25-JUL-83 13:02"
)                                               (* Find the default 
						value to use for an item
						of type STR.)
    (COND
      ((ATOM STR)
	(SELECTQ STR
		 ((INTEGER NUMBER)
		   0)
		 (REAL 0.0)
		 (STRING "")
		 NIL))
      (T NIL])

(GLDEFFNRESULTTYPES
  [LAMBDA (LST)                                 (* edited: 
						"19-MAY-82 13:33")

          (* Define the result types for a list of functions.
	  The format of the argument is a list of dotted 
	  pairs, (FN . TYPE))


    (MAPC LST (FUNCTION (LAMBDA (X)
	      (MAPC (CADR X)
		    (FUNCTION (LAMBDA (Y)
			(PUTPROP Y (QUOTE GLRESULTTYPE)
				 (CAR X])

(GLDEFFNRESULTTYPEFNS
  [LAMBDA (LST)                                 (* edited: 
						"19-MAY-82 13:05")

          (* Define the result type functions for a list of 
	  functions. The format of the argument is a list of 
	  dotted pairs, (FN . TYPEFN))


    (MAPC LST (FUNCTION (LAMBDA (X)
	      (PUTPROP (CAR X)
		       (QUOTE GLRESULTTYPEFN)
		       (CDR X])

(GLDEFPROP
  [LAMBDA (OBJECT PROP LST)                     (* GSN " 2-MAR-83 10:14"
)

          (* Define properties for an object type.
	  Each property is of the form 
	  (<propname> (<definition>) <properties>))


    (PROG (LSTP)
          [MAPC LST (FUNCTION (LAMBDA (X)
		    (COND
		      ([NOT (OR (EQ PROP (QUOTE DOC))
				(AND (EQ PROP (QUOTE SUPERS))
				     (ATOM X))
				(AND (LISTP X)
				     (ATOM (CAR X))
				     (CDR X]
			(PRIN1 "GLDEFPROP: For object ")
			(PRIN1 OBJECT)
			(PRIN1 " the ")
			(PRIN1 PROP)
			(PRIN1 " property ")
			(PRIN1 X)
			(PRIN1 " has bad form.")
			(TERPRI)
			(PRIN1 "This property was ignored.")
			(TERPRI))
		      (T (SETQ LSTP (CONS X LSTP]
          (NCONC (GETPROP OBJECT (QUOTE GLSTRUCTURE))
		 (LIST PROP (DREVERSE LSTP])

(GLDEFSTR
  [LAMBDA (LST SYSTEMFLG)                       (* GSN " 1-JUN-83 17:28"
)                                               (* "GSN: " 
						"17-Sep-81 12:21")

          (* Process a Structure Description.
	  The format of the argument is the name of the 
	  structure followed by its structure description, 
	  followed by other optional arguments.)


    (PROG (STRNAME STR OLDSTR)
          (SETQ STRNAME (pop LST))
          [COND
	    ((AND (NOT SYSTEMFLG)
		  (MEMB STRNAME GLBASICTYPES))
	      (PRIN1 "The GLISP type ")
	      (PRIN1 STRNAME)
	      (PRIN1 " may not be redefined by the user.")
	      (TERPRI)
	      (RETURN))
	    ((SETQ OLDSTR (GETPROP STRNAME (QUOTE GLSTRUCTURE)))
	      (COND
		((EQUAL OLDSTR LST)
		  (RETURN))
		((NOT GLQUIETFLG)
		  (PRIN1 STRNAME)
		  (PRIN1 " structure redefined.")
		  (TERPRI)))
	      (GLSTRCHANGED STRNAME))
	    ((NOT SYSTEMFLG)
	      (SELECTQ GLLISPDIALECT
		       (INTERLISP (MARKASCHANGED STRNAME (QUOTE 
						       GLISPOBJECTS)
						 T))
		       (SETQ STR T]             (* The preceding 
						(SETQ STR T) avoids PSL 
						compiler bug.)
          (SETQ STR (pop LST))
          (PUTPROP STRNAME (QUOTE GLSTRUCTURE)
		   (LIST STR))
          (COND
	    ((NOT (GLOKSTR? STR))
	      (PRIN1 STRNAME)
	      (PRIN1 " has faulty structure specification.")
	      (TERPRI)))
          [COND
	    ((NOT (MEMB STRNAME GLOBJECTNAMES))
	      (SETQ GLOBJECTNAMES (CONS STRNAME GLOBJECTNAMES]

          (* Process the remaining specifications, if any.
	  Each additional specification is a list beginning 
	  with a keyword.)


      LP  (COND
	    ((NULL LST)
	      (RETURN)))
          (SELECTQ (CAR LST)
		   ((ADJ Adj adj)
		     (GLDEFPROP STRNAME (QUOTE ADJ)
				(CADR LST)))
		   ((PROP Prop prop)
		     (GLDEFPROP STRNAME (QUOTE PROP)
				(CADR LST)))
		   ((ISA Isa IsA isA isa)
		     (GLDEFPROP STRNAME (QUOTE ISA)
				(CADR LST)))
		   ((MSG Msg msg)
		     (GLDEFPROP STRNAME (QUOTE MSG)
				(CADR LST)))
		   (GLDEFPROP STRNAME (CAR LST)
			      (CADR LST)))
          (SETQ LST (CDDR LST))
          (GO LP])

(GLDEFSTRNAMES
  [NLAMBDA LST                                  (* edited: 
						"27-APR-82 11:01")
    (MAPC LST (FUNCTION (LAMBDA (X)
	      (PROG (TMP)
		    (COND
		      ((SETQ TMP (ASSOC (CAR X)
					GLUSERSTRNAMES))
			(RPLACD TMP (CDR X)))
		      (T (SETQ GLUSERSTRNAMES (NCONC1 GLUSERSTRNAMES X])

(GLDEFSTRQ
  [NLAMBDA ARGS                                 (* GSN "10-FEB-83 11:50"
)

          (* Define named structure descriptions.
	  The descriptions are of the form 
	  (<name> <description>). Each description is put on 
	  the property list of <name> as GLSTRUCTURE)


    (MAPC ARGS (FUNCTION (LAMBDA (ARG)
	      (GLDEFSTR ARG NIL])

(GLDEFSYSSTRQ
  [NLAMBDA ARGS                                 (* GSN "10-FEB-83 12:13"
)

          (* Define named structure descriptions.
	  The descriptions are of the form 
	  (<name> <description>). Each description is put on 
	  the property list of <name> as GLSTRUCTURE)


    (MAPC ARGS (FUNCTION (LAMBDA (ARG)
	      (GLDEFSTR ARG T])

(GLDEFUNITPKG
  [LAMBDA (UNITREC)                             (* edited: 
						"27-MAY-82 13:00")
                                                (* "GSN: " 
						" 2-Jun-81 13:31")

          (* This function is called by the user to define a 
	  unit package to the GLISP system.
	  The argument, a unit record, is a list consisting of
	  the name of a function to test an entity to see if 
	  it is a unit of the units package, the name of the 
	  unit package's runtime GET function, and an ALIST of
	  operations on units and the functions to perform 
	  those operations. Operations include GET, PUT, ISA, 
	  ISADJ, NCONC, REMOVE, PUSH, and POP.)


    (PROG (LST)
          (SETQ LST GLUNITPKGS)
      A   (COND
	    ((NULL LST)
	      (SETQ GLUNITPKGS (NCONC1 GLUNITPKGS UNITREC))
	      (RETURN))
	    ((EQ (CAAR LST)
		 (CAR UNITREC))
	      (RPLACA LST UNITREC)))
          (SETQ LST (CDR LST))
          (GO A])

(GLDELDEF
  [LAMBDA (NAME TYPE)                           (* GSN "23-JAN-83 15:39"
)                                               (* Remove the GLISP 
						structure definition for
						NAME.)
    (PUTPROP NAME (QUOTE GLSTRUCTURE)
	     NIL])

(GLDESCENDANTP
  [LAMBDA (SUBCLASS CLASS)                      (* edited: 
						"28-NOV-82 15:18")
    (PROG (SUPERS)
          (COND
	    ((EQ SUBCLASS CLASS)
	      (RETURN T)))
          (SETQ SUPERS (GLGETSUPERS SUBCLASS))
      LP  (COND
	    ((NULL SUPERS)
	      (RETURN))
	    ((GLDESCENDANTP (CAR SUPERS)
			    CLASS)
	      (RETURN T)))
          (SETQ SUPERS (CDR SUPERS))
          (GO LP])

(GLDOEXPRC
  [LAMBDA (START CONTEXT VALBUSY)               (* GSN "22-JUL-83 14:34"
)                                               (* Parse an expression 
						if the compiler is 
						present, else just 
						return it.)
    (COND
      ((GLISPCP)
	(GLDOEXPR START CONTEXT VALBUSY))
      (START (LIST EXPR (QUOTE ANYTHING)))
      (T (LIST (pop EXPR)
	       (QUOTE ANYTHING])

(GLED
  [LAMBDA (FN)                                  (* edited: 
						"20-MAY-82 12:48")
                                                (* "GSN: " 
						"15-Apr-81 16:51")
                                                (* Edit the compiled 
						version of a GLISP 
						function.)
    (EDITV (GETPROPLIST (OR FN GLLASTFNCOMPILED)))
    FN])

(GLEDS
  [LAMBDA (STR)                                 (* GSN "28-JAN-83 11:28"
)                                               (* "GSN: " 
						"15-Apr-81 16:51")
                                                (* Edit a GLISP 
						structure description.)
    (EDITE (GETPROP (SETQ GLLASTSTREDITED (OR STR GLLASTSTREDITED))
		    (QUOTE GLSTRUCTURE))
	   NIL STR (QUOTE GLISPOBJECTS)
	   (QUOTE GLIFSTRCHANGED))
    STR])

(GLERR
  [NLAMBDA ERREXP                               (* edited: 
						"23-SEP-82 11:52")
    (PRIN1 "Execution of GLISP error expression: ")
    (PRINT ERREXP)
    (ERROR])

(GLERROR
  [LAMBDA (FN MSGLST)                           (* edited: 
						"23-SEP-82 11:44")

          (* Print a GLISP error message.
	  The global stack EXPRSTACK is used to help the user 
	  locate the error.)


    (PROG NIL
          (PRIN1 "GLISP error detected by ")
          (PRIN1 FN)
          (PRIN1 " in function ")
          (PRINT FAULTFN)
          [MAPC MSGLST (FUNCTION (LAMBDA (X)
		    (PRIN1 X)
		    (SPACES 1]
          (TERPRI)
          (PRIN1 "in expression: ")
          (RESETFORM (PRINTLEVEL (QUOTE (2 . 20)))
		     (PRINTDEF (CAR EXPRSTACK)
			       15 T T)
		     (TERPRI)
		     (PRIN1 "within expr. ")
		     (PRINTDEF (CADR EXPRSTACK)
			       15 T NIL))
          (TERPRI)
          (COND
	    (GLBREAKONERROR (ERROR)))
          (RETURN (LIST (LIST (QUOTE GLERR)
			      (LIST (QUOTE QUOTE)
				    (CAR EXPRSTACK)))
			NIL])

(GLEXPENSIVE?
  [LAMBDA (EXPR)                                (* edited: 
						" 9-JUN-82 12:55")
                                                (* Test if EXPR is 
						expensive to compute.)
    (COND
      ((ATOM EXPR)
	NIL)
      ((NLISTP EXPR)
	(ERROR))
      ((FMEMB (CAR EXPR)
	      (QUOTE (CDR CDDR CDDDR CDDDDR CAR CAAR CADR CAADR CADDR 
			  CADDDR)))
	(GLEXPENSIVE? (CADR EXPR)))
      ((AND (EQ (CAR EXPR)
		(QUOTE PROG1))
	    (NULL (CDDR EXPR)))
	(GLEXPENSIVE? (CADR EXPR)))
      (T T])

(GLGENCODE
  [LAMBDA (X)                                   (* edited: 
						"19-OCT-82 15:19")

          (* Generate code of the form X.
	  The code generated by the compiler is transformed, 
	  if necessary, for the output dialect.)


    (SELECTQ GLLISPDIALECT
	     (INTERLISP (GLINTERLISPTRANSFM X))
	     (MACLISP (GLMACLISPTRANSFM X))
	     (FRANZLISP (GLFRANZLISPTRANSFM X))
	     (UCILISP (GLUCILISPTRANSFM X))
	     (PSL (GLPSLTRANSFM X))
	     (ERROR])

(GLGETASSOC
  [LAMBDA (KEY ALST)                            (* "GSN: " 
						"20-Mar-81 15:52")

          (* Get the value for the entry KEY from the a-list 
	  ALST. GETASSOC is used so that the corresponding 
	  PUTASSOC can be generated by GLPUTFN.)


    (PROG (TMP)
          (RETURN (AND (SETQ TMP (ASSOC KEY ALST))
		       (CDR TMP])

(GLGETD
  [LAMBDA (FN)                                  (* GSN "22-JUL-83 13:54"
)                                               (* Get the EXPR 
						definition of FN, if 
						available.)
    (COND
      ((AND (CCODEP FN)
	    (OR (EQ (UNSAVEDEF FN (QUOTE EXPR))
		    (QUOTE EXPR))
		(LOADDEF FN)))
	(PRIN1 FN)
	(SPACES 1)
	(PRIN1 "unsaved.")
	(TERPRI)))
    (GETD FN])

(GLGETDB
  [LAMBDA (FN)                                  (* edited: 
						"19-MAY-82 16:11")

          (* Get the function definition of FN, if easily 
	  available, so it can be examined.)


    (OR (AND (EQ (FNTYP FN)
		 (QUOTE EXPR))
	     (GETD FN))
	(GETPROP FN (QUOTE EXPR])

(GLGETDEF
  [LAMBDA (NAME TYPE)                           (* edited: 
						"30-OCT-81 12:20")
                                                (* Get the GLISP object 
						description for NAME for
						the file package.)
    (LIST (QUOTE GLDEFSTRQ)
	  (CONS NAME (GETPROP NAME (QUOTE GLSTRUCTURE])

(GLGETFROMUNIT
  [LAMBDA (UNITREC IND DES)                     (* edited: 
						"27-MAY-82 13:01")
                                                (* "GSN: " 
						" 2-Jun-81 13:46")

          (* Call the appropriate function to compile code to 
	  get the indicator (QUOTE IND') from the item whose 
	  description is DES, where DES describes a unit in a 
	  unit package whose record is UNITREC.)


    (PROG (TMP)
          (COND
	    ((SETQ TMP (ASSOC (QUOTE GET)
			      (CADDR UNITREC)))
	      (RETURN (APPLY* (CDR TMP)
			      IND DES)))
	    (T (RETURN])

(GLGETPAIRS
  [LAMBDA (EXPR)                                (* GSN "25-JUL-83 11:21"
)                                               (* edited: 
						"13-Aug-81 12:36")

          (* Get pairs of <field> = <value>, where the = and ,
	  are optional.)


    (PROG (PROP VAL PAIRLIST)
      A   (COND
	    ((NULL EXPR)
	      (RETURN (DREVERSE PAIRLIST)))
	    ([NOT (ATOM (SETQ PROP (pop EXPR]
	      (GLERROR (QUOTE GLGETPAIRS)
		       (LIST PROP "is not a legal property name.")))
	    ((EQ PROP (QUOTE ,))
	      (GO A)))
          (COND
	    ((MEMB (CAR EXPR)
		   (QUOTE (= _ :=)))
	      (pop EXPR)))
          (SETQ VAL (GLDOEXPRC NIL CONTEXT T))
          (SETQ PAIRLIST (CONS (CONS PROP VAL)
			       PAIRLIST))
          (GO A])

(GLGETSTR
  [LAMBDA (DES)                                 (* edited: 
						"23-DEC-81 12:52")
                                                (* "GSN: " 
						" 5-Oct-81 13:27")
                                                (* "GSN: " 
						"24-Apr-81 12:07")
                                                (* "GSN: " 
						" 7-Jan-81 16:38")
    (PROG (TYPE TMP)
          (RETURN (AND (SETQ TYPE (GLXTRTYPE DES))
		       (ATOM TYPE)
		       (SETQ TMP (GETPROP TYPE (QUOTE GLSTRUCTURE)))
		       (CAR TMP])

(GLGETSUPERS
  [LAMBDA (CLASS)                               (* edited: 
						"28-NOV-82 15:10")
                                                (* Get the superclasses 
						of CLASS.)
    (LISTGET (CDR (GETPROP CLASS (QUOTE GLSTRUCTURE)))
	     (QUOTE SUPERS])

(GLIFSTRCHANGED
  [LAMBDA (ATM EXPR TYPE FLG)                   (* GSN "28-JAN-83 11:30"
)                                               (* This function is 
						called by the editor if 
						a structure is changed.)
    (COND
      (FLG (GLSTRCHANGED ATM])

(GLINIT
  [LAMBDA NIL                                   (* "GSN: " 
						"12-Dec-83 11:37")
                                                (* Initialize things for
						GLISP)
    (PROG NIL
          (SETQ GLNOSPLITATOMS NIL)
          [SETQ GLSEPBITTBL
	    (MAKEBITTABLE (QUOTE (: _ + - ' = ~ < > * / , ^]
          (SETQ GLUNITPKGS NIL)
          (SETQ GLSEPMINUS NIL)
          (SETQ GLQUIETFLG NIL)
          (SETQ GLSEPATOM NIL)
          (SETQ GLSEPPTR 0)
          (SETQ GLBREAKONERROR NIL)
          (SETQ GLUSERSTRNAMES NIL)
          (SETQ GLTYPESUSED NIL)
          (SETQ GLLASTFNCOMPILED NIL)
          (SETQ GLLASTSTREDITED NIL)
          (SETQ GLCAUTIOUSFLG NIL)
          (SETQ GLGLSENDFLG NIL)
          [MAPC (SELECTQ GLLISPDIALECT
			 (INTERLISP (QUOTE (EQ EQP NEQ EQUAL MEMB AND 
					       OR NOT ZEROP NULL 
					       NUMBERP FIXP FLOATP ATOM 
					       LITATOM LISTP MINUSP 
					       STRINGP FASSOC ASSOC 
					       IGREATERP IGEQ ILESSP 
					       ILEQ IPLUS ITIMES 
					       IDIFFERENCE IQUOTIENT 
					       ADD1 SUB1 PLUS MINUS 
					       IMINUS TIMES SQRT EXPT 
					       DIFFERENCE QUOTIENT 
					       GREATERP GEQ LESSP LEQ 
					       CAR CDR CAAR CADR)))
			 (MACLISP (QUOTE (EQ EQP AND OR NOT EQUAL ZEROP 
					     NULL NULL NUMBERP FIXP 
					     FLOATP ATOM SYMBOLP PAIRP 
					     BIGP HUNKP ASCII PLUSP 
					     MINUSP ODDP GREATERP LESSP 
					     MEMQ ASSQ > = MAX MIN ABS 
					     FIX FLOAT REMAINDER GCD \ 
					     \\ ^ LOG EXP SIN COS ATAN 
					     BOOLE ASH LSH ROT < + * / 
					     - 1+ 1- ADD1 SUB1 PLUS 
					     MINUS TIMES SQRT EXPT 
					     DIFFERENCE QUOTIENT CAR 
					     CDR CAAR CADR)))
			 (FRANZLISP (QUOTE (EQ NEQ AND OR NOT EQUAL 
					       ATOM NULL DTPR SYMBOLP 
					       STRINGP HUNKP MEMQ > = < 
					       + * / - 1+ 1- ADD1 SUB1 
					       PLUS MINUS TIMES SQRT 
					       EXPT DIFFERENCE QUOTIENT 
					       ABS BOOLE COS EVENP EXP 
					       FIX FIXP FLOAT FLOATP 
					       GREATERP LESSP LOG LSH 
					       MAX MIN MINUSP MOD 
					       NUMBERP ODDP ONEP 
					       REMAINDER ROT SIN SQRT 
					       ZEROP CAR CDR CAAR CADR))
				    )
			 (UCILISP (QUOTE (EQ EQUAL AND OR NOT MEMQ > GE 
					     = LE < + * / - ADD1 SUB1 
					     PLUS MINUS TIMES 
					     DIFFERENCE QUOTIENT CAR 
					     CDR CAAR CADR)))
			 (PSL (QUOTE (EQ NE EQUAL AND OR NOT MEMQ ADD1 
					 SUB1 EQN ASSOC PLUS MINUS 
					 TIMES SQRT EXPT DIFFERENCE 
					 QUOTIENT GREATERP GEQ LESSP 
					 LEQ CAR CDR CAAR CADR)))
			 NIL)
		(FUNCTION (LAMBDA (X)
		    (PUTPROP X (QUOTE GLEVALWHENCONST)
			     T]
          [MAPC (SELECTQ GLLISPDIALECT
			 (INTERLISP (QUOTE (IGREATERP IGEQ ILESSP ILEQ 
						      IPLUS ITIMES 
						      IDIFFERENCE 
						      IQUOTIENT ADD1 
						      SUB1 PLUS MINUS 
						      IMINUS TIMES SQRT 
						      EXPT DIFFERENCE 
						      QUOTIENT GREATERP 
						      GEQ LESSP LEQ)))
			 (MACLISP (QUOTE (> = < + * / - 1+ 1- ADD1 SUB1 
					    PLUS MINUS IMINUS TIMES 
					    SQRT EXPT DIFFERENCE 
					    QUOTIENT GREATERP LESSP)))
			 (FRANZLISP (QUOTE (> = < + * / - 1+ 1- ADD1 
					      SUB1 PLUS MINUS IMINUS 
					      TIMES SQRT EXPT 
					      DIFFERENCE QUOTIENT 
					      GREATERP LESSP)))
			 (UCILISP (QUOTE (> GE = LE < + * / - ADD1 SUB1 
					    PLUS MINUS IMINUS TIMES 
					    SQRT EXPT DIFFERENCE 
					    QUOTIENT GREATERP LESSP)))
			 (PSL (QUOTE (ADD1 SUB1 EQN PLUS MINUS TIMES 
					   SQRT EXPT DIFFERENCE 
					   QUOTIENT GREATERP GEQ LESSP 
					   LEQ)))
			 NIL)
		(FUNCTION (LAMBDA (X)
		    (PUTPROP X (QUOTE GLARGSNUMBERP)
			     T]
          [GLDEFFNRESULTTYPES (QUOTE ((NUMBER (PLUS MINUS DIFFERENCE 
						    TIMES EXPT QUOTIENT 
						    REMAINDER MIN MAX 
						    ABS))
				       (INTEGER (LENGTH FIX ADD1 SUB1))
				       (REAL (SQRT LOG EXP SIN COS ATAN 
						   ARCSIN ARCCOS ARCTAN 
						   ARCTAN2 FLOAT))
				       (BOOLEAN (ATOM NULL EQUAL MINUSP 
						      ZEROP GREATERP 
						      LESSP NUMBERP 
						      FIXP FLOATP 
						      STRINGP ARRAYP EQ 
						      NOT NULL BOUNDP]
          (SELECTQ GLLISPDIALECT
		   [INTERLISP (GLDEFFNRESULTTYPES
				(QUOTE ((INTEGER (FLENGTH IPLUS NCHARS 
							  IMINUS 
							IDIFFERENCE 
							  ITIMES 
							  IQUOTIENT 
							 IREMAINDER 
							  IMIN IMAX 
							  LOGAND LOGOR 
							  LOGXOR LSH 
							  RSH LRSH LLSH 
							  GCD COUNT 
							  COUNTDOWN 
							  NARGS))
					 (BOOLEAN (LISTP IGREATERP 
							 SMALLP 
							 FGREATERP 
							 FLESSP GEQ LEQ 
							 LITATOM NLISTP 
							 NEQ ILESSP 
							 IGEQ ILEQ IEQP 
							 CCODEP SCODEP 
							 SUBRP EVERY 
							 EQUALALL 
							 EQLENGTH 
							 EQUALN EXPRP 
							 EQP))
					 (STRING (SUBSTRING CONCAT 
							   MKSTRING))
					 (REAL (RAND RANDSET]
		   [MACLISP (GLDEFFNRESULTTYPES
			      (QUOTE ((INTEGER (+ - * / 1+ 1- FLATC))
				       (BOOLEAN (> PAIRP HUNKP BIGP EQP
						   < = SYMBOLP))
				       (STRING SUBSTRING CONCAT]
		   [FRANZLISP (GLDEFFNRESULTTYPES
				(QUOTE ((INTEGER (+ - * / 1+ 1- FLATC))
					 (BOOLEAN (> BIGP HUNKP
						     < = DTPR SYMBOLP))
					 (STRING (SUBSTRING))	       |
					 (ATOM (CONCAT]		       |
		   [UCILISP (GLDEFFNRESULTTYPES
			      (QUOTE ((INTEGER (+ - * / ADD1 SUB1 
						  FLATSIZE FLATSIZEC))
				       (BOOLEAN (CONSP GE LE INUMP))
				       (STRING SUBSTRING CONCAT]
		   [PSL (GLDEFFNRESULTTYPES
			  (QUOTE ((INTEGER (FLATSIZE FLATSIZE2))
				   (BOOLEAN (EQN NE PAIRP IDP UNBOUNDP))
				   (STRING (SUBSTRING CONCAT]
		   NIL)
          (GLDEFFNRESULTTYPEFNS
	    (APPEND (QUOTE ((CONS . GLLISTRESULTTYPEFN)
			     (LIST . GLLISTRESULTTYPEFN)
			     (NCONC . GLLISTRESULTTYPEFN)))
		    (SELECTQ GLLISPDIALECT
			     [(INTERLISP UCILISP)
			       (QUOTE ((NTH . GLNTHRESULTTYPEFN]
			     [PSL (QUOTE ((PNTH . GLNTHRESULTTYPEFN]
			     [(MACLISP FRANZLISP)
			       (QUOTE ((NTHCDR . GLNTHRESULTTYPEFN]
			     NIL)))
          (SELECTQ GLLISPDIALECT
		   [INTERLISP (GLDEFSYSSTRQ (STRING STRING PROP
						    ((LENGTH NCHARS 
							     RESULT 
							    INTEGER))
						    MSG
						    ((+ CONCAT RESULT 
							STRING)))
					    (INTEGER INTEGER SUPERS
						     (NUMBER))
					    (ATOM ATOM PROP
						  ((PNAME MKSTRING 
							  RESULT STRING)
						   ))
					    (REAL REAL SUPERS (NUMBER]
		   [MACLISP (GLDEFSYSSTRQ (STRING STRING PROP
						  ((LENGTH FLATC RESULT 
							   INTEGER))
						  MSG
						  ((+ CONCAT RESULT 
						      STRING)))
					  (INTEGER INTEGER SUPERS
						   (NUMBER))
					  (ATOM ATOM PROP
						((PNAME (self)
							RESULT STRING)))
					  (REAL REAL SUPERS (NUMBER]
		   [FRANZLISP (GLDEFSYSSTRQ (STRING STRING PROP
						    ((LENGTH FLATC 
							     RESULT 
							    INTEGER))
						    MSG
						    ((+ CONCAT RESULT 
							STRING)))
					    (INTEGER INTEGER SUPERS
						     (NUMBER))
					    (ATOM ATOM PROP
						  ((PNAME GET_PNAME
							  RESULT STRING)
						   ))
					    (REAL REAL SUPERS (NUMBER]
		   [UCILISP (GLDEFSYSSTRQ (STRING STRING PROP
						  ((LENGTH STRLEN 
							   RESULT 
							   INTEGER))
						  MSG
						  ((+ CONCAT RESULT 
						      STRING)))
					  (INTEGER INTEGER SUPERS
						   (NUMBER))
					  (ATOM ATOM PROP
						((PNAME STR RESULT 
							STRING)))
					  (REAL REAL SUPERS (NUMBER]
		   [PSL (GLDEFSYSSTRQ
			  (STRING STRING PROP
				  ((LENGTH ((ADD1 (SIZE self)))
					   RESULT INTEGER))
				  MSG
				  ((+ CONCAT RESULT STRING)))
			  (INTEGER INTEGER SUPERS (NUMBER))
			  (ATOM ATOM PROP ((PNAME ID2STRING RESULT 
						  STRING)))
			  (REAL REAL SUPERS (NUMBER]
		   NIL])

(GLISPCONSTANTS
  [NLAMBDA ARGS                                 (* GSN "25-JUL-83 10:20"
)                                               (* Define compile-time 
						constants.)
    (PROG (TMP EXPR EXPRSTACK FAULTFN)
          (MAPC ARGS (FUNCTION (LAMBDA (ARG)
		    (PUTPROP (CAR ARG)
			     (QUOTE GLISPCONSTANTFLG)
			     T)
		    (PUTPROP (CAR ARG)
			     (QUOTE GLISPORIGCONSTVAL)
			     (CADR ARG))
		    [PUTPROP (CAR ARG)
			     (QUOTE GLISPCONSTANTVAL)
			     (PROGN (SETQ EXPR (LIST (CADR ARG)))
				    (SETQ TMP (GLDOEXPRC NIL NIL T))
				    (SET (CAR ARG)
					 (EVAL (CAR TMP]
		    (PUTPROP (CAR ARG)
			     (QUOTE GLISPCONSTANTTYPE)
			     (OR (CADDR ARG)
				 (CADR TMP])

(GLISPCP
  [LAMBDA NIL                                   (* GSN "25-JUL-83 10:00"
)                                               (* Test whether the 
						GLISP compiler is 
						present.)
    (COND
      ((GETD (QUOTE GLDOEXPR))
	T)
      (T NIL])

(GLISPGLOBALS
  [NLAMBDA ARGS                                 (* GSN " 1-JUN-83 17:31"
)                                               (* Define compile-time 
						constants.)
    (MAPC ARGS (FUNCTION (LAMBDA (ARG)
	      (SELECTQ GLLISPDIALECT
		       (PSL (GLOBAL (LIST (CAR ARG)))
			    (PUTPROP (CAR ARG)
				     (QUOTE GLISPGLOBALVAR)
				     T))
		       (PUTPROP (CAR ARG)
				(QUOTE GLISPGLOBALVAR)
				T))
	      (PUTPROP (CAR ARG)
		       (QUOTE GLISPGLOBALVARTYPE)
		       (CADR ARG])

(GLISPOBJECTS
  [NLAMBDA ARGS                                 (* GSN "10-FEB-83 11:51"
)                                               (* "GSN: " 
						" 7-Jan-81 10:48")

          (* Define named structure descriptions.
	  The descriptions are of the form 
	  (<name> <description>). Each description is put on 
	  the property list of <name> as GLSTRUCTURE)


    (MAPC ARGS (FUNCTION (LAMBDA (ARG)
	      (GLDEFSTR ARG NIL])

(GLLISTRESULTTYPEFN
  [LAMBDA (FN ARGTYPES)                         (* edited: 
						"12-NOV-82 10:53")
                                                (* Compute result types 
						for Lisp functions.)
    (PROG (ARG1 ARG2)
          (SETQ ARG1 (GLXTRTYPE (CAR ARGTYPES)))
          [COND
	    ((CDR ARGTYPES)
	      (SETQ ARG2 (GLXTRTYPE (CADR ARGTYPES]
          (RETURN
	    (SELECTQ
	      FN
	      (CONS (OR (AND (LISTP ARG2)
			     (COND
			       [(EQ (CAR ARG2)
				    (QUOTE LIST))
				 (CONS (QUOTE LIST)
				       (CONS ARG1 (CDR ARG2]
			       ((AND (EQ (CAR ARG2)
					 (QUOTE LISTOF))
				     (EQUAL ARG1 (CADR ARG2)))
				 ARG2)))
			(LIST FN ARGTYPES)))
	      [NCONC (COND
		       ((EQUAL ARG1 ARG2)
			 ARG1)
		       ((AND (LISTP ARG1)
			     (LISTP ARG2)
			     (EQ (CAR ARG1)
				 (QUOTE LISTOF))
			     (EQ (CAR ARG2)
				 (QUOTE LIST))
			     (NULL (CDDR ARG2))
			     (EQUAL (CADR ARG1)
				    (CADR ARG2)))
			 ARG1)
		       (T (OR ARG1 ARG2]
	      [LIST (CONS FN (MAPCAR ARGTYPES (FUNCTION GLXTRTYPE]
	      (ERROR])

(GLLISTSTRFN
  [LAMBDA (IND DES DESLIST)                     (* GSN "11-JAN-83 14:05"
)

          (* Create a function call to retrieve the field IND 
	  from a LIST structure.)


    (PROG (TMP N FNLST)
          (SETQ N 1)
          [SETQ FNLST (QUOTE ((CAR *GL*)
			       (CADR *GL*)
			       (CADDR *GL*)
			       (CADDDR *GL*]
          [COND
	    ((EQ (CAR DES)
		 (QUOTE LISTOBJECT))
	      (SETQ N (ADD1 N))
	      (SETQ FNLST (CDR FNLST]
      C   (pop DES)
          [COND
	    ((NULL DES)
	      (RETURN))
	    ((NLISTP (CAR DES)))
	    ((SETQ TMP (GLSTRFN IND (CAR DES)
				DESLIST))
	      (RETURN
		(GLSTRVAL TMP
			  (COND
			    (FNLST (COPY (CAR FNLST)))
			    (T (LIST (QUOTE CAR)
				     (GLGENCODE (LIST (QUOTE NTH)
						      (QUOTE *GL*)
						      N]
          (SETQ N (ADD1 N))
          (AND FNLST (SETQ FNLST (CDR FNLST)))
          (GO C])

(GLMKATOM
  [LAMBDA (NAME)                                (* edited: 
						"11-NOV-82 11:54")
                                                (* Make a variable name 
						for GLCOMP functions.)
    (PROG (N NEWATOM)
      LP  [PUTPROP NAME (QUOTE GLISPATOMNUMBER)
		   (SETQ N (ADD1 (OR (GETPROP NAME (QUOTE 
						    GLISPATOMNUMBER))
				     0]
          [SETQ NEWATOM (PACK (APPEND (UNPACK NAME)
				      (UNPACK N]

          (* If an atom with this name has something on its 
	  proplist, try again.)


          (COND
	    ((GETPROPLIST NEWATOM)
	      (GO LP))
	    (T (RETURN NEWATOM])

(GLMKRECORD
  [LAMBDA (N NAME)                              (* GSN "25-JUL-83 14:09"
)                                               (* Make a record with a 
						given length or 
						datatype.)
    (SELECTQ GLLISPDIALECT
	     (PSL (MKVECT (SUB1 N)))
	     ((MACLISP FRANZLISP)
	       (MAKHUNK N))
	     [INTERLISP (COND
			  (NAME (EVAL (LIST (QUOTE create)
					    NAME)))
			  (T (COND
			       ((LEQ N 0)
				 NIL)
			       (T (CONS NIL (GLMKRECORD (SUB1 N)
							NAME]
	     (COND
	       ((LEQ N 0)
		 NIL)
	       (T (CONS NIL (GLMKRECORD (SUB1 N)
					NAME])

(GLMKSTR
  [LAMBDA (STR NAME PAIRS PREVLST)              (* edited: 
						" 3-Dec-83 13:26")

          (* Make a structure at runtime.
	  STR is the structure description, and PAIRS is an 
	  ALIST of field names and values.
	  The values are unevaluated, in GLISP code form, 
	  i.e., a list of code and type.)


    (PROG (TMP NEW N)
          (RETURN
	    (COND
	      [(ATOM STR)
		(COND
		  ((OR (NULL STR)
		       (FMEMB STR GLBASICTYPES))
		    (RETURN (GLDEFAULTVALUE STR)))
		  ((FMEMB STR PREVLST)
		    (RETURN))
		  (T (RETURN (GLMKSTR (GLGETSTR STR)
				      STR NIL (CONS STR PREVLST]
	      ((NLISTP STR)
		(GLERROR (QUOTE GLMKSTR)
			 (LIST "Illegal structure specification" STR)))
	      (T
		(SELECTQ
		  (CAR STR)
		  (CONS (CONS (GLMKSTR (CADR STR)
				       NIL PAIRS PREVLST)
			      (GLMKSTR (CADDR STR)
				       NIL PAIRS PREVLST)))
		  [LIST (MAPCAR (CDR STR)
				(FUNCTION (LAMBDA (X)
				    (GLMKSTR X NIL PAIRS PREVLST]
		  (LISTOF NIL)
		  [ALIST
		    (MAPCONC
		      (CDR STR)
		      (FUNCTION (LAMBDA (X)
			  (COND
			    [(ASSOC (CAR X)
				    PAIRS)
			      (LIST
				(CONS
				  (CAR X)
				  (EVAL (CADR (ASSOC (CAR X)
						     PAIRS]
			    ((COND
				((SETQ TMP (GLMKSTR (CADR X)
						    NIL PAIRS PREVLST))
				  (LIST (CONS (CAR X)
					      TMP]
		  [PROPLIST
		    (MAPCONC
		      (CDR STR)
		      (FUNCTION (LAMBDA (X)
			  (COND
			    [(ASSOC (CAR X)
				    PAIRS)
			      (LIST (CAR X)
				    (EVAL (CADR (ASSOC (CAR X)
						       PAIRS]
			    ((COND
				((SETQ TMP (GLMKSTR (CADR X)
						    NIL PAIRS PREVLST))
				  (LIST (CAR X)
					TMP]
		  [TRANSPARENT (COND
				 ((FMEMB (CADR STR)
					 PREVLST)
				   NIL)
				 (T (GLMKSTR (GLGETSTR (CADR STR))
					     NIL PAIRS
					     (CONS (CADR STR)
						   PREVLST]
		  (ATOM [SETQ NEW (GLMKATOM (OR NAME (QUOTE GLATOM]
			[MAPC (CDR STR)
			      (FUNCTION (LAMBDA (Y)
				  (COND
				    [(EQ (CAR Y)
					 (QUOTE PROPLIST))
				      (MAPC (CDR Y)
					    (FUNCTION (LAMBDA (X)
						(PUTPROP NEW
							 (CAR X)
							 (GLMKSTR
							   X NIL PAIRS 
							   PREVLST]
				    ((EQ (CAR Y)
					 (QUOTE BINDING))
				      (SET NEW (GLMKSTR (CADR Y)
							NIL PAIRS 
							PREVLST]
			NEW)
		  (ATOMOBJECT [SETQ NEW (GLMKATOM (OR NAME
						      (QUOTE GLATOM]
			      (PUTPROP NEW (QUOTE CLASS)
				       NAME)
			      [MAPC (CDR STR)
				    (FUNCTION (LAMBDA (X)
					(PUTPROP NEW (CAR X)
						 (GLMKSTR X NIL PAIRS 
							  PREVLST]
			      NEW)
		  [LISTOBJECT (CONS NAME
				    (MAPCAR (CDR STR)
					    (FUNCTION (LAMBDA (X)
						(GLMKSTR X NIL PAIRS 
							 PREVLST]
		  ((OBJECT RECORD)
		    [SETQ NEW (GLMKRECORD
			[COND
			  [(EQ (CAR STR)
			       (QUOTE OBJECT))
			    (ADD1 (LENGTH (CDR STR]
			  ((ATOM (CADR STR))
			    (LENGTH (CDDR STR)))
			  (T (LENGTH (CDR STR]
			(AND (ATOM (CADR STR))
			     (CADR STR]
		    (SETQ N 0)
		    [COND
		      ((EQ (CAR STR)
			   (QUOTE OBJECT))
			[SELECTQ GLLISPDIALECT
				 [INTERLISP (COND
					      ((LISTP NEW)
						(RPLACA NEW NAME]
				 (PSL (PUTV NEW 0 NAME))
				 ((MACLISP FRANZLISP)
				   (RPLACX 0 NEW NAME))
				 (COND
				   ((LISTP NEW)
				     (RPLACA NEW NAME]
			(SETQ N (ADD1 N]
		    [MAPC
		      (CDR STR)
		      (FUNCTION (LAMBDA (X)
			  (SETQ TMP (GLMKSTR X NIL PAIRS PREVLST))
			  [SELECTQ
			    GLLISPDIALECT
			    [INTERLISP (COND
					 ((LISTP NEW)
					   (RPLACA (NTH NEW
							(ADD1 N))
						   TMP]
			    (PSL (PUTV NEW N TMP))
			    ((MACLISP FRANZLISP)
			      (RPLACX N NEW TMP))
			    (COND
			      ((LISTP NEW)
				(RPLACA (NTH NEW (ADD1 N))
					TMP]
			  (SETQ N (ADD1 N]
		    NEW)
		  (COND
		    ((SETQ TMP (ASSOC (CAR STR)
				      PAIRS))
		      (EVAL (CADR TMP)))
		    ((GLMKSTR (CADR STR)
			      NIL PAIRS PREVLST])

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

(GLNOTICETYPE
  [LAMBDA (TYPE)                                (* GSN "28-JAN-83 09:39"
)                                               (* Add TYPE to the 
						global variable 
						GLTYPESUSED if not 
						already there.)
    (COND
      ((NOT (FMEMB TYPE GLTYPESUSED))
	(SETQ GLTYPESUSED (CONS TYPE GLTYPESUSED])

(GLNTHRESULTTYPEFN
  [LAMBDA (FN ARGTYPES)                         (* edited: 
						" 3-Dec-83 13:49")
                                                (* Compute the result 
						type for the function 
						NTH or NTHCDR.)
    (PROG (TMP TYPE)
          (SETQ TYPE (SELECTQ GLLISPDIALECT
			      ((INTERLISP PSL UCILISP)
				(CAR ARGTYPES))
			      ((MACLISP FRANZLISP)
				(CADR ARGTYPES))
			      NIL))
          (RETURN (COND
		    ((AND (LISTP (SETQ TMP (GLXTRTYPE TYPE)))
			  (EQ (CAR TMP)
			      (QUOTE LISTOF)))
		      TYPE)
		    (T NIL])

(GLOKSTR?
  [LAMBDA (STR)                                 (* "GSN: " 
						"22-Dec-83 10:44")
                                                (* Check a structure 
						description for 
						legality.)
    (COND
      ((NULL STR)
	NIL)
      ((ATOM STR)
	T)
      [(AND (LISTP STR)
	    (ATOM (CAR STR)))
	(SELECTQ (CAR STR)
		 [(A AN a an An)
		   (COND
		     ((CDDR STR)
		       NIL)
		     ((OR (GLGETSTR (CADR STR))
			  (GLUNIT? (CADR STR))
			  (COND
			    (GLCAUTIOUSFLG (PRIN1 "The structure ")
					   (PRIN1 (CADR STR))
					   (PRIN1 
			    " is not currently defined.  Accepted.")
					   (TERPRI)
					   T)
			    (T T]
		 [CONS (AND (CDR STR)
			    (CDDR STR)
			    (NULL (CDDDR STR))
			    (GLOKSTR? (CADR STR))
			    (GLOKSTR? (CADDR STR]
		 [(LIST OBJECT ATOMOBJECT LISTOBJECT)
		   (AND (CDR STR)
			(EVERY (CDR STR)
			       (FUNCTION GLOKSTR?]
		 [RECORD (COND
			   ((AND (CDR STR)
				 (ATOM (CADR STR)))
			     (pop STR)))
			 (AND (CDR STR)
			      (EVERY (CDR STR)
				     (FUNCTION (LAMBDA (X)
					 (AND (ATOM (CAR X))
					      (GLOKSTR? (CADR X]
		 [LISTOF (AND (CDR STR)
			      (NULL (CDDR STR))
			      (GLOKSTR? (CADR STR]
		 [(ALIST PROPLIST)
		   (AND (CDR STR)
			(EVERY (CDR STR)
			       (FUNCTION (LAMBDA (X)
				   (AND (ATOM (CAR X))
					(GLOKSTR? (CADR X]
		 (ATOM (GLATMSTR? STR))
		 (TYPEOF T)
		 (COND
		   ((AND (CDR STR)
			 (NULL (CDDR STR)))
		     (GLOKSTR? (CADR STR)))
		   ((ASSOC (CAR STR)
			   GLUSERSTRNAMES))
		   [(AND (BOUNDP (QUOTE GEVUSERTYPENAMES))	       |
			 (FMEMB (CAR STR)
				GEVUSERTYPENAMES))
		     (AND (CDR STR)
			  (EVERY (CDR STR)
				 (FUNCTION (LAMBDA (X)
				     (AND (ATOM (CAR X))
					  (GLOKSTR? (CADR X]
		   (T NIL]
      (T NIL])

(GLP
  [LAMBDA (FUN)                                 (* edited: 
						"29-APR-82 09:42")
                                                (* Prettyprint the 
						compiled version of a 
						function)
    (PROG (FN)
          (SETQ FN (OR FUN GLLASTFNCOMPILED))
          (PRIN1 "GLRESULTTYPE: ")
          (PRINT (GETPROP FN (QUOTE GLRESULTTYPE)))
          (PRINTDEF (GETPROP FN (QUOTE GLCOMPILED)))
          (TERPRI)
          (RETURN FN])

(GLPROPSTRFN
  [LAMBDA (IND DES DESLIST FLG)                 (* edited: 
						"14-MAR-83 17:12")

          (* Create a function call to retrieve the field IND 
	  from a property-list type structure.
	  FLG is true if a PROPLIST is inside an ATOM 
	  structure.)


    (PROG (DESIND TMP RECNAME N)                (* Handle a PROPLIST by 
						looking inside each 
						property for IND.)
          [COND
	    ((AND (EQ (SETQ DESIND (pop DES))
		      (QUOTE RECORD))
		  (ATOM (CAR DES)))
	      (SETQ RECNAME (pop DES]
          (SETQ N 0)
      P   (COND
	    ((NULL DES)
	      (RETURN))
	    ((AND (LISTP (CAR DES))
		  (ATOM (CAAR DES))
		  (CDAR DES)
		  (SETQ TMP (GLSTRFN IND (CAR DES)
				     DESLIST)))
	      (SETQ TMP
		(GLSTRVAL
		  TMP
		  (SELECTQ
		    DESIND
		    (ALIST (LIST (QUOTE GLGETASSOC)
				 (KWOTE (CAAR DES))
				 (QUOTE *GL*)))
		    [(RECORD OBJECT)
		      [COND
			((EQ DESIND (QUOTE OBJECT))
			  (SETQ N (ADD1 N]
		      (SELECTQ
			GLLISPDIALECT
			[INTERLISP
			  (COND
			    (RECNAME (LIST (QUOTE fetch)
					   (LIST RECNAME (CAAR DES))
					   (QUOTE of)
					   (QUOTE *GL*)))
			    (T (LIST (QUOTE CAR)
				     (GLGENCODE (LIST (QUOTE NTH)
						      (QUOTE *GL*)
						      (ADD1 N]
			((MACLISP FRANZLISP)
			  (LIST (QUOTE CXR)
				N
				(QUOTE *GL*)))
			(PSL (LIST (QUOTE GetV)
				   (QUOTE *GL*)
				   N))
			(LIST (QUOTE CAR)
			      (GLGENCODE (LIST (QUOTE NTH)
					       (QUOTE *GL*)
					       (ADD1 N]
		    [(PROPLIST ATOMOBJECT)
		      (GLGENCODE (LIST (COND
					 ((OR FLG (EQ DESIND
						      (QUOTE ATOMOBJECT)
						      ))
					   (QUOTE GETPROP))
					 (T (QUOTE LISTGET)))
				       (QUOTE *GL*)
				       (KWOTE (CAAR DES]
		    NIL)))
	      (RETURN TMP))
	    (T (pop DES)
	       (SETQ N (ADD1 N))
	       (GO P])

(GLPUTARITH
  [LAMBDA (LHS RHS)                             (* GSN "22-JAN-83 14:44"
)

          (* Process a "store" into a value which is computed 
	  by an arithmetic expression.)


    (PROG (LHSC OP TMP NEWLHS NEWRHS)
          (SETQ LHSC (CAR LHS))
          (SETQ OP (CAR LHSC))
          (COND
	    ([NOT (SETQ TMP (FASSOC OP (QUOTE ((PLUS DIFFERENCE)
						(MINUS MINUS)
						(DIFFERENCE PLUS)
						(TIMES QUOTIENT)
						(QUOTIENT TIMES)
						(IPLUS IDIFFERENCE)
						(IMINUS IMINUS)
						(IDIFFERENCE IPLUS)
						(ITIMES IQUOTIENT)
						(IQUOTIENT ITIMES)
						(ADD1 SUB1)
						(SUB1 ADD1)
						(EXPT SQRT)
						(SQRT EXPT]
	      (RETURN)))
          (SETQ NEWLHS (CADR LHSC))
          (SELECTQ OP
		   [(ADD1 SUB1 MINUS IMINUS)
		     (SETQ NEWRHS (LIST (CADR TMP)
					(CAR RHS]
		   [(PLUS DIFFERENCE TIMES QUOTIENT IPLUS IDIFFERENCE 
			  ITIMES IQUOTIENT)
		     (COND
		       [(NUMBERP (CADDR LHSC))
			 (SETQ NEWRHS (LIST (CADR TMP)
					    (CAR RHS)
					    (CADDR LHSC]
		       ((NUMBERP (CADR LHSC))
			 (SETQ NEWLHS (CADDR LHSC))
			 (SELECTQ OP
				  [(DIFFERENCE IDIFFERENCE QUOTIENT 
					       IQUOTIENT)
				    (SETQ NEWRHS (LIST OP (CADR LHSC)
						       (CAR RHS]
				  (PROGN (SETQ NEWRHS
					   (LIST (CADR TMP)
						 (CAR RHS)
						 (CADR LHSC]
		   [EXPT (COND
			   ((EQUAL (CADDR LHSC)
				   2)
			     (SETQ NEWRHS (LIST (CADR TMP)
						(CAR RHS]
		   (SQRT (SETQ NEWRHS (LIST (CADR TMP)
					    (CAR RHS)
					    2)))
		   NIL)
          (RETURN (AND NEWRHS (GLPUTFN (LIST NEWLHS (CADR LHS))
				       (LIST NEWRHS (CADR RHS))
				       NIL])

(GLPUTFN
  [LAMBDA (LHS RHS OPTFLG)                      (* GSN "25-JUL-83 10:57"
)                                               (* edited: 
						" 2-Jun-81 14:16")
                                                (* edited: 
						"24-Apr-81 12:05")
                                                (* edited: 
						"21-Apr-81 11:28")

          (* Create code to put the right-hand side datum RHS 
	  into the left-hand side, whose access function and 
	  type are given by LHS.)


    (PROG (LHSD LNAME TMP RESULT TMPVAR GETFN PUTFN REST)
          (SETQ LHSD (CAR LHS))
          [COND
	    ((ATOM LHSD)
	      (RETURN (OR (AND (GLISPCP)
			       (GLDOMSG LHS (QUOTE _)
					(LIST RHS)))
			  (GLUSERSTROP LHS (QUOTE _)
				       RHS)
			  (AND (NULL (CADR LHS))
			       (CADR RHS)
			       (GLUSERSTROP (LIST (CAR LHS)
						  (CADR RHS))
					    (QUOTE _)
					    RHS))
			  (AND (GLISPCP)
			       (GLDOVARSETQ LHSD RHS]
          (SETQ LNAME (CAR LHSD))
          [COND
	    [(SETQ TMP (GLANYCARCDR? LNAME))
	      (SETQ TMP (DREVERSE TMP))
	      [SETQ PUTFN (COND
		  ((EQ (CAR TMP)
		       (QUOTE A))
		    (QUOTE RPLACA))
		  (T (QUOTE RPLACD]
	      [SETQ GETFN (COND
		  ((EQ (CAR TMP)
		       (QUOTE A))
		    (QUOTE CAR))
		  (T (QUOTE CDR]
	      [SETQ REST (COND
		  ((CDR TMP)
		    (LIST (PACK (NCONC1 (CONS (QUOTE C)
					      (CDR TMP))
					(QUOTE R)))
			  (CADR LHSD)))
		  (T (CADR LHSD]
	      (SETQ RESULT
		(COND
		  [(AND OPTFLG (GLEXPENSIVE? REST))
		    (LIST (QUOTE PROG)
			  (LIST (LIST (SETQ TMPVAR (GLMKVAR))
				      REST))
			  (LIST (QUOTE RETURN)
				(LIST GETFN (LIST PUTFN TMPVAR
						  (SUBST TMPVAR REST
							 (CAR RHS]
		  (T (LIST GETFN (LIST PUTFN REST (CAR RHS]
	    [[SETQ TMP (ASSOC LNAME (QUOTE ((GetV . PutV)
					     (IGetV . IPutV)
					     (GET . PUTPROP)
					     (GETPROP . PUTPROP)
					     (LISTGET . LISTPUT]
	      (SETQ RESULT (LIST (CDR TMP)
				 (CADR LHSD)
				 (CADDR LHSD)
				 (CAR RHS]
	    [(EQ LNAME (QUOTE CXR))
	      (SETQ RESULT (LIST (QUOTE CXR)
				 (CADR LHSD)
				 (LIST (QUOTE RPLACX)
				       (CADR LHSD)
				       (CADDR LHSD)
				       (CAR RHS]
	    [(EQ LNAME (QUOTE GLGETASSOC))
	      (SETQ RESULT (LIST (QUOTE PUTASSOC)
				 (CADR LHSD)
				 (CAR RHS)
				 (CADDR LHSD]
	    [(EQ LNAME (QUOTE EVAL))
	      (SETQ RESULT (LIST (QUOTE SET)
				 (CADR LHSD)
				 (CAR RHS]
	    [(EQ LNAME (QUOTE fetch))
	      (SETQ RESULT (LIST (QUOTE replace)
				 (CADR LHSD)
				 (QUOTE of)
				 (CADDDR LHSD)
				 (QUOTE with)
				 (CAR RHS]
	    ((SETQ TMP (GLUNITOP LHS RHS (QUOTE PUT)))
	      (RETURN TMP))
	    ([AND (GLISPCP)
		  (SETQ TMP (GLDOMSG LHS (QUOTE _)
				     (LIST RHS]
	      (RETURN TMP))
	    ((SETQ TMP (GLUSERSTROP LHS (QUOTE _)
				    RHS))
	      (RETURN TMP))
	    ((SETQ TMP (GLPUTARITH LHS RHS))
	      (RETURN TMP))
	    (T (RETURN (GLERROR (QUOTE GLPUTFN)
				(LIST "Illegal assignment.  LHS =" LHS 
				      "RHS ="
				      RHS]
      X   (RETURN (LIST (GLGENCODE RESULT)
			(OR (CADR LHS)
			    (CADR RHS])

(GLRESULTTYPE
  [LAMBDA (ATM ARGTYPES)                        (* edited: 
						"26-MAY-82 16:14")
                                                (* "GSN: " 
						" 1-Jun-81 16:03")

          (* Get the result type for a function which has a 
	  GLAMBDA definition. ATM is the function name.)


    (PROG (TYPE FNDEF STR TMP)                  (* See if this function 
						has a known result 
						type.)
          (COND
	    ((SETQ TYPE (GETPROP ATM (QUOTE GLRESULTTYPE)))
	      (RETURN TYPE)))

          (* If there exists a function to compute the result 
	  type, let it do so.)


          [COND
	    ((SETQ TMP (GETPROP ATM (QUOTE GLRESULTTYPEFN)))
	      (RETURN (APPLY* TMP ATM ARGTYPES)))
	    ((SETQ TMP (GLANYCARCDR? ATM))
	      (RETURN (GLCARCDRRESULTTYPE TMP (CAR ARGTYPES]
          (SETQ FNDEF (GLGETDB ATM))
          (COND
	    ([OR (NLISTP FNDEF)
		 (NOT (FMEMB (CAR FNDEF)
			     (QUOTE (LAMBDA GLAMBDA]
	      (RETURN)))
          (SETQ FNDEF (CDDR FNDEF))
      A   (COND
	    ((OR (NULL FNDEF)
		 (NLISTP (CAR FNDEF)))
	      (RETURN))
	    ([OR (AND (EQ GLLISPDIALECT (QUOTE INTERLISP))
		      (EQ (CAAR FNDEF)
			  (QUOTE *)))
		 (MEMB (CAAR FNDEF)
		       (QUOTE (GLOBAL Global global]
	      (pop FNDEF)
	      (GO A))
	    ([AND (MEMB (CAAR FNDEF)
			(QUOTE (RESULT Result result)))
		  (GLOKSTR? (SETQ STR (CADAR FNDEF]
	      (RETURN STR))
	    (T (RETURN])

(GLSEND
  [NLAMBDA GLISPSENDARGS                        (* GSN " 9-FEB-83 16:46"
)
    (GLSENDB (EVAL (CAR GLISPSENDARGS))
	     NIL
	     (CADR GLISPSENDARGS)
	     (QUOTE MSG)
	     (MAPCAR (CDDR GLISPSENDARGS)
		     (FUNCTION EVAL])

(GLSENDB
  [LAMBDA (OBJ CLASS SELECTOR PROPTYPE ARGS)    (* GSN " 1-JUN-83 17:43"
)                                               (* Send a runtime 
						message to OBJ.)
    (DECLARE (SPECVARS *GL* *GLVAL*))
    (PROG (RESULT ARGLIST FNCODE PUTCODE *GL* *GLVAL* SEL
		  (FAULTFN (QUOTE GLSENDB))
		  SV TMP)
          [COND
	    (CLASS)
	    ((SETQ CLASS (GLCLASS OBJ)))
	    (T (ERROR (LIST "Object" OBJ "has no Class."]
          (SETQ ARGLIST (CONS OBJ ARGS))
          (COND
	    ((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST 
					    PROPTYPE))
		  (QUOTE GLSENDFAILURE))
	      (RETURN RESULT))
	    ([AND (EQ SELECTOR (QUOTE CLASS))
		  (MEMB PROPTYPE (QUOTE (PROP MSG]
	      (RETURN CLASS))
	    ((NEQ PROPTYPE (QUOTE MSG))
	      (GO ERR))
	    [(AND ARGS (NULL (CDR ARGS))
		  (EQ (NTHCHAR SELECTOR -1)
		      (QUOTE :))
		  (SETQ SEL (SUBATOM SELECTOR 1 -2))
		  [SETQ FNCODE (OR (GLCOMPPROP CLASS SEL (QUOTE STR))
				   (GLCOMPPROP CLASS SEL (QUOTE PROP]
		  (SETQ PUTCODE
		    (PROGN (SELECTQ GLLISPDIALECT
				    (UCI (COND
					   ((BOUNDP (QUOTE 
						     MACROEXPANSION))
					     (SETQ SV MACROEXPANSION)
					     (SETQ MACROEXPANSION NIL))
					   (T T)))
				    T)
			   (SETQ TMP (GLPUTFN
			       (LIST (SUBST (QUOTE *GL*)
					    (CAADR FNCODE)
					    (CADDR FNCODE))
				     NIL)
			       (LIST (QUOTE *GLVAL*)
				     NIL)
			       NIL))
			   (SELECTQ GLLISPDIALECT
				    [UCI (COND
					   ((BOUNDP (QUOTE 
						     MACROEXPANSION))
					     (SETQ MACROEXPANSION SV]
				    T)
			   TMP)))
	      (SETQ *GLVAL*(CAR ARGS))
	      (SETQ *GL* OBJ)
	      (RETURN (EVAL (CAR PUTCODE]
	    (ARGS (GO ERR))
	    ((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
					    (QUOTE STR)))
		  (QUOTE GLSENDFAILURE))
	      (RETURN RESULT))
	    ((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
					    (QUOTE PROP)))
		  (QUOTE GLSENDFAILURE))
	      (RETURN RESULT))
	    ((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
					    (QUOTE ADJ)))
		  (QUOTE GLSENDFAILURE))
	      (RETURN RESULT))
	    ((NEQ (SETQ RESULT (GLCLASSSEND CLASS SELECTOR ARGLIST
					    (QUOTE ISA)))
		  (QUOTE GLSENDFAILURE))
	      (RETURN RESULT)))
      ERR (ERROR (LIST "Message" SELECTOR "to object" OBJ "of class" 
		       CLASS "not understood."])

(GLSENDC
  [NLAMBDA GLISPSENDARGS                        (* GSN " 9-FEB-83 16:48"
)
    (GLSENDB (EVAL (CAR GLISPSENDARGS))
	     (CADR GLISPSENDARGS)
	     (CADDR GLISPSENDARGS)
	     (QUOTE MSG)
	     (MAPCAR (CDDDR GLISPSENDARGS)
		     (FUNCTION EVAL])

(GLSENDPROP
  [NLAMBDA GLISPSENDPROPARGS                    (* GSN " 9-FEB-83 16:46"
)
    (GLSENDB (EVAL (CAR GLISPSENDPROPARGS))
	     NIL
	     (CADR GLISPSENDPROPARGS)
	     (CADDR GLISPSENDPROPARGS)
	     (MAPCAR (CDDDR GLISPSENDPROPARGS)
		     (FUNCTION EVAL])

(GLSENDPROPC
  [NLAMBDA GLISPSENDPROPARGS                    (* GSN " 9-FEB-83 16:48"
)
    (GLSENDB (EVAL (CAR GLISPSENDPROPARGS))
	     (CADR GLISPSENDPROPARGS)
	     (CADDR GLISPSENDPROPARGS)
	     (CADDDR GLISPSENDPROPARGS)
	     (MAPCAR (CDDDDR GLISPSENDPROPARGS)
		     (FUNCTION EVAL])

(GLSTRCHANGED
  [LAMBDA (STR)                                 (* GSN "25-JUL-83 10:31"
)

          (* This function is called when the structure STR 
	  has been changed. It uncompiles code which depends 
	  on STR.)


    (PROG (FNS)
          (COND
	    ((NOT (GETPROP STR (QUOTE GLSTRUCTURE)))
	      (RETURN))
	    ((GETPROP STR (QUOTE GLPROPFNS))
	      (PUTPROP STR (QUOTE GLPROPFNS)
		       NIL)))
          [SELECTQ GLLISPDIALECT
		   [INTERLISP (MARKASCHANGED STR (QUOTE GLISPOBJECTS)
					     NIL)
			      (SETQ FNS (GETPROP STR (QUOTE GLFNSUSEDIN]
		   (SETQ FNS (GETPROP STR (QUOTE GLFNSUSEDIN]
          (PUTPROP STR (QUOTE GLFNSUSEDIN)
		   NIL)
          (COND
	    ((GLISPCP)
	      (MAPC FNS (FUNCTION GLUNCOMPILE])

(GLSTRFN
  [LAMBDA (IND DES DESLIST)                     (* GSN "28-JAN-83 10:19"
)

          (* Create a function call to retrieve the field IND 
	  from a structure described by the structure 
	  description DES. The value is NIL if failure, 
	  (NIL DESCR) if DES equals IND, or 
	  (FNSTR DESCR) if IND can be gotten from within DES.
	  In the latter case, FNSTR is a function to get the 
	  IND from the atom *GL*. GLSTRFN only does retrieval 
	  from a structure, and does not get properties of an 
	  object unless they are part of a TRANSPARENT 
	  substructure. DESLIST is a list of structure 
	  descriptions which have been tried already;
	  this prevents a compiler loop in case the user 
	  specifies circular TRANSPARENT structures.)


    (PROG (DESIND TMP STR UNITREC)              (* If this structure has
						already been tried, quit
						to avoid a loop.)
          (COND
	    ((FMEMB DES DESLIST)
	      (RETURN)))
          (SETQ DESLIST (CONS DES DESLIST))
          [COND
	    ((OR (NULL DES)
		 (NULL IND))
	      (RETURN))
	    [[OR (ATOM DES)
		 (AND (LISTP DES)
		      (ATOM (CADR DES))
		      (GL-A-AN? (CAR DES))
		      (SETQ DES (CADR DES]
	      (RETURN (COND
			((SETQ STR (GLGETSTR DES))
			  (GLNOTICETYPE DES)
			  (GLSTRFN IND STR DESLIST))
			((SETQ UNITREC (GLUNIT? DES))
			  (GLGETFROMUNIT UNITREC IND DES))
			((EQ IND DES)
			  (LIST NIL (CADR DES)))
			(T NIL]
	    ((NLISTP DES)
	      (GLERROR (QUOTE GLSTRFN)
		       (LIST "Bad structure specification" DES]
          (SETQ DESIND (CAR DES))
          [COND
	    ((OR (EQ IND DES)
		 (EQ DESIND IND))
	      (RETURN (LIST NIL (CADR DES]
          (RETURN (SELECTQ DESIND
			   [CONS (OR (GLSTRVALB IND (CADR DES)
						(QUOTE (CAR *GL*)))
				     (GLSTRVALB IND (CADDR DES)
						(QUOTE (CDR *GL*]
			   ((LIST LISTOBJECT)
			     (GLLISTSTRFN IND DES DESLIST))
			   ((PROPLIST ALIST RECORD ATOMOBJECT OBJECT)
			     (GLPROPSTRFN IND DES DESLIST NIL))
			   (ATOM (GLATOMSTRFN IND DES DESLIST))
			   (TRANSPARENT (GLSTRFN IND (CADR DES)
						 DESLIST))
			   (COND
			     ((AND (SETQ TMP (ASSOC DESIND 
						    GLUSERSTRNAMES))
				   (CADR TMP))
			       (APPLY* (CADR TMP)
				       IND DES DESLIST))
			     ([OR (NULL (CDR DES))
				  (ATOM (CADR DES))
				  (AND (LISTP (CADR DES))
				       (GL-A-AN? (CAADR DES]
			       NIL)
			     (T (GLSTRFN IND (CADR DES)
					 DESLIST])

(GLSTRPROP
  [LAMBDA (STR GLPROP PROP ARGS)                (* GSN "16-MAR-83 10:49"
)

          (* If STR is a structured object, i.e., either a 
	  declared GLISP structure or a Class of Units, get 
	  the property PROP from the GLISP class of properties
	  GLPROP.)


    (PROG (STRB UNITREC GLPROPS PROPL TMP SUPERS)
          (OR (ATOM (SETQ STRB (GLXTRTYPE STR)))
	      (RETURN))
          [COND
	    ((SETQ GLPROPS (GETPROP STRB (QUOTE GLSTRUCTURE)))
	      (GLNOTICETYPE STRB)
	      (COND
		((AND (SETQ PROPL (LISTGET (CDR GLPROPS)
					   GLPROP))
		      (SETQ TMP (GLSTRPROPB PROP PROPL ARGS)))
		  (RETURN TMP]
          [SETQ SUPERS (AND GLPROPS (LISTGET (CDR GLPROPS)
					     (QUOTE SUPERS]
      LP  (COND
	    [SUPERS (COND
		      ((SETQ TMP (GLSTRPROP (CAR SUPERS)
					    GLPROP PROP ARGS))
			(RETURN TMP))
		      (T (SETQ SUPERS (CDR SUPERS))
			 (GO LP]
	    ((AND (SETQ UNITREC (GLUNIT? STRB))
		  (SETQ TMP (APPLY* (CADDDR UNITREC)
				    STRB GLPROP PROP)))
	      (RETURN TMP])

(GLSTRPROPB
  [LAMBDA (PROP PROPL ARGS)                     (* GSN "10-FEB-83 13:14"
)

          (* See if the property PROP can be found within the 
	  list of properties PROPL. If ARGS is specified and 
	  ARGTYPES are specified for a property entry, ARGS 
	  are required to match ARGTYPES.)


    (PROG (PROPENT ARGTYPES LARGS)
      LP  (COND
	    ((NULL PROPL)
	      (RETURN)))
          (SETQ PROPENT (CAR PROPL))
          (SETQ PROPL (CDR PROPL))
          (COND
	    ((NEQ (CAR PROPENT)
		  PROP)
	      (GO LP)))
          (OR [AND ARGS (SETQ ARGTYPES (LISTGET (CDDR PROPENT)
						(QUOTE ARGTYPES]
	      (RETURN PROPENT))
          (SETQ LARGS ARGS)
      LPB (COND
	    ((AND (NULL LARGS)
		  (NULL ARGTYPES))
	      (RETURN PROPENT))
	    ((OR (NULL LARGS)
		 (NULL ARGTYPES))
	      (GO LP))
	    ((GLTYPEMATCH (CADAR LARGS)
			  (CAR ARGTYPES))
	      (SETQ LARGS (CDR LARGS))
	      (SETQ ARGTYPES (CDR ARGTYPES))
	      (GO LPB))
	    (T (GO LP])

(GLSTRVAL
  [LAMBDA (OLDFN NEW)                           (* edited: 
						"11-JAN-82 14:58")
                                                (* "GSN: " 
						"19-Mar-81 12:27")

          (* GLSTRVAL is a subroutine of GLSTRFN.
	  Given an old partial retrieval function, in which 
	  the item from which the retrieval is made is 
	  specified by *GL*, and a new function to compute 
	  *GL*, a composite function is made.)


    (PROG NIL
          (COND
	    [(CAR OLDFN)
	      (RPLACA OLDFN (SUBST NEW (QUOTE *GL*)
				   (CAR OLDFN]
	    (T (RPLACA OLDFN NEW)))
          (RETURN OLDFN])

(GLSTRVALB
  [LAMBDA (IND DES NEW)                         (* "GSN: " 
						"13-Aug-81 16:13")
                                                (* "GSN: " 
						"19-Mar-81 12:28")

          (* If the indicator IND can be found within the 
	  description DES, make a composite retrieval function
	  using a copy of the function pattern NEW.)


    (PROG (TMP)
          (COND
	    [(SETQ TMP (GLSTRFN IND DES DESLIST))
	      (RETURN (GLSTRVAL TMP (COPY NEW]
	    (T (RETURN])

(GLSUPERS
  [LAMBDA (CLASS)                               (* edited: 
						"11-NOV-82 14:02")
                                                (* Get the list of 
						superclasses for CLASS.)
    (PROG (TMP)
          (RETURN (AND (SETQ TMP (GETPROP CLASS (QUOTE GLSTRUCTURE)))
		       (LISTGET (CDR TMP)
				(QUOTE SUPERS])

(GLTRANSPARENTTYPES
  [LAMBDA (STR)                                 (* edited: 
						"14-DEC-81 10:51")
                                                (* Return a list of all 
						transparent types 
						defined for STR)
    (DECLARE (SPECVARS TTLIST))
    (PROG (TTLIST)
          [COND
	    ((ATOM STR)
	      (SETQ STR (GLGETSTR STR]
          (GLTRANSPB STR)
          (RETURN (DREVERSE TTLIST])

(GLTRANSPB
  [LAMBDA (STR)                                 (* GSN "31-JUL-83 21:32"
)                                               (* Look for TRANSPARENT 
						substructures for 
						GLTRANSPARENTTYPES.)
    (COND
      ((NLISTP STR))
      ((EQ (CAR STR)
	   (QUOTE TRANSPARENT))
	(SETQ TTLIST (CONS STR TTLIST)))
      [(MEMB (CAR STR)
	     (QUOTE (LISTOF]
      (T (MAPC (CDR STR)
	       (FUNCTION GLTRANSPB])

(GLTYPEMATCH
  [LAMBDA (SUBTYPE TYPE)                        (* GSN "10-FEB-83 13:31"
)

          (* See if the type SUBTYPE matches the type TYPE, 
	  either directly or because TYPE is a SUPER of 
	  SUBTYPE.)


    (PROG NIL
          (SETQ SUBTYPE (GLXTRTYPE SUBTYPE))
          (RETURN (OR (NULL SUBTYPE)
		      (NULL TYPE)
		      (EQ TYPE (QUOTE ANYTHING))
		      (EQUAL SUBTYPE TYPE)
		      (SOME (GLSUPERS SUBTYPE)
			    (FUNCTION (LAMBDA (Y)
				(GLTYPEMATCH Y TYPE])

(GLUNIT?
  [LAMBDA (STR)                                 (* edited: 
						"27-MAY-82 13:08")

          (* GLUNIT? tests a given structure to see if it is a
	  unit of one of the unit packages on GLUNITPKGS.
	  If so, the value is the unit package record for the 
	  unit package which matched.)


    (PROG (UPS)
          (SETQ UPS GLUNITPKGS)
      LP  [COND
	    ((NULL UPS)
	      (RETURN))
	    ((APPLY* (CAAR UPS)
		     STR)
	      (RETURN (CAR UPS]
          (SETQ UPS (CDR UPS))
          (GO LP])

(GLUNITOP
  [LAMBDA (LHS RHS OP)                          (* edited: 
						"27-MAY-82 13:08")

          (* GLUNITOP calls a function to generate code for an
	  operation on a unit in a units package.
	  UNITREC is the unit record for the units package, 
	  LHS and RHS the code for the left-hand side and 
	  right-hand side of the operation 
	  (in general, the (QUOTE GET') code for each side), 
	  and OP is the operation to be performed.)


    (PROG (TMP LST UNITREC)                     (* 
						
"See if the LHS code matches the GET function of a unit package.")
          (SETQ LST GLUNITPKGS)
      A   (COND
	    ((NULL LST)
	      (RETURN))
	    ((NOT (MEMB (CAAR LHS)
			(CADAR LST)))
	      (SETQ LST (CDR LST))
	      (GO A)))
          (SETQ UNITREC (CAR LST))
          [COND
	    ((SETQ TMP (ASSOC OP (CADDR UNITREC)))
	      (RETURN (APPLY* (CDR TMP)
			      LHS RHS]
          (RETURN])

(GLUNWRAPC
  [LAMBDA (X BUSY)                              (* GSN "22-JUL-83 14:32"
)                                               (* Unwrap and optimize 
						an expression if the 
						compiler is present.)
    (COND
      ((GLISPCP)
	(GLUNWRAP X BUSY))
      (T X])

(GLUSERSTROP
  [LAMBDA (LHS OP RHS)                          (* GSN "22-JUL-83 15:57"
)

          (* Try to perform an operation on a user-defined 
	  structure, which is LHS. The type of LHS is looked 
	  up on GLUSERSTRNAMES, and if found, the appropriate 
	  user function is called.)


    (PROG (TMP DES TMPB LST UNITREC)
          (SETQ DES (CADR LHS))
          [COND
	    ((NULL DES)
	      (GO B))
	    [(ATOM DES)
	      (COND
		((NEQ (SETQ TMP (GLGETSTR DES))
		      DES)
		  (RETURN (GLUSERSTROP (LIST (CAR LHS)
					     TMP)
				       OP RHS)))
		(T (GO B]
	    ((NLISTP DES)
	      (GO B))
	    ([AND (SETQ TMP (ASSOC (CAR DES)
				   GLUSERSTRNAMES))
		  (SETQ TMPB (ASSOC OP (CADDDR TMP]
	      (RETURN (APPLY* (CDR TMPB)
			      LHS RHS]
      B   (SETQ LST GLUSERSTRNAMES)
      A   (COND
	    ((NULL LST)
	      (RETURN))
	    ((NEQ (CAAR LHS)
		  (CADDAR LST))
	      (SETQ LST (CDR LST))
	      (GO A)))
          (SETQ UNITREC (CAR LST))
          [COND
	    ((SETQ TMP (ASSOC OP (CADDDR UNITREC)))
	      (RETURN (APPLY* (CDR TMP)
			      LHS RHS]
          (RETURN])

(GLXTRTYPE
  [LAMBDA (TYPE)                                (* edited: 
						"26-JUL-82 14:03")

          (* Extract an atomic type name from a type spec 
	  which may be either <type> or 
	  (A <type>).)


    (COND
      ((ATOM TYPE)
	TYPE)
      ((NLISTP TYPE)
	NIL)
      ((AND (OR (GL-A-AN? (CAR TYPE))
		(EQ (CAR TYPE)
		    (QUOTE TRANSPARENT)))
	    (CDR TYPE)
	    (ATOM (CADR TYPE)))
	(CADR TYPE))
      ((MEMB (CAR TYPE)
	     GLTYPENAMES)
	TYPE)
      ((ASSOC (CAR TYPE)
	      GLUSERSTRNAMES)
	TYPE)
      ((AND (ATOM (CAR TYPE))
	    (CDR TYPE))
	(GLXTRTYPE (CADR TYPE)))
      (T (GLERROR (QUOTE GLXTRTYPE)
		  (LIST TYPE "is an illegal type specification."))
	 NIL])

(GLYESP
  [LAMBDA (MSG)                                 (* GSN "31-JUL-83 21:33"
)
    (PROG (ANS)
      LP  (SELECTQ GLLISPDIALECT
		   (INTERLISP (PRIN1 MSG)
			      (PRIN1 "? "))
		   (PROGN (PRINC MSG)
			  (PRINC "? ")))
          (SETQ ANS (READ))
          (COND
	    ((FMEMB ANS (QUOTE (YES Yes yes Y y)))
	      (RETURN T))
	    ((FMEMB ANS (QUOTE (NO No no N n)))
	      (RETURN NIL)))
          (GO LP])

(SEND
  [NLAMBDA GLISPSENDARGS                        (* GSN " 9-FEB-83 16:46"
)
    (GLSENDB (EVAL (CAR GLISPSENDARGS))
	     NIL
	     (CADR GLISPSENDARGS)
	     (QUOTE MSG)
	     (MAPCAR (CDDR GLISPSENDARGS)
		     (FUNCTION EVAL])

(SENDC
  [NLAMBDA GLISPSENDARGS                        (* GSN " 9-FEB-83 16:48"
)
    (GLSENDB (EVAL (CAR GLISPSENDARGS))
	     (CADR GLISPSENDARGS)
	     (CADDR GLISPSENDARGS)
	     (QUOTE MSG)
	     (MAPCAR (CDDDR GLISPSENDARGS)
		     (FUNCTION EVAL])

(SENDPROP
  [NLAMBDA GLISPSENDPROPARGS                    (* GSN " 9-FEB-83 16:46"
)
    (GLSENDB (EVAL (CAR GLISPSENDPROPARGS))
	     NIL
	     (CADR GLISPSENDPROPARGS)
	     (CADDR GLISPSENDPROPARGS)
	     (MAPCAR (CDDDR GLISPSENDPROPARGS)
		     (FUNCTION EVAL])

(SENDPROPC
  [NLAMBDA GLISPSENDPROPARGS                    (* GSN " 9-FEB-83 16:48"
)
    (GLSENDB (EVAL (CAR GLISPSENDPROPARGS))
	     (CADR GLISPSENDPROPARGS)
	     (CADDR GLISPSENDPROPARGS)
	     (CADDDR GLISPSENDPROPARGS)
	     (MAPCAR (CDDDDR GLISPSENDPROPARGS)
		     (FUNCTION EVAL])
)

(RPAQQ GLBASICTYPES (ATOM INTEGER REAL NUMBER STRING BOOLEAN ANYTHING))

(RPAQQ GLLISPDIALECT INTERLISP)

(RPAQQ GLSPECIALFNS (GLAMBDATRAN GLANALYZEGLISP GLAPPLY GLCOMPCOMS GLED 
				 GLEDS GLERROR GLFIXCOMS GLGETD GLGETDB 
				 GLIFSTRCHANGED GLINTERLISPTRANSFM 
				 GLMAKEGLISPVERSION GLMAKEGLISPVERSIONS 
				 GLP GLPRETTYPRINTCONST 
				 GLPRETTYPRINTGLOBALS GLPRETTYPRINTSTRS)
)

(RPAQQ GLTYPENAMES (CONS LIST RECORD LISTOF ALIST ATOM OBJECT 
			 LISTOBJECT ATOMOBJECT))

(RPAQ GLOBJECTNAMES NIL)

(PUTPROPS GLTYPE GLSTRUCTURE [[ATOM
	     (PROPLIST [GLSTRUCTURE (CONS (STRDES ANYTHING)
					  (PROPLIST
					    (PROP (LISTOF GLPROPENTRY))
					    (ADJ (LISTOF GLPROPENTRY))
					    (ISA (LISTOF GLPROPENTRY))
					    (MSG (LISTOF GLPROPENTRY))
					    (DOC ANYTHING)
					    (SUPERS (LISTOF GLTYPE]
		       (GLISPATOMNUMBER INTEGER)
		       [GLPROPFNS (ALIST (STR (LISTOF GLPROPFNENTRY))
					 (PROP (LISTOF GLPROPFNENTRY))
					 (ADJ (LISTOF GLPROPFNENTRY))
					 (ISA (LISTOF GLPROPFNENTRY))
					 (MSG (LISTOF GLPROPFNENTRY]
		       (GLFNSUSEDIN (LISTOF GLFUNCTION]
	   PROP
	   ((PROPS (PROP))
	    (ADJS (ADJ))
	    (ISAS (ISA))
	    (MSGS (MSG])

(PUTPROPS GLPROPENTRY GLSTRUCTURE [[CONS (NAME ATOM)
					 (CONS (CODE ANYTHING)
					       (PROPLIST (RESULT GLTYPE)
							 (OPEN BOOLEAN]
				   PROP
				   ((SHORTVALUE (NAME])

(PUTPROPS GLPROPFNENTRY GLSTRUCTURE ((LIST (NAME ATOM)
					   (CODE ANYTHING)
					   (RESULT GLTYPE))))

(PUTPROPS GLFUNCTION GLSTRUCTURE [(ATOM (PROPLIST (GLORIGINALEXPR
						    ANYTHING)
						  (GLCOMPILED ANYTHING)
						  (GLRESULTTYPE 
							   ANYTHING)
						  (GLARGUMENTTYPES
						    (LISTOF ANYTHING))
						  (GLTYPESUSED
						    (LISTOF GLTYPE])
(DECLARE: DOEVAL@COMPILE DONTCOPY

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

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

(ADDTOVAR NLAMA SENDPROPC SENDPROP SENDC SEND GLSENDPROPC GLSENDPROP 
			  GLSENDC GLSEND GLISPOBJECTS GLISPGLOBALS 
			  GLISPCONSTANTS GLERR GLDEFSYSSTRQ GLDEFSTRQ 
			  GLDEFSTRNAMES GLADDTOOBJECTS AN A)

(ADDTOVAR NLAML )

(ADDTOVAR LAMA )
)
(DECLARE: DONTCOPY
  (FILEMAP (NIL (2839 77538 (A 2849 . 2960) (AN 2962 . 3074) (GL-A-AN? 3076 . 3291) (GLADDPROP 3293 . 
3819) (GLADDTOOBJECT 3821 . 5048) (GLADDTOOBJECTS 5050 . 5303) (GLAINTERPRETER 5305 . 6303) (
GLANYCARCDR? 6305 . 7000) (GLAPPLY 7002 . 7106) (GLAQR 7108 . 7269) (GLAQRB 7271 . 10744) (GLAQRLISTOF
 10746 . 11220) (GLAQRRD 11222 . 11379) (GLAQRSTR 11381 . 11763) (GLATMSTR? 11765 . 12586) (
GLATOMSTRFN 12588 . 13066) (GLCARCDRRESULTTYPE 13068 . 13572) (GLCARCDRRESULTTYPEB 13574 . 14749) (
GLCLASS 14751 . 15453) (GLCLASSMEMP 15455 . 15720) (GLCLASSP 15722 . 15953) (GLCLASSSEND 15955 . 16540
) (GLCOMPPROP 16542 . 17710) (GLCOMPPROPL 17712 . 20313) (GLDEFAULTVALUE 20315 . 20647) (
GLDEFFNRESULTTYPES 20649 . 21027) (GLDEFFNRESULTTYPEFNS 21029 . 21396) (GLDEFPROP 21398 . 22179) (
GLDEFSTR 22181 . 24280) (GLDEFSTRNAMES 24282 . 24588) (GLDEFSTRQ 24590 . 24933) (GLDEFSYSSTRQ 24935 . 
25279) (GLDEFUNITPKG 25281 . 26207) (GLDELDEF 26209 . 26454) (GLDESCENDANTP 26456 . 26860) (GLDOEXPRC 
26862 . 27244) (GLED 27246 . 27594) (GLEDS 27596 . 28021) (GLERR 28023 . 28198) (GLERROR 28200 . 29067
) (GLEXPENSIVE? 29069 . 29574) (GLGENCODE 29576 . 30040) (GLGETASSOC 30042 . 30385) (GLGETD 30387 . 
30761) (GLGETDB 30763 . 31045) (GLGETDEF 31047 . 31347) (GLGETFROMUNIT 31349 . 31917) (GLGETPAIRS 
31919 . 32659) (GLGETSTR 32661 . 33178) (GLGETSUPERS 33180 . 33444) (GLIFSTRCHANGED 33446 . 33706) (
GLINIT 33708 . 41339) (GLISPCONSTANTS 41341 . 42040) (GLISPCP 42042 . 42293) (GLISPGLOBALS 42295 . 
42797) (GLISPOBJECTS 42799 . 43228) (GLLISTRESULTTYPEFN 43230 . 44290) (GLLISTSTRFN 44292 . 45166) (
GLMKATOM 45168 . 45767) (GLMKRECORD 45769 . 46344) (GLMKSTR 46346 . 50139) (GLMKVAR 50141 . 50464) (
GLNOTICETYPE 50466 . 50783) (GLNTHRESULTTYPEFN 50785 . 51341) (GLOKSTR? 51343 . 53082) (GLP 53084 . 
53529) (GLPROPSTRFN 53531 . 55332) (GLPUTARITH 55334 . 56944) (GLPUTFN 56946 . 59989) (GLRESULTTYPE 
59991 . 61388) (GLSEND 61390 . 61626) (GLSENDB 61628 . 63934) (GLSENDC 63936 . 64192) (GLSENDPROP 
64194 . 64461) (GLSENDPROPC 64463 . 64755) (GLSTRCHANGED 64757 . 65493) (GLSTRFN 65495 . 67894) (
GLSTRPROP 67896 . 68906) (GLSTRPROPB 68908 . 69875) (GLSTRVAL 69877 . 70472) (GLSTRVALB 70474 . 70951)
 (GLSUPERS 70953 . 71280) (GLTRANSPARENTTYPES 71282 . 71686) (GLTRANSPB 71688 . 72107) (GLTYPEMATCH 
72109 . 72591) (GLUNIT? 72593 . 73101) (GLUNITOP 73103 . 74012) (GLUNWRAPC 74014 . 74285) (GLUSERSTROP
 74287 . 75383) (GLXTRTYPE 75385 . 76068) (GLYESP 76070 . 76485) (SEND 76487 . 76721) (SENDC 76723 . 
76977) (SENDPROP 76979 . 77244) (SENDPROPC 77246 . 77536)))))
STOP
)))))
STOP