(FILECREATED "13-Dec-83 16:40:27" <CS.NOVAK>GEV.LSP.3 50634 changes to: GEVA GEVDATANAMESB GEVEDIT previous date: " 9-Dec-83 12:00:56" <CS.NOVAK>GEV.LSP.2) (PRETTYCOMPRINT GEVCOMS) (RPAQQ GEVCOMS [(* GEV Structure Inspector) (* Copyright (c) 1983 by Gordon S. Novak Jr.) (* The following files are required: VECTOR GEVAUX DWINDOW) (GLISPGLOBALS GEVACTIVEFLG GEVEDITCHAIN GEVEDITFLG GEVLASTITEMNUMBER GEVMENUWINDOW GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY) (GLISPCONSTANTS GEVMOUSEBUTTON GEVNAMECHARS GEVVALUECHARS GEVNAMEPOS GEVTILDEPOS GEVVALUEPOS) (GLISPOBJECTS EDITCHAIN EDITFRAME GSEITEM MOUSESTATE) (FNS GEV GEVA GEVCOMMANDFN GEVCOMMANDPROP GEVCOMMANDPROPNAMES GEVCOMPPROP GEVDATANAMES GEVDATANAMESB GEVDISPLAYNEWPROP GEVDOPROP GEVEDIT GEVEXPROP GEVFILLWINDOW GEVFILTER GEVFINDITEMPOS GEVFINDITEMTYPE GEVFINDLISTPOS GEVFINDPOS GEVGETNAMES GEVGETPROP GEVGLISPP GEVHORIZLINE GEVINIT GEVINTERFACE GEVITEMEVENTFN GEVLENGTHBOUND GEVMAKENEWFN GEVMATCH GEVMATCHA GEVMATCHATOM GEVMATCHALIST GEVMATCHB GEVMATCHLISTOF GEVMATCHOBJECT GEVMATCHPROPLIST GEVMATCHRECORD GEVMATCHUOBJ GEVPOP GEVPOSTEST GEVPPS GEVPROGRAM GEVPROPMENU GEVPROPNAMES GEVPROPTYPE GEVPROPTYPES GEVPUSH GEVPUSHLISTOF GEVQUIT GEVREDOPROPS GEVREFILLWINDOW GEVSHORTATOMVAL GEVSHORTCONSVAL GEVSHORTLISTVAL GEVSHORTSTRINGVAL GEVSHORTVALUE GEVUSERSTR GEVXTRTYPE) (VARS GEVTYPENAMES) (GLOBALVARS GLLISPDIALECT GLUSERSTRNAMES GEVACTIVEFLG GEVEDITCHAIN GEVEDITFLG GEVLASTITEMNUMBER GEVMENUWINDOW GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY GEVUSERTYPENAMES) (SPECVARS GLNATOM RESULT Y P X N GEVTYPENAMES) (P (SETQ GEVUSERTYPENAMES NIL)) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA GEV) (NLAML) (LAMA]) [DECLARE: DONTEVAL@LOAD DONTCOPY (* GEV Structure Inspector) ] [DECLARE: DONTEVAL@LOAD DONTCOPY (* Copyright (c) 1983 by Gordon S. Novak Jr.) ] [DECLARE: DONTEVAL@LOAD DONTCOPY (* The following files are required: VECTOR GEVAUX DWINDOW) ] [GLISPGLOBALS (GEVACTIVEFLG BOOLEAN ) (GEVEDITCHAIN EDITCHAIN ) (GEVEDITFLG BOOLEAN ) (GEVLASTITEMNUMBER INTEGER ) (GEVMENUWINDOW WINDOW ) (GEVMENUWINDOWHEIGHT INTEGER ) (GEVMOUSEAREA MOUSESTATE ) (GEVSHORTCHARS INTEGER ) (GEVWINDOW WINDOW ) (GEVWINDOWY INTEGER ) ] [GLISPCONSTANTS (GEVMOUSEBUTTON 4 INTEGER ) (GEVNAMECHARS 11 INTEGER ) (GEVVALUECHARS 27 INTEGER ) (GEVNAMEPOS (PLUS GEVNUMBERPOS (COND ((GREATERP GEVNUMBERCHARS 0) (TIMES (ADD1 GEVNUMBERCHARS) WINDOWCHARWIDTH)) (T 0))) INTEGER ) (GEVTILDEPOS (PLUS GEVNAMEPOS (TIMES (ADD1 GEVNAMECHARS) WINDOWCHARWIDTH)) INTEGER ) (GEVVALUEPOS (PLUS GEVTILDEPOS (TIMES 2 WINDOWCHARWIDTH)) INTEGER ) ] [GLISPOBJECTS (EDITCHAIN (LISTOF EDITFRAME) PROP [(TOPFRAME ((CAR self))) (TOPITEM ((CAR TOPFRAME:PREVS] ) (EDITFRAME (LIST (PREVS (LISTOF GSEITEM)) (SUBITEMS (LISTOF GSEITEM)) (PROPS (LISTOF GSEITEM))) ) (GSEITEM (LIST (NAME ATOM) (VALUE ANYTHING) (TYPE ANYTHING) (SHORTVALUE ATOM) (NODETYPE ATOM) (SUBVALUES (LISTOF GSEITEM)) (NAMEPOS VECTOR) (VALUEPOS VECTOR)) PROP [(NAMEAREA ((VIRTUAL REGION WITH START = NAMEPOS WIDTH = WINDOWCHARWIDTH* (NCHARS NAME) HEIGHT = WINDOWLINEYSPACING))) (VALUEAREA ((VIRTUAL REGION WITH START = VALUEPOS WIDTH = WINDOWCHARWIDTH* (NCHARS NAME) HEIGHT = WINDOWLINEYSPACING] ) (MOUSESTATE (LIST (AREA REGION) (ITEM GSEITEM) (FLAG BOOLEAN) (GROUP INTEGER)) ) ] (DEFINEQ (GEV [NLAMBDA ARGS (* GSN " 9-FEB-83 11:40" ) (* GLISP Edit Value function. Edit VAL according to structure description STR.) (GEVA (CAR ARGS) (EVAL (CAR ARGS)) (AND (CDR ARGS) (COND ((OR (NOT (ATOM (CADR ARGS))) (BOUNDP (CADR ARGS))) (EVAL (CADR ARGS))) (T (CADR ARGS]) (GEVA (GLAMBDA (VAR VAL STR) (* "GSN: " "13-Dec-83 16:40") (* GLISP Edit Value function. Edit VAL according to structure description STR.) (PROG (GLNATOM HEADER) (GEVENTER) (COND ((OR (NOT (BOUNDP (QUOTE GEVWINDOW))) (NULL GEVWINDOW)) (GEVINITEDITWINDOW))) (IF GEVMENUWINDOW THEN (SEND GEVMENUWINDOW OPEN)) (SEND GEVWINDOW OPEN) (GEVACTIVEFLG←T) (GEVEDITFLG←NIL) (GLNATOM←0) (GEVSHORTCHARS←GEVVALUECHARS) [IF VAR IS A LIST AND (CAR VAR)='QUOTE THEN VAR←(CONCAT "'" (GEVSTRINGIFY (CADR VAR] (IF ~STR THEN (IF VAL IS ATOMIC AND (GETPROP VAL (QUOTE | GLSTRUCTURE)) | THEN STR←'GLTYPE | ELSEIF (STR ←(GEVUSERSTR VAL)) | ELSEIF (GETD (QUOTE GEVUSEROBJECTTYPE)) | AND (STR ←(GEVUSEROBJECTTYPE VAL)) | ELSEIF (GEVGLISPP) | THEN STR←(GLCLASS VAL))) | (HEADER←(A GSEITEM WITH NAME = VAR , VALUE = VAL , TYPE = STR) ) (GEVEDITCHAIN←(LIST (LIST (LIST HEADER) NIL NIL))) (GEVREFILLWINDOW) (GEVMOUSELOOP) (GEVEXIT)))) (GEVCOMMANDFN [GLAMBDA (COMMANDWORD:ATOM) (* edited: "17-APR-83 15:07") (PROG (TOPITEM) (CASE COMMANDWORD OF (EDIT (GEVEDIT)) (QUIT (IF GEVMOUSEAREA THEN (SEND GEVWINDOW INVERTAREA GEVMOUSEAREA:AREA) (GEVMOUSEAREA←NIL) ELSE (GEVQUIT))) (POP (GEVPOP T 1)) (PROGRAM (GEVPROGRAM)) ((PROP ADJ ISA MSG) (TOPITEM←GEVEDITCHAIN:TOPITEM) (GEVCOMMANDPROP TOPITEM COMMANDWORD NIL)) ELSE (ERROR]) (GEVCOMMANDPROP [GLAMBDA (ITEM:GSEITEM COMMANDWORD:ATOM PROPNAME:ATOM) (* GSN "11-AUG-83 14:08" ) (PROG (PROPNAMES FLG) (IF PROPNAME THEN FLG←T) (IF ITEM:TYPE IS ATOMIC THEN (PROPNAMES←(GEVCOMMANDPROPNAMES ITEM:TYPE COMMANDWORD GEVEDITCHAIN:TOPFRAME))) (IF ITEM:TYPE IS ATOMIC OR COMMANDWORD='PROP THEN (IF COMMANDWORD='PROP THEN (IF PROPNAMES AND (CDR PROPNAMES) THEN PROPNAMES+←'All) PROPNAMES+←'self) (IF ~PROPNAMES THEN (GEVENTERPRINT) (PRIN1 "None.") (GEVEXITPRINT) (RETURN)) (IF ~PROPNAME (PROPNAME ←(SEND (A MENU WITH ITEMS = PROPNAMES) SELECT))) (IF ~PROPNAME (RETURN) ELSEIF PROPNAME='self THEN (GEVENTERPRINT) (PRIN1 PROPNAME) (PRINC " = ") (PRINT ITEM:VALUE) (GEVEXITPRINT) ELSEIF COMMANDWORD='PROP AND PROPNAME='All THEN (FOR X IN (OR (CDDR PROPNAMES) (CDR PROPNAMES)) DO (GEVDOPROP ITEM X COMMANDWORD FLG)) ELSE (GEVDOPROP ITEM PROPNAME COMMANDWORD FLG)) (IF COMMANDWORD='MSG THEN (GEVREFILLWINDOW) (GEVEDITFLG←T]) (GEVCOMMANDPROPNAMES (GLAMBDA (OBJ:GLTYPE PROPTYPE:ATOM TOPFRAME:EDITFRAME) (* "GSN: " " 9-Dec-83 11:54") (* Get all property names of properties of type PROPTYPE for OBJ. Properties are filtered to remove system properties and those which are already displayed.) (PROG (RESULT) (IF OBJ IS NOT ATOMIC THEN (RETURN)) (RESULT ←(FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN ~(PROPTYPE~='MSG AND (THE PROP OF TOPFRAME WITH NAME =(CAR | P))) | AND ~[PROPTYPE='PROP AND (MEMB (CAR P) (QUOTE (SHORTVALUE DISPLAYPROPS] AND ~(PROPTYPE='MSG AND (CADR P) AND (CADR P) IS ATOMIC AND (~(GETD (CADR P)) OR [LENGTH (CADR (GETD (CADR P] >1)) COLLECT P:NAME)) [FOR S IN OBJ:SUPERS DO (RESULT ←(NCONC RESULT (GEVCOMMANDPROPNAMES S PROPTYPE TOPFRAME] [FOR S IN (GLTRANSPARENTTYPES OBJ) DO (RESULT ←(NCONC RESULT (GEVCOMMANDPROPNAMES (GLXTRTYPE S) PROPTYPE TOPFRAME] (RETURN RESULT)))) (GEVCOMPPROP [GLAMBDA (STR:GLTYPE PROPNAME:ATOM PROPTYPE:ATOM) (* "GSN: " " 9-Dec-83 11:55") (* Compile a property whose name is PROPNAME and whose property type (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR.) (PROG (PROPENT) (IF ~(PROPTYPE <=(QUOTE (ADJ ISA PROP MSG))) | OR STR IS NOT ATOMIC (RETURN (QUOTE GEVERROR))) | (* If the property is implemented by a named function, return the function name.) (IF (PROPENT←(GEVGETPROP STR PROPNAME PROPTYPE)) AND (CADR PROPENT) IS ATOMIC THEN (RETURN (CADR PROPENT))) (* Compile code for this property and save it. First be sure the GLISP compiler is loaded.) (RETURN (COND ((GEVGLISPP) (GLCOMPPROP STR PROPNAME PROPTYPE) OR (QUOTE GEVERROR)) (T (QUOTE GEVERROR]) (GEVDATANAMES [GLAMBDA (OBJ:GLTYPE FILTER:ATOM) (* edited: " 4-NOV-82 16:08") (* Get a flattened list of names and types from a given structure description.) (PROG (RESULT) (GEVDATANAMESB OBJ:STRDES FILTER) (RETURN (DREVERSE RESULT]) (GEVDATANAMESB [GLAMBDA (STR:ANYTHING FILTER:ATOM) (* "GSN: " "13-Dec-83 16:36") (* Get a flattened list of names and types from a given structure description.) (GLOBAL RESULT) (IF STR IS A LIST | THEN (CASE (CAR STR) | OF | (CONS (GEVDATANAMESB (CADR STR) | FILTER) | (GEVDATANAMESB (CADDR STR) | FILTER)) | ((ALIST PROPLIST LIST OBJECT ATOMOBJECT LISTOBJECT) | (FOR X IN (CDR STR) DO (GEVDATANAMESB X FILTER))) | (RECORD (FOR X IN (CDDR STR) | DO (GEVDATANAMESB X FILTER))) | (ATOM (GEVDATANAMESB (CADR STR) | FILTER) | (GEVDATANAMESB (CADDR STR) | FILTER)) | (BINDING (GEVDATANAMESB (CADR STR) | FILTER)) | (LISTOF NIL) | ELSE | [IF (GEVFILTER (CADR STR) | FILTER) | THEN (RESULT +←(LIST (CAR STR) | (CADR STR] | (GEVDATANAMESB (CADR STR) | FILTER]) (GEVDISPLAYNEWPROP (GLAMBDA NIL (* GSN "25-MAR-83 09:48" ) (* Display a newly added property in the window.) (PROG (Y NEWONE:GSEITEM) (Y←GEVWINDOWY) (NEWONE←(CAR (LAST GEVEDITCHAIN:TOPFRAME:PROPS))) (GEVPPS NEWONE 0 GEVWINDOW) (GEVWINDOWY←Y)))) (GEVDOPROP [GLAMBDA (ITEM:GSEITEM PROPNAME:ATOM COMMANDWORD:ATOM FLG:BOOLEAN) (* GSN " 4-FEB-83 16:58" ) (* Add the property PROPNAME of type COMMANDWORD to the display for ITEM.) (PROG (VAL) (VAL←(GEVEXPROP ITEM:VALUE ITEM:TYPE PROPNAME COMMANDWORD NIL) ) (GEVEDITCHAIN:TOPFRAME:PROPS←+(A GSEITEM WITH NAME = PROPNAME , TYPE =(GEVPROPTYPE ITEM:TYPE PROPNAME COMMANDWORD) , VALUE = VAL , NODETYPE = COMMANDWORD)) (IF ~FLG THEN (GEVDISPLAYNEWPROP]) (GEVEDIT (GLAMBDA NIL (* "GSN: " "13-Dec-83 16:37") (* Edit the currently displayed item.) (PROG (CHANGEDFLG GEVTOPITEM) (GEVTOPITEM←GEVEDITCHAIN:TOPITEM) (IF GEVTOPITEM:TYPE IS ATOMIC AND (GEVEXPROP GEVTOPITEM:VALUE GEVTOPITEM:TYPE (QUOTE EDIT) (QUOTE MSG) NIL) ~='GEVERROR THEN CHANGEDFLG←T ELSEIF GEVTOPITEM:VALUE IS A LIST THEN (EVAL (LIST (QUOTE EDITV) | (LIST (QUOTE QUOTE) | GEVTOPITEM:VALUE))) | (CHANGEDFLG←T) ELSE (RETURN)) (IF CHANGEDFLG THEN (SEND GEVWINDOW OPEN) (GEVREFILLWINDOW)) (GEVEDITFLG←CHANGEDFLG)))) (GEVEXPROP [GLAMBDA (OBJ STR PROPNAME:ATOM PROPTYPE:ATOM ARGS) (* GSN "26-JUL-83 17:08" ) (* Execute a property whose name is PROPNAME and whose property type (ADJ, ISA, PROP, MSG) is PROPTYPE on the object OBJ whose type is STR.) (PROG (FN TMP) (IF ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG))) OR (ARGS AND PROPTYPE~='MSG) (RETURN (QUOTE GEVERROR))) (IF (FN←(GEVCOMPPROP STR PROPNAME PROPTYPE))='GEVERROR THEN (RETURN FN) ELSEIF FN = NIL THEN (IF STR IS ATOMIC AND (TMP ←(GETPROP (CAAR (GETPROP STR (QUOTE GLSTRUCTURE)) ) (QUOTE GEVINTERFACE))) THEN (RETURN (APPLY* (CADR TMP) OBJ STR PROPNAME PROPTYPE ARGS)) ELSE (RETURN (QUOTE GEVERROR))) ELSE (RETURN (GLAPPLY FN (CONS OBJ ARGS]) (GEVFILLWINDOW (GLAMBDA NIL (* GSN "25-JUL-83 17:34" ) (* Fill the GEV editor window with the item which is at the top of GEVEDITCHAIN.) (PROG (Y TOP) (SEND GEVWINDOW CLEAR) (* Compute an initial Y value for printing titles in the window.) (Y←GEVWINDOW:HEIGHT - GEVWINDOWTOPMARGIN) (* Print the titles from the edit chain first.) (GEVLASTITEMNUMBER ← 0) (TOP←GEVEDITCHAIN:TOPFRAME) (FOR X IN (REVERSE TOP:PREVS) DO (GEVPPS X 0 GEVWINDOW)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:SUBITEMS DO (GEVPPS X 0 GEVWINDOW)) (GEVHORIZLINE GEVWINDOW) (FOR X IN TOP:PROPS DO (GEVPPS X 0 GEVWINDOW)) (GEVWINDOWY←Y)))) (GEVFILTER (GLAMBDA (TYPE FILTER) (* GSN "29-APR-83 16:37" ) (* Filter types according to a specified FILTER.) (TYPE←(GEVXTRTYPE TYPE)) (CASE FILTER OF (NUMBER ~(MEMB TYPE (QUOTE (BOOLEAN ANYTHING))) AND ~((LISTP TYPE) AND (CAR TYPE)='LISTOF) ) (LIST (LISTP TYPE) AND (CAR TYPE)='LISTOF) ELSE T))) (GEVFINDITEMPOS [GLAMBDA (POS:VECTOR ITEM:GSEITEM N:INTEGER) (* edited: "14-OCT-82 11:32") (RESULT MOUSESTATE) (* Test whether ITEM contains the mouse position POS. The result is NIL if not found, else a list of the sub-item and a flag which is NIL if the NAME part is identified, T if the VALUE part is identified.) (OR (GEVPOSTEST POS ITEM:NAMEPOS ITEM:NAME ITEM NIL N) (GEVPOSTEST POS ITEM:VALUEPOS ITEM:SHORTVALUE ITEM T N) ((ITEM:NODETYPE='STRUCTURE OR ITEM:NODETYPE='SUBTREE OR ITEM:NODETYPE='LISTOF) AND (GEVFINDLISTPOS POS ITEM:SUBVALUES N]) (GEVFINDITEMTYPE [GLAMBDA (ITEM:GSEITEM) (* Try to find the type of an item if its declared type is unknown.) (PROG (VAL) (IF ITEM:TYPE = NIL OR ITEM:TYPE =(QUOTE ANYTHING) THEN (VAL ← ITEM:VALUE) (ITEM:TYPE ←(IF VAL IS REAL THEN (QUOTE REAL) ELSEIF VAL IS INTEGER THEN (QUOTE INTEGER) ELSEIF VAL IS A STRING THEN (QUOTE STRING) ELSEIF (GEVUSERSTR VAL) ELSEIF VAL IS ATOMIC THEN (QUOTE ATOM) ELSE ITEM:TYPE]) (GEVFINDLISTPOS (GLAMBDA (POS:VECTOR ITEMS:(LISTOF GSEITEM) N) (* edited: "13-OCT-82 12:03") (RESULT MOUSESTATE) (* Find some ITEM corresponding to the mouse position POS.) (IF ITEMS THEN (GEVFINDITEMPOS POS (CAR ITEMS) N) OR (GEVFINDLISTPOS POS (CDR ITEMS) N)))) (GEVFINDPOS (GLAMBDA (POS:VECTOR FRAME:EDITFRAME) (* edited: "13-OCT-82 12:06") (RESULT MOUSESTATE) (* Find the sub-item of FRAME corresponding to the mouse position POS. The result is NIL if not found, else a list of the sub-item and a flag which is NIL if the NAME part is identified, T if the VALUE part is identified.) (PROG (TMP N ITEMS:(LISTOF GSEITEM)) (N←0) (WHILE FRAME AND ~TMP DO (N←+1) ITEMS-←FRAME (TMP←(GEVFINDLISTPOS POS ITEMS N))) (RETURN TMP)))) (GEVGETNAMES [GLAMBDA (OBJ:GLTYPE FILTER:ATOM) (* edited: "22-DEC-82 14:53") (* Get all names of properties and stored data from a GLISP object type.) (PROG (DATANAMES PROPNAMES) (SETQ DATANAMES (GEVDATANAMES OBJ FILTER)) (SETQ PROPNAMES (GEVPROPNAMES OBJ (QUOTE PROP) FILTER)) (RETURN (NCONC DATANAMES PROPNAMES]) (GEVGETPROP [GLAMBDA (STR PROPNAME:ATOM PROPTYPE:ATOM) (* "GSN: " " 9-Dec-83 11:56") (* Retrieve a GLISP property whose name is PROPNAME and whose property type (ADJ, ISA, PROP, MSG) is PROPTYPE for the object type STR.) (PROG (PL SUBPL PROPENT) (IF ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG))) (ERROR)) (RETURN (AND (ATOM STR) | (PL←(GETPROP STR (QUOTE GLSTRUCTURE))) (SUBPL←(LISTGET (CDR PL) PROPTYPE)) (PROPENT←(ASSOC PROPNAME SUBPL]) (GEVGLISPP [LAMBDA NIL (* edited: "11-NOV-82 15:53") (BOUNDP (QUOTE GLBASICTYPES]) (GEVHORIZLINE (GLAMBDA (W:WINDOW) (* edited: " 6-APR-83 15:54") (GLOBAL Y:INTEGER) (* Draw a horizontal line across window W at Y and decrease Y.) (SEND W DRAWLINE (A VECTOR WITH X = W:LEFTMARGIN Y = Y+WINDOWLINEYSPACING / 2) (A VECTOR WITH X = W:RIGHTMARGIN Y = Y+WINDOWLINEYSPACING / 2) ) (Y←-WINDOWLINEYSPACING))) (GEVINIT [LAMBDA NIL (* edited: "11-MAR-83 16:03") (SETQ GLNATOM 0) [COND ((NOT (BOUNDP (QUOTE GLLISPDIALECT))) (SETQ GLLISPDIALECT (QUOTE INTERLISP] (SETQ GEVWINDOW NIL]) (GEVINTERFACE [LAMBDA (STROP GETFN PROPFN CLASSFN) (* GSN "25-JUL-83 17:32" ) (* Simple interface to GEV for an objects package.) (* STROP is a structuring operator used to form a GLISP object description. For example, FRAME.) (* GETFN, with args <object>, <structure>, <slotname>, is a function to get slot values from an object.) (* PROPFN, with args <object>, <structure>, <propname>, <proptype>, <arglist>, is a function to compute properties of an object. <proptype> is one of PROP, ADJ, ISA, MSG.) (* CLASSFN is a safe function that takes an object and returns its class name or NIL.) [COND ((NOT (FMEMB STROP GEVUSERTYPENAMES)) (SETQ GEVUSERTYPENAMES (CONS STROP GEVUSERTYPENAMES] (PUTPROP STROP (QUOTE GEVINTERFACE) (LIST GETFN PROPFN CLASSFN]) (GEVITEMEVENTFN [GLAMBDA (ITEM:GSEITEM GROUP:INTEGER FLAG:BOOLEAN) (* "GSN: " " 9-Dec-83 11:56") (* Respond to an event which selects an item. GROUP gives the group in which the item occurs. 1 = edit path. FLAG is T if the type of the item is selected, NIL if the value is selected.) (PROG (TMP TOP N) (IF FLAG | THEN (IF GROUP=1 | THEN (TMP←GEVEDITCHAIN:TOPFRAME:PREVS) | (N←0) | (WHILE TMP AND (TOP-←TMP) | <>ITEM | DO N←+1) | (GEVPOP NIL N) | ELSE (GEVFINDITEMTYPE ITEM) | (GEVPUSH ITEM)) | ELSE (GEVFINDITEMTYPE ITEM) | (GEVENTERPRINT) | (PRIN1 ITEM:NAME) | (PRINC " is ") | (SELECTQ GLLISPDIALECT | (INTERLISP (PRINTDEF ITEM:TYPE (POSITION | T))) | (PRIN1 ITEM:TYPE)) | (GEVEXITPRINT]) (GEVLENGTHBOUND (GLAMBDA (VAL NCHARS) (* GSN "26-JUL-83 16:38" ) (* Bound the length of VAL to NCHARS.) (SETQ VAL (GEVSTRINGIFY VAL)) (COND ((IGREATERP (NCHARS VAL) NCHARS) ((SUBSTRING VAL 1 (SUB1 NCHARS))+ "-")) (T VAL)))) (GEVMAKENEWFN [GLAMBDA [OPERATION:ATOM INPUTTYPE:ATOM SET:(LIST (NAME ATOM) (TYPE GLTYPE)) PATH:(LISTOF (LIST (NAME ATOM) (TYPE GLTYPE] (* edited: " 6-APR-83 16:01") (* Make a function to perform OPERATION on set SETNAME from INPUTTYPE following PATH to get to the data.) (PROG (LASTPATH VIEWSPEC) (SETQ LASTPATH (CAR (LAST PATH))) (RETURN (LIST [LIST (QUOTE GLAMBDA) (LIST (MKATOM (CONCAT "GEVNEWFNTOP:" INPUTTYPE:PNAME))) (LIST (QUOTE PROG) (CONS (QUOTE GEVNEWFNVALUE) (CASE OPERATION OF (COLLECT (QUOTE ( GEVNEWFNRESULT))) ((MAXIMUM MINIMUM) (QUOTE (GEVNEWFNTESTVAL GEVNEWFNINSTANCE) )) [TOTAL (QUOTE ((GEVNEWFNSUM 0] [AVERAGE (QUOTE ((GEVNEWFNSUM 0.0) (GEVNEWFNCOUNT 0] ELSE (ERROR))) [NCONC (LIST (QUOTE FOR) (QUOTE GEVNEWFNLOOPVAR) (QUOTE IN) (MKATOM (CONCAT "GEVNEWFNTOP:" SET:NAME:PNAME) ) (QUOTE DO) (LIST (QUOTE GEVNEWFNVALUE) (QUOTE ←) (PROGN (VIEWSPEC ←(LIST (QUOTE GEVNEWFNLOOPVAR))) (FOR X IN PATH DO (VIEWSPEC +←(QUOTE OF)) (VIEWSPEC +← X:NAME) (VIEWSPEC +←(QUOTE THE))) VIEWSPEC))) (COPY (CASE OPERATION OF [COLLECT (QUOTE ((GEVNEWFNRESULT +← GEVNEWFNVALUE] [MAXIMUM (QUOTE ((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE > GEVNEWFNTESTVAL THEN ( GEVNEWFNTESTVAL ← GEVNEWFNVALUE) ( GEVNEWFNINSTANCE ← GEVNEWFNLOOPVAR] [MINIMUM (QUOTE ((IF ~ GEVNEWFNINSTANCE OR GEVNEWFNVALUE < GEVNEWFNTESTVAL THEN ( GEVNEWFNTESTVAL ← GEVNEWFNVALUE) ( GEVNEWFNINSTANCE ← GEVNEWFNLOOPVAR] [AVERAGE (QUOTE ((GEVNEWFNSUM ←+ GEVNEWFNVALUE) (GEVNEWFNCOUNT ←+ 1] (TOTAL (QUOTE ((GEVNEWFNSUM ←+ GEVNEWFNVALUE] (LIST (QUOTE RETURN) (CASE OPERATION OF (COLLECT (QUOTE (DREVERSE GEVNEWFNRESULT))) ((MAXIMUM MINIMUM) (QUOTE (LIST GEVNEWFNTESTVAL GEVNEWFNINSTANCE))) [AVERAGE (QUOTE (QUOTIENT GEVNEWFNSUM (FLOAT GEVNEWFNCOUNT] (TOTAL (QUOTE GEVNEWFNSUM] (CASE OPERATION OF (COLLECT (LIST (QUOTE LISTOF) (CADR LASTPATH))) [(MAXIMUM MINIMUM) (LIST (QUOTE LIST) (COPY LASTPATH) (LIST (QUOTE WINNER) (CADR SET:TYPE] (AVERAGE (QUOTE REAL)) (TOTAL (CADR LASTPATH]) (GEVMATCH [GLAMBDA (STR VAL FLG) (* edited: " 8-OCT-82 10:43") (RESULT (LISTOF GSEITEM)) (* Match a structure description, STR, and a value VAL which matches that description, to form a structure editor tree structure.) (PROG (RESULT) (GEVMATCHB STR VAL NIL FLG) (RETURN (DREVERSE RESULT]) (GEVMATCHA [GLAMBDA (STR VAL FLG) (* edited: " 8-OCT-82 10:01") (* Make a single item which matches structure STR and value VAL.) (PROG (RES) (RES←(GEVMATCH STR VAL FLG)) (IF ~(CDR RES) THEN (RETURN (CAR RES)) ELSE (RETURN (A GSEITEM WITH VALUE = VAL , TYPE = STR , SUBVALUES = RES , NODETYPE =(QUOTE SUBTREE]) (GEVMATCHATOM [GLAMBDA (STR VAL NAME) (* edited: " 7-OCT-82 16:38") (* Match an ATOM structure to a given value.) (PROG (L STRB TMP) (IF VAL IS NOT ATOMIC OR VAL IS NULL THEN (RETURN)) (STRB←(CADR STR)) (IF (CAR STRB) ~='PROPLIST THEN (RETURN)) (L←(CDR STRB)) (FOR X IN L DO (IF TMP←(GETPROP VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL]) (GEVMATCHALIST [GLAMBDA (STR VAL NAME) (* edited: " 7-OCT-82 16:57") (* Match an ALIST structure to a given value.) (PROG (L TMP) (L←(CDR STR)) (FOR X IN L DO (IF TMP←(ASSOC (CAR X) VAL) THEN (GEVMATCHB X (CDR TMP) NIL NIL]) (GEVMATCHB [GLAMBDA (STR:(LISTOF ANYTHING) VAL NAME:ATOM FLG:BOOLEAN) (* GSN "26-JUL-83 17:05" ) (* Match a structure description, STR, and a value VAL which matches that description, to form a structure editor tree structure. If FLG is set, the match will descend inside an atomic type name. Results are added to the free variable RESULT.) (GLOBAL RESULT) (PROG (Y STRB XSTR TOP TMP) (XSTR←(GEVXTRTYPE STR)) (IF STR IS ATOMIC THEN (IF FLG AND [STRB ←(CAR (GETPROP STR (QUOTE GLSTRUCTURE] THEN (RESULT +←(A GSEITEM WITH NAME = NAME , VALUE = VAL , SUBVALUES =( GEVMATCH STRB VAL NIL) , TYPE = STR , NODETYPE =( QUOTE STRUCTURE))) ELSE (RESULT +←(A GSEITEM WITH NAME = NAME , VALUE = VAL , TYPE = STR))) (RETURN) ELSE (CASE (CAR STR) OF (CONS (GEVMATCHB (CADR STR) (CAR VAL) NIL NIL) (GEVMATCHB (CADDR STR) (CDR VAL) NIL NIL)) [LIST (FOR X IN (CDR STR) DO (IF VAL (GEVMATCHB X (CAR VAL) NIL NIL) (VAL←(CDR VAL] (ATOM (GEVMATCHATOM STR VAL NAME)) (ALIST (GEVMATCHALIST STR VAL NAME)) (PROPLIST (GEVMATCHPROPLIST STR VAL NAME)) (LISTOF (GEVMATCHLISTOF STR VAL NAME)) (RECORD (GEVMATCHRECORD STR VAL NAME)) ((OBJECT ATOMOBJECT LISTOBJECT) (GEVMATCHOBJECT STR VAL NAME)) (TRANSPARENT (GEVMATCHB (CADR STR) VAL NIL T)) ELSE (IF (GETPROP (CAR STR) (QUOTE GEVINTERFACE)) THEN (GEVMATCHUOBJ STR VAL NAME) ELSEIF NAME THEN (TMP ←(GEVMATCH STR VAL NIL)) (TOP←(CAR TMP)) [RESULT +←(IF ~(CDR TMP) AND ~TOP:NAME THEN (TOP:NAME←NAME) TOP ELSE (A GSEITEM WITH NAME = NAME , VALUE = VAL , SUBVALUES = TMP , TYPE = XSTR , NODETYPE =(QUOTE SUBTREE] ELSEIF (STRB ←(GEVXTRTYPE (CADR STR))) IS ATOMIC THEN (GEVMATCHB STRB VAL (CAR STR) NIL) ELSEIF (TMP←(GEVMATCH (CADR STR) VAL NIL)) THEN (TOP←(CAR TMP)) [RESULT +←(IF ~(CDR TMP) AND ~TOP:NAME THEN (TOP:NAME←(CAR STR)) TOP ELSE (A GSEITEM WITH NAME =( CAR STR) , VALUE = VAL , SUBVALUES = TMP , TYPE =(CADR STR) , NODETYPE =(QUOTE SUBTREE] ELSE (PRINT "GEVMATCHB Failed"]) (GEVMATCHLISTOF (GLAMBDA (STR VAL NAME) (* edited: " 8-OCT-82 10:15") (* Match a LISTOF structure.) (GLOBAL RESULT) (RESULT+←(A GSEITEM WITH NAME = NAME , VALUE = VAL , TYPE = STR)))) (GEVMATCHOBJECT [GLAMBDA (STR VAL NAME) (* GSN "26-JUL-83 16:54" ) (* Match the OBJECT structures.) (GLOBAL RESULT) (PROG ((OBJECTTYPE (CAR STR)) TMP N) (RESULT ←+(A GSEITEM WITH NAME =(QUOTE CLASS) VALUE =[CASE OBJECTTYPE OF (OBJECT (SELECTQ GLLISPDIALECT (PSL (GETV VAL 0)) ((MACLISP FRANZLISP) (CXR 0 VAL)) (TMP-←VAL))) (LISTOBJECT (TMP-←VAL)) (ATOMOBJECT (GETPROP VAL (QUOTE CLASS] TYPE =(QUOTE GLTYPE))) (N ← 0) (FOR X IN (CDR STR) DO (N ←+ 1) (CASE OBJECTTYPE OF [OBJECT (SELECTQ GLLISPDIALECT (PSL (GEVMATCHB X (GETV VAL N) NIL NIL)) ((MACLISP FRANZLISP) (GEVMATCHB X (CXR N VAL) NIL NIL)) (IF VAL (GEVMATCHB X (TMP-←VAL) NIL NIL] (LISTOBJECT (IF VAL (GEVMATCHB X (TMP-←VAL) NIL NIL))) (ATOMOBJECT (IF TMP←(GETPROP VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL]) (GEVMATCHPROPLIST [GLAMBDA (STR VAL NAME) (* edited: "24-NOV-82 16:31") (* Match an PROPLIST structure to a given value.) (PROG (L TMP) (L←(CDR STR)) (FOR X IN L DO (IF TMP←(LISTGET VAL (CAR X)) THEN (GEVMATCHB X TMP NIL NIL]) (GEVMATCHRECORD [GLAMBDA (STR VAL NAME) (* edited: "11-MAR-83 16:31") (* Match a RECORD structure.) (PROG (STRNAME FIELDS N) (IF (CADR STR) IS ATOMIC THEN STRNAME←(CADR STR) FIELDS←(CDDR STR) ELSE FIELDS←(CDR STR)) (N←0) (FOR X IN FIELDS DO (N←+1) (GEVMATCHB X (SELECTQ GLLISPDIALECT (INTERLISP (RECORDACCESS (CAR X) VAL NIL NIL STRNAME)) (PSL (GetV VAL N)) (UCILISP (CAR (NTH VAL N))) ((MACLISP FRANZLISP) (CXR (N - 1) VAL)) (ERROR)) (CAR X) NIL]) (GEVMATCHUOBJ (GLAMBDA (STR:(CONS ATOM (LISTOF ANYTHING)) VAL NAME) (* GSN "26-JUL-83 17:05" ) (* Match an object in a user representation language.) (FOR X IN (CDR STR) DO (GEVMATCHB X (APPLY* (CAR (GETPROP (CAR STR) (QUOTE GEVINTERFACE))) VAL STR (CAR X)) NIL NIL)))) (GEVPOP [GLAMBDA (FLG:BOOLEAN N:INTEGER) (* GSN " 2-MAR-83 17:33" ) (* Pop up from the current item to the previous one. If FLG is set, popping continues through extended LISTOF elements.) (PROG (TMP TOP:GSEITEM TMPITEM) (IF N<1 (RETURN)) LP (TMP-←GEVEDITCHAIN) (IF ~GEVEDITCHAIN THEN (RETURN (GEVQUIT))) (TOP←(CAAAR GEVEDITCHAIN)) (* Test for repeated LISTOF elements.) (TMPITEM←(CAR TMP:PREVS)) (IF FLG AND TMPITEM:NODETYPE='FORWARD THEN (GO LP)) (IF (N←-1) >0 THEN (GO LP)) (IF TOP:TYPE IS A LIST AND (CAR TOP:TYPE)='LISTOF AND ~(CDR TOP:VALUE) THEN (GO LP)) (IF GEVEDITFLG AND ~(MEMBER TMPITEM:SHORTVALUE (QUOTE ("(...)" "---"))) THEN (GEVREFILLWINDOW) ELSE GEVEDITFLG←NIL (GEVFILLWINDOW]) (GEVPOSTEST (GLAMBDA (POS:VECTOR TPOS:VECTOR NAME:STRING ITEM:GSEITEM FLG N:INTEGER) (* edited: "11-MAR-83 15:06") (RESULT MOUSESTATE) (* Test whether TPOS contains the mouse position POS. The result is NIL if not found, else a list of the sub-item and a flag which is NIL if the NAME part is identified, T if the VALUE part is identified.) (IF POS:Y>=TPOS:Y AND POS:Y<=TPOS:Y+WINDOWLINEYSPACING AND POS:X>=TPOS:X AND POS:X<TPOS:X+GEVNAMECHARS*WINDOWCHARWIDTH THEN (A MOUSESTATE WITH AREA =(A REGION WITH START =(A VECTOR WITH X = TPOS:X Y = TPOS:Y - 1) SIZE =(A VECTOR WITH X = WINDOWCHARWIDTH*NAME:LENGTH Y = WINDOWLINEYSPACING)) ITEM = ITEM FLAG = FLG GROUP = N)))) (GEVPPS [GLAMBDA (ITEM:GSEITEM COL:INTEGER WINDOW:WINDOW) (* edited: "17-APR-83 15:09") (GLOBAL Y:INTEGER) (* Pretty-print a structure defined by ITEM in the window WINDOW, beginning ar horizontal column COL and vertical position Y. The positions in ITEM are modified to match the positions in the window.) (PROG (NAMEX) (* Make sure there is room in window.) (IF Y<0 THEN (RETURN)) (GEVFINDITEMTYPE ITEM) (IF GEVNUMBERCHARS>0 THEN (GEVLASTITEMNUMBER ←+ 1) (SEND WINDOW PRINTAT (GEVSTRINGIFY GEVLASTITEMNUMBER) (A VECTOR WITH X = GEVNUMBERPOS Y = Y))) (* Position in window for slot name.) (NAMEX ← GEVNAMEPOS + COL*WINDOWCHARWIDTH) (ITEM:NAMEPOS:X←NAMEX) (ITEM:NAMEPOS:Y←Y) (IF ITEM:NODETYPE='FULLVALUE THEN (SEND WINDOW PRINTAT "(expanded)" (A VECTOR WITH X = NAMEX Y = Y)) ELSEIF ITEM:NAME THEN (IF ITEM:NAME IS NUMERIC THEN (SEND WINDOW PRINTAT "#" (A VECTOR WITH X = NAMEX Y = Y)) (NAMEX←+WINDOWCHARWIDTH)) (SEND WINDOW PRINTAT (GEVLENGTHBOUND ITEM:NAME GEVNAMECHARS) (A VECTOR WITH X = NAMEX Y = Y))) (* See if there is a value to print for this name.) (IF ~ITEM:NODETYPE OR (MEMB ITEM:NODETYPE (QUOTE (FORWARD BACKUP PROP ADJ MSG ISA))) THEN (ITEM:VALUEPOS:X←GEVVALUEPOS) (ITEM:VALUEPOS:Y←Y) (SEND WINDOW PRINTAT [ITEM:SHORTVALUE OR (ITEM:SHORTVALUE ←(GEVSHORTVALUE ITEM:VALUE ITEM:TYPE (GEVSHORTCHARS - COL] (A VECTOR WITH X = GEVVALUEPOS Y = Y)) (IF ~(EQ ITEM:SHORTVALUE ITEM:VALUE) THEN (SEND WINDOW PRINTAT "~" (A VECTOR WITH X = GEVTILDEPOS Y = Y)) ) (Y←-WINDOWLINEYSPACING) ELSEIF ITEM:NODETYPE='FULLVALUE THEN (Y←-WINDOWLINEYSPACING) (SEND WINDOW PRETTYPRINTAT ITEM:VALUE (A VECTOR WITH X = WINDOWCHARWIDTH Y = Y)) (Y←WINDOW:YPOSITION - WINDOWLINEYSPACING) ELSEIF ITEM:NODETYPE='DISPLAY THEN (GEVEXPROP ITEM:VALUE ITEM:TYPE (QUOTE GEVDISPLAY) (QUOTE MSG) (LIST WINDOW Y)) ELSE (* This is a subtree) (Y←-WINDOWLINEYSPACING) (FOR VSUB IN ITEM:SUBVALUES DO (GEVPPS VSUB COL+2 WINDOW]) (GEVPROGRAM (GLAMBDA NIL (* "GSN: " " 9-Dec-83 11:57") (* Write an interactive program involving the current item.) (PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST ABORTFLG) (TOPITEM←GEVEDITCHAIN:TOPITEM) (IF (COMMAND←(SEND (A MENU WITH ITEMS =(QUOTE (Quit COLLECT TOTAL AVERAGE MAXIMUM MINIMUM))) SELECT))='Quit OR ~ COMMAND THEN (RETURN)) (IF (SET←(GEVPROPMENU TOPITEM:TYPE (QUOTE LIST) NIL))='Quit OR SET='Pop OR ~SET THEN (RETURN)) (PATH←(LIST SET (LIST TOPITEM:NAME TOPITEM:TYPE))) (NEXT←SET) (TYPE←(CADADR SET)) (WHILE ~DONE AND ~ABORTFLG DO (NEXT←(GEVPROPMENU TYPE (COMMAND~='COLLECT AND (QUOTE NUMBER)) COMMAND='COLLECT)) (IF NEXT IS ATOMIC THEN (CASE NEXT OF (NIL (IF COMMAND =(QUOTE COLLECT) THEN (DONE ← T) ELSE (ABORTFLG←T))) (Quit (ABORTFLG←T)) [Pop (IF ~(CDDR PATH) THEN (ABORTFLG←T) ELSE (NEXT-←PATH) (NEXT←(CAR PATH)) (TYPE←(CADR NEXT)) (IF TYPE IS A LIST THEN TYPE←(CADR TYPE)) (LAST←(CAR NEXT] (Done (DONE←T))) ELSE (PATH+←NEXT) (TYPE←(CADR NEXT)) (LAST←(CAR NEXT))) (IF ~TYPE OR [COMMAND <> (QUOTE COLLECT) AND (MEMB TYPE (QUOTE (INTEGER REAL NUMBER] DONE←T)) (IF ABORTFLG (RETURN)) (PATH←(DREVERSE PATH)) (NEWFN←(GEVMAKENEWFN COMMAND TOPITEM:TYPE SET (CDDR PATH))) (GEVPUTD (QUOTE GEVNEWFN) (CAR NEWFN)) (GLCC (QUOTE GEVNEWFN)) (RESULT←(GEVNEWFN TOPITEM:VALUE)) (* Print result as well as displaying it.) (GEVENTERPRINT) (PRIN1 COMMAND) (SPACES 1) (FOR X IN (CDDR PATH) DO (PRIN1 (CAR X)) (SPACES 1)) (PRINC "of ") | (PRIN1 (CAAR PATH)) (SPACES 1) (PRIN1 (CAADR PATH)) (PRINC " = ") (PRINT RESULT) (GEVEXITPRINT) (GEVEDITCHAIN:TOPFRAME:PROPS←+(A GSEITEM WITH NAME =(CONCAT (GEVSTRINGIFY COMMAND) (CONCAT " " (GEVSTRINGIFY LAST))) , TYPE =(CADR NEWFN) , VALUE = RESULT , NODETYPE =(QUOTE MSG))) (GEVDISPLAYNEWPROP)))) (GEVPROPMENU [GLAMBDA (OBJ:GLTYPE FILTER:ATOM FLG:BOOLEAN) (* edited: "17-APR-83 15:10") (* Make a menu to get properties of object OBJ with filter FILTER. FLG is T if it is okay to stop before reaching a basic type.) (PROG (PROPS SEL PNAMES) (PROPS←(GEVGETNAMES OBJ FILTER)) (IF ~PROPS THEN (RETURN) ELSE (PNAMES←(MAPCAR PROPS (FUNCTION CAR))) (SEL←(SEND [A MENU WITH ITEMS =(CONS (QUOTE Quit) (CONS (QUOTE Pop) (IF FLG THEN (CONS (QUOTE Done) PNAMES) ELSE PNAMES] SELECT)) (RETURN (CASE SEL OF ((Quit Pop Done NIL) SEL) ELSE (ASSOC SEL PROPS]) (GEVPROPNAMES (GLAMBDA (OBJ:GLTYPE PROPTYPE:ATOM FILTER:ATOM) (* GSN " 4-FEB-83 17:01" ) (* Get all property names and types of properties of type PROPTYPE for OBJ when they satisfy FILTER.) (PROG (RESULT TYPE) (RESULT ←(FOR P IN (CASE PROPTYPE OF (PROP OBJ:PROPS) (ADJ OBJ:ADJS) (ISA OBJ:ISAS) (MSG OBJ:MSGS)) WHEN (TYPE←(GEVPROPTYPES OBJ P:NAME (QUOTE PROP))) AND (GEVFILTER TYPE FILTER) COLLECT (LIST P:NAME TYPE))) [FOR S IN OBJ:SUPERS DO (RESULT ←(NCONC RESULT (GEVPROPNAMES S PROPTYPE FILTER] (RETURN RESULT)))) (GEVPROPTYPE [GLAMBDA (STR:ATOM PROPNAME:ATOM PROPTYPE:ATOM) (* GSN " 4-FEB-83 17:02" ) (* Find the type of a computed property.) (PROG (PL SUBPL PROPENT TMP) (IF STR IS NOT ATOMIC THEN (RETURN) ELSEIF (PROPENT←(GEVGETPROP STR PROPNAME PROPTYPE)) AND (TMP←(LISTGET (CDDR PROPENT) (QUOTE RESULT))) THEN (RETURN TMP) ELSEIF PROPENT AND (CADR PROPENT) IS ATOMIC AND (TMP←(GETPROP (CADR PROPENT) (QUOTE GLRESULTTYPE))) THEN (RETURN TMP) ELSEIF (AND (PL←(GETPROP STR (QUOTE GLPROPFNS))) (SUBPL←(ASSOC PROPTYPE PL)) (PROPENT←(ASSOC PROPNAME (CDR SUBPL))) (TMP←(CADDR PROPENT))) THEN (RETURN TMP) ELSEIF PROPTYPE='ADJ THEN (RETURN (QUOTE BOOLEAN]) (GEVPROPTYPES [LAMBDA (OBJ NAME TYPE) (* edited: " 4-NOV-82 15:39") (OR (GEVPROPTYPE OBJ NAME TYPE) (AND (GEVCOMPPROP OBJ NAME TYPE) (GEVPROPTYPE OBJ NAME TYPE]) (GEVPUSH [GLAMBDA (ITEM:GSEITEM) (* GSN " 2-MAY-83 14:58" ) (* Push down to look at an item referenced from the current item.) (PROG (NEWITEMS TOPITEM LSTITEM:GSEITEM) (IF ITEM:NODETYPE='BACKUP THEN (GEVPOP NIL 1) (RETURN)) (TOPITEM←GEVEDITCHAIN:TOPITEM) (IF ITEM:NODETYPE='FORWARD THEN (NEWITEMS←(GEVPUSHLISTOF ITEM T)) ELSEIF ITEM:TYPE IS ATOMIC AND (MEMB ITEM:TYPE (QUOTE (ATOM NUMBER REAL INTEGER STRING ANYTHING))) THEN [NEWITEMS←(LIST (A GSEITEM WITH NAME = ITEM:NAME , VALUE = ITEM:VALUE , SHORTVALUE = ITEM:SHORTVALUE , TYPE = ITEM:TYPE , NODETYPE =(QUOTE FULLVALUE] ELSEIF ITEM:TYPE IS ATOMIC AND ~(GETPROP ITEM:TYPE (QUOTE GLSTRUCTURE) ) THEN (RETURN) ELSEIF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE)='LISTOF THEN (NEWITEMS←(GEVPUSHLISTOF ITEM NIL))) (GEVEDITCHAIN+←(AN EDITFRAME WITH PREVS =(CONS ITEM GEVEDITCHAIN:TOPFRAME:PREVS) , SUBITEMS = NEWITEMS)) (* Do another PUSH automatically for a list of only one item.) (GEVREFILLWINDOW) (IF ITEM:TYPE IS A LIST AND (CAR ITEM:TYPE)='LISTOF AND ITEM:VALUE IS A LIST AND ~(CDR ITEM:VALUE) THEN (LSTITEM←(CAADAR GEVEDITCHAIN)) (GEVPUSH (CAR LSTITEM:SUBVALUES)) (RETURN]) (GEVPUSHLISTOF [GLAMBDA (ITEM:GSEITEM FLG:BOOLEAN) (* GSN "30-APR-83 16:39" ) (* Push into a datum of type LISTOF, expanding it into the individual elements. If FLG is set, ITEM is a FORWARD item to be continued.) (PROG (ITEMTYPE LISTTYPE TOPFRAME N:INTEGER NROOM LST VALS:(LISTOF ANYTHING) TMP) (* Compute the vertical room available in the window.) (IF ~ITEM:VALUE AND ITEM:NODETYPE <> (QUOTE FORWARD) (RETURN)) (TOPFRAME←GEVEDITCHAIN:TOPFRAME) (LISTTYPE←ITEM:TYPE) (ITEMTYPE←(CADR LISTTYPE)) (NROOM ← GEVWINDOW:HEIGHT / WINDOWLINEYSPACING - 4 -(LENGTH TOPFRAME:PREVS)) (* If there was a previous display of this list, insert an ellipsis header.) (IF FLG THEN (LST+←(A GSEITEM WITH SHORTVALUE = "(..." TYPE = LISTTYPE NODETYPE =(QUOTE BACKUP))) (N←ITEM:NAME) (NROOM←-1) (VALS←ITEM:SUBVALUES) ELSE (N←1) (VALS←ITEM:VALUE)) (* Now make entries for each value on the list.) (WHILE VALS AND (NROOM>1 OR (NROOM=1 AND ~(CDR VALS))) DO (LST+←(A GSEITEM WITH VALUE =(TMP-←VALS) TYPE = ITEMTYPE NAME = N)) (NROOM←-1) (N←+1)) (IF VALS THEN (LST+←(A GSEITEM WITH SHORTVALUE = "...)" NODETYPE =( QUOTE FORWARD) TYPE = LISTTYPE NAME = N SUBVALUES = VALS))) (RETURN (LIST (A GSEITEM WITH NAME = "expanded" TYPE = LISTTYPE NODETYPE =(QUOTE LISTOF) SUBVALUES =(DREVERSE LST]) (GEVQUIT (GLAMBDA NIL (* edited: "14-MAR-83 16:46") (SETQ GEVACTIVEFLG NIL) (SEND GEVWINDOW CLOSE) (IF GEVMENUWINDOW THEN (SEND GEVMENUWINDOW CLOSE)))) (GEVREDOPROPS [GLAMBDA (TOP:EDITFRAME) (* edited: "19-OCT-82 10:23") (* Recompute property values for the item.) (PROG (ITEM L) (ITEM←(CAR TOP:PREVS)) (IF ~TOP:PROPS AND (L←(GEVEXPROP ITEM:VALUE ITEM:TYPE (QUOTE DISPLAYPROPS) (QUOTE PROP) NIL)) ~='GEVERROR THEN (IF L IS ATOMIC THEN (GEVCOMMANDPROP ITEM (QUOTE PROP) (QUOTE All)) ELSEIF L IS A LIST THEN (FOR X IN L (GEVCOMMANDPROP ITEM (QUOTE PROP) X))) ELSE (FOR X IN TOP:PROPS WHEN X:NODETYPE~='MSG DO (X:VALUE ←(GEVEXPROP ITEM:VALUE ITEM:TYPE X:NAME X:NODETYPE NIL)) (X:SHORTVALUE ← NIL]) (GEVREFILLWINDOW (GLAMBDA NIL (* GSN "11-AUG-83 14:12" ) (* Re-expand the top item of GEVEDITCHAIN, which may have been changed due to editing.) (PROG (TOP TOPITEM SUBS TOPSUB) (TOP←GEVEDITCHAIN:TOPFRAME) (TOPITEM←GEVEDITCHAIN:TOPITEM) (IF TOP:SUBITEMS THEN (TOPSUB←(CAR TOP:SUBITEMS))) [IF ~TOPSUB OR (TOPSUB:NODETYPE~='FULLVALUE AND TOPSUB:NODETYPE~='LISTOF) THEN (IF (GEVGETPROP TOPITEM:TYPE (QUOTE GEVDISPLAY) (QUOTE MSG)) THEN [TOP:SUBITEMS←(LIST (A GSEITEM WITH VALUE = TOPITEM:VALUE , TYPE = TOPITEM:TYPE , NODETYPE =(QUOTE DISPLAY] ELSE (SUBS←(GEVMATCH TOPITEM:TYPE TOPITEM:VALUE T)) (TOPSUB←(CAR SUBS)) (TOP:SUBITEMS←(IF ~(CDR SUBS) AND TOPSUB:NODETYPE='STRUCTURE AND TOPSUB:VALUE=TOPITEM:VALUE AND TOPSUB:TYPE=TOPITEM:TYPE THEN TOPSUB:SUBVALUES ELSE SUBS] (GEVREDOPROPS TOP) (GEVFILLWINDOW)))) (GEVSHORTATOMVAL [LAMBDA (ATM NCHARS) (* edited: " 6-APR-83 16:05") (COND ((NUMBERP ATM) (COND ((IGREATERP (NCHARS ATM) NCHARS) (GEVSHORTSTRINGVAL (GEVSTRINGIFY ATM) NCHARS)) (T ATM))) ((IGREATERP (NCHARS ATM) NCHARS) (CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS)) "-")) (T ATM]) (GEVSHORTCONSVAL [GLAMBDA (VAL STR NCHARS:INTEGER) (* GSN " 4-APR-83 16:23" ) (* Compute a short value for printing a CONS of two items.) (PROG (NLEFT RES TMP NC) (RES +← "(") (NLEFT ← NCHARS - 5) (TMP←(GEVSHORTVALUE (CAR VAL) (CADR STR) NLEFT - 3)) (NC←(NCHARS TMP)) (IF NC>NLEFT - 3 THEN TMP← "---" NC←3) (RES+←(GEVSTRINGIFY TMP)) (RES +← " . ") (NLEFT←-NC) (TMP←(GEVSHORTVALUE (CDR VAL) (CADDR STR) NLEFT)) (NC←(NCHARS TMP)) (IF NC>NLEFT THEN TMP← "---" NC←3) (RES+←(GEVSTRINGIFY TMP)) (RES+← ")") (RETURN (GEVCONCAT (DREVERSE RES]) (GEVSHORTLISTVAL [GLAMBDA (VAL STR NCHARS:INTEGER) (* GSN "11-AUG-83 14:14" ) (* Compute a short value for printing a list of items.) (PROG (NLEFT RES TMP QUIT NC NCI REST RSTR) (RES +← "(") (REST←4) (NLEFT ← NCHARS - 2) (RSTR←(CDR STR)) [WHILE VAL AND ~QUIT AND (NCI←(IF (CDR VAL) THEN NLEFT - REST ELSE NLEFT)) >2 DO (TMP←(GEVSHORTVALUE (CAR VAL) (IF (CAR STR)='LISTOF THEN (CADR STR) ELSEIF (CAR STR)='LIST THEN (CAR RSTR)) NCI)) [QUIT ←(MEMBER TMP (QUOTE (GEVERROR "(...)" "---" "???"] (NC←(NCHARS TMP)) (IF NC>NCI AND (CDR RES) THEN QUIT←T ELSE (IF NC>NCI THEN TMP← "---" NC←3 QUIT←T) (RES+←(GEVSTRINGIFY TMP)) (NLEFT←-NC) (VAL←(CDR VAL)) (IF (CAR STR)='LIST THEN (RSTR←(CDR RSTR))) (IF VAL THEN (RES+← " ") (NLEFT←-1] (IF VAL THEN (RES+← "...")) (RES+← ")") (RETURN (GEVCONCAT (DREVERSE RES]) (GEVSHORTSTRINGVAL [LAMBDA (VAL NCHARS) (* edited: "12-OCT-82 12:14") (* Compute the short value of a string VAL. The result is a string which can be printed within NCHARS.) (COND ((STRINGP VAL) (GEVLENGTHBOUND VAL NCHARS)) (T "???"]) (GEVSHORTVALUE [LAMBDA (VAL STR NCHARS) (* edited: "11-MAR-83 15:34") (* Compute the short value of a given value VAL whose type is STR. The result is an atom, string, or list structure which can be printed within NCHARS.) (PROG (TMP) (SETQ STR (GEVXTRTYPE STR)) (RETURN (COND ([AND (ATOM STR) (FMEMB STR (QUOTE (ATOM INTEGER REAL] (GEVSHORTATOMVAL VAL NCHARS)) ((EQ STR (QUOTE STRING)) (GEVSHORTSTRINGVAL VAL NCHARS)) ((AND (ATOM STR) (SETQ TMP (GEVEXPROP VAL STR (QUOTE SHORTVALUE) (QUOTE PROP) NIL)) (NEQ TMP (QUOTE GEVERROR))) (GEVLENGTHBOUND TMP NCHARS)) ((OR (ATOM VAL) (NUMBERP VAL)) (GEVSHORTATOMVAL VAL NCHARS)) ((STRINGP VAL) (GEVSHORTSTRINGVAL VAL NCHARS)) ((LISTP STR) (SELECTQ (CAR STR) ((LISTOF LIST) (COND ((LISTP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "???"))) (CONS (COND ((LISTP VAL) (GEVSHORTCONSVAL VAL STR NCHARS)) (T "???"))) "---")) ((LISTP VAL) (GEVSHORTLISTVAL VAL (QUOTE (LISTOF ANYTHING)) NCHARS)) (T "---"]) (GEVUSERSTR [LAMBDA (OBJ) (* GSN "26-JUL-83 17:03" ) (* Determine the type of a user object if possible.) (PROG (L RES) (SETQ L GEVUSERTYPENAMES) LP (COND ((NULL L) (RETURN)) ((SETQ RES (APPLY* (CADDR (GETPROP (CAR L) (QUOTE GEVINTERFACE))) OBJ)) (RETURN RES))) (SETQ L (CDR L)) (GO LP]) (GEVXTRTYPE [LAMBDA (TYPE) (* edited: "21-OCT-82 11:17") (* 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 (FMEMB (CAR TYPE) (QUOTE (A AN a an An TRANSPARENT))) (CDR TYPE) (ATOM (CADR TYPE))) (CADR TYPE)) ((MEMB (CAR TYPE) GEVTYPENAMES) TYPE) ((AND (BOUNDP GLUSERSTRNAMES) (ASSOC (CAR TYPE) GLUSERSTRNAMES)) TYPE) ((AND (ATOM (CAR TYPE)) (CDR TYPE)) (GEVXTRTYPE (CADR TYPE))) (T (ERROR (QUOTE GEVXTRTYPE) (LIST TYPE "is an illegal type specification.")) NIL]) ) (RPAQQ GEVTYPENAMES (CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT)) (DECLARE: DOEVAL@COMPILE DONTCOPY (ADDTOVAR GLOBALVARS GLLISPDIALECT GLUSERSTRNAMES GEVACTIVEFLG GEVEDITCHAIN GEVEDITFLG GEVLASTITEMNUMBER GEVMENUWINDOW GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY GEVUSERTYPENAMES) ) (DECLARE: DOEVAL@COMPILE DONTCOPY (SPECVARS GLNATOM RESULT Y P X N GEVTYPENAMES) ) (SETQ GEVUSERTYPENAMES NIL) (DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA GEV) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (DECLARE: DONTCOPY (FILEMAP (NIL (3752 50029 (GEV 3762 . 4170) (GEVA 4172 . 5494) (GEVCOMMANDFN 5496 . 5967) ( GEVCOMMANDPROP 5969 . 7207) (GEVCOMMANDPROPNAMES 7209 . 8446) (GEVCOMPPROP 8448 . 9375) (GEVDATANAMES 9377 . 9672) (GEVDATANAMESB 9674 . 10802) (GEVDISPLAYNEWPROP 10804 . 11179) (GEVDOPROP 11181 . 11846) (GEVEDIT 11848 . 12653) (GEVEXPROP 12655 . 13540) (GEVFILLWINDOW 13542 . 14354) (GEVFILTER 14356 . 14767) (GEVFINDITEMPOS 14769 . 15424) (GEVFINDITEMTYPE 15426 . 15932) (GEVFINDLISTPOS 15934 . 16306) ( GEVFINDPOS 16308 . 16864) (GEVGETNAMES 16866 . 17257) (GEVGETPROP 17259 . 17807) (GEVGLISPP 17809 . 17938) (GEVHORIZLINE 17940 . 18351) (GEVINIT 18353 . 18586) (GEVINTERFACE 18588 . 19510) ( GEVITEMEVENTFN 19512 . 20564) (GEVLENGTHBOUND 20566 . 20893) (GEVMAKENEWFN 20895 . 23526) (GEVMATCH 23528 . 23898) (GEVMATCHA 23900 . 24348) (GEVMATCHATOM 24350 . 24862) (GEVMATCHALIST 24864 . 25228) ( GEVMATCHB 25230 . 27752) (GEVMATCHLISTOF 27754 . 28031) (GEVMATCHOBJECT 28033 . 29160) ( GEVMATCHPROPLIST 29162 . 29513) (GEVMATCHRECORD 29515 . 30203) (GEVMATCHUOBJ 30205 . 30612) (GEVPOP 30614 . 31513) (GEVPOSTEST 31515 . 32326) (GEVPPS 32328 . 34861) (GEVPROGRAM 34863 . 37352) ( GEVPROPMENU 37354 . 38099) (GEVPROPNAMES 38101 . 38769) (GEVPROPTYPE 38771 . 39628) (GEVPROPTYPES 39630 . 39833) (GEVPUSH 39835 . 41343) (GEVPUSHLISTOF 41345 . 42925) (GEVQUIT 42927 . 43133) ( GEVREDOPROPS 43135 . 43903) (GEVREFILLWINDOW 43905 . 44981) (GEVSHORTATOMVAL 44983 . 45348) ( GEVSHORTCONSVAL 45350 . 46152) (GEVSHORTLISTVAL 46154 . 47268) (GEVSHORTSTRINGVAL 47270 . 47575) ( GEVSHORTVALUE 47577 . 48852) (GEVUSERSTR 48854 . 49321) (GEVXTRTYPE 49323 . 50027))))) STOP ))) STOP