% GEV Editor, PSL version. G. Novak 31 Jan. 1983
[GLISPGLOBALS
(GEVACTIVEFLG BOOLEAN )
(GEVCHARWIDTH INTEGER )
(GEVEDITCHAIN EDITCHAIN )
(GEVEDITFLG BOOLEAN )
(GEVMENUWINDOW WINDOW )
(GEVMENUWINDOWHEIGHT INTEGER )
(GEVMOUSEAREA MOUSESTATE )
(GEVSHORTCHARS INTEGER )
(GEVWINDOW WINDOW )
(GEVWINDOWY INTEGER )
]
[GLISPOBJECTS
(AREA
(LIST (START VECTOR)
(SIZE VECTOR))
PROP ((LEFT (START:X))
(BOTTOM (START:Y))
(RIGHT (LEFT+WIDTH))
(TOP (BOTTOM+HEIGHT))
(WIDTH (SIZE:X))
(HEIGHT (SIZE:Y))
(CENTER (START+SIZE/2))
(AREA (WIDTH*HEIGHT)))
ADJ ((EMPTY (WIDTH IS ZERO OR HEIGHT IS ZERO))
(ZERO (self IS EMPTY)))
MSG ((CONTAINS? REGION-CONTAINS OPEN T)) )
(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 = 8* (NCHARS NAME)
HEIGHT = 12))
VTYPE GLVTYPE4)
(VALUEAREA ((VIRTUAL REGION WITH START = VALUEPOS
WIDTH = 8* (NCHARS NAME)
HEIGHT = 12] )
(MOUSESTATE
(LIST (AREA AREA)
(ITEM GSEITEM)
(FLAG BOOLEAN)
(GROUP INTEGER)) )
(DOLPHINREGION
(RECORD REGION (LEFT INTEGER)
(BOTTOM INTEGER)
(WIDTH INTEGER)
(HEIGHT INTEGER)) )
(MENU
(RECORD MENU (ITEMS (LISTOF ATOM)))
MSG ((SELECT MENU RESULT ATOM)) )
(VECTOR
(LIST (X INTEGER)
(Y INTEGER))
PROP [(MAGNITUDE ((SQRT X^2 + Y^2)))
(ANGLE ((ARCTAN2 Y X T))
RESULT RADIANS)
(UNITVECTOR ((A RVECTOR WITH X = X/MAGNITUDE Y = Y/MAGNITUDE]
ADJ ((ZERO (X IS ZERO AND Y IS ZERO))
(NORMALIZED (MAGNITUDE = 1.0)))
MSG [(PRIN1 ((PRIN1 "(")
(PRIN1 X)
(PRIN1 ",")
(PRIN1 Y)
(PRIN1 ")")))
(PRINT ((_ self PRIN1)
(TERPRI] )
(WINDOW
ANYTHING
PROP ((REGION ((DSPCLIPPINGREGION NIL self))
RESULT DOLPHINREGION)
(XPOSITION ((DSPXPOSITION NIL self))
RESULT INTEGER)
(YPOSITION ((DSPYPOSITION NIL self))
RESULT INTEGER)
(HEIGHT (REGION:HEIGHT))
(WIDTH (REGION:WIDTH))
(LEFT ((DSPXOFFSET NIL self))
RESULT INTEGER)
(BOTTOM ((DSPYOFFSET NIL self))
RESULT INTEGER))
MSG ((CLEAR CLEARW)
(OPEN OPENW)
(CLOSE CLOSEW)) )
]
(DEFINEQ
(AREA-CONTAINS
(GLAMBDA (AREA P)
% edited: "26-OCT-82 11:45"
% Test whether an area contains a point P.
(P:X>=AREA:LEFT AND P:X<=AREA:RIGHT
AND P:Y>=AREA:BOTTOM AND P:Y<=AREA:TOP)))
(GEV
[NLAMBDA (VAR STR)
% edited: "12-OCT-82 14:19"
% GLISP Edit Value function.
% Edit VAL according to structure description STR.
(PROG (VAL)
(SETQ VAL (EVAL VAR))
(SETQ STR (EVAL STR))
(GEVA VAR VAL STR])
(GEVA
(GLAMBDA (VAR VAL STR)
% edited: "22-DEC-82 14:16"
% GLISP Edit Value function.
% Edit VAL according to structure description STR.
(PROG (GLNATOM TMP HEADER)
(OR (AND (BOUNDP (QUOTE GEVWINDOW))
GEVWINDOW)
(GEVINITEDITWINDOW))
(OPENW GEVMENUWINDOW)
(GEVACTIVEFLG_T)
(GEVEDITFLG_NIL)
(GLNATOM_0)
(GEVSHORTCHARS_27)
(GEVCHARWIDTH_7)
(IF VAR IS A LIST AND (CAR VAR)='QUOTE
THEN VAR_(CONCAT "'" (CADR VAR)))
(IF ~STR
THEN (IF VAL IS ATOMIC AND (GETPROP VAL (QUOTE GLSTRUCTURE))
THEN STR_'GLTYPE
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))))
(GEVBUTTONEVENTFN
[GLAMBDA NIL
% edited: "11-NOV-82 16:53"
% Respond to a button event within the editing window.
(PROG (POS SELECTION TMP TOP N)
(GETMOUSESTATE)
% Test the state of the left mouse button.
(IF (ZEROP (LOGAND LASTMOUSEBUTTONS 4))
THEN
% Button is now up.
(IF GEVMOUSEAREA
THEN (SELECTION_GEVMOUSEAREA)
(GEVMOUSEAREA_NIL)
(GEVINVERTENTRY SELECTION:AREA GEVWINDOW)
% Execute action.
(IF SELECTION:FLAG
THEN (IF SELECTION:GROUP=1
THEN (TMP_GEVEDITCHAIN:TOPFRAME:PREVS)
(N_0)
(WHILE TMP AND (TOP-_TMP)
<>SELECTION:ITEM
DO N_+1)
(GEVPOP NIL N)
ELSE (GEVPUSH SELECTION:ITEM))
ELSE (PRIN1 SELECTION:ITEM:NAME)
(PRIN1 " is ")
(PRINTDEF SELECTION:ITEM:TYPE (POSITION T))
(TERPRI))
(RETURN)
ELSE
% Button is now down.
(POS _(A VECTOR WITH X =(LASTMOUSEX GEVWINDOW)
Y =(LASTMOUSEY GEVWINDOW)))
(IF GEVMOUSEAREA
THEN (IF (_ GEVMOUSEAREA:AREA CONTAINS? POS)
THEN (RETURN)
ELSE
% Mouse has moved out of area with button down.
(SELECTION_GEVMOUSEAREA)
(GEVMOUSEAREA_NIL)
(GEVINVERTENTRY SELECTION:AREA GEVWINDOW)))
% Try to find an item at current mouse position.
(IF GEVMOUSEAREA _(GEVFINDPOS POS GEVEDITCHAIN:TOPFRAME)
THEN (GEVINVERTENTRY GEVMOUSEAREA:AREA GEVWINDOW])
(GEVCOMMANDFN
[GLAMBDA (COMMANDWORD:ATOM)
% edited: "11-NOV-82 16:20"
(PROG (PL SUBPL PROPNAME VAL PROPNAMES TOPITEM)
(CASE COMMANDWORD OF (EDIT (GEVEDIT))
(QUIT (IF GEVMOUSEAREA
THEN (GEVINVERTENTRY GEVMOUSEAREA:AREA GEVWINDOW)
(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)
% edited: "22-DEC-82 11:30"
(PROG (VAL 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 (CDR PROPNAMES)
THEN PROPNAMES+_'All)
PROPNAMES+_'self)
(IF ~PROPNAMES (RETURN))
[IF ~PROPNAME (PROPNAME _(MENU (create MENU
ITEMS _ PROPNAMES]
(IF ~PROPNAME (RETURN)
ELSEIF PROPNAME='self
THEN (PRIN1 PROPNAME)
(PRIN1 " = ")
(PRINT ITEM:VALUE)
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)
% edited: "22-DEC-82 11:09"
% 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 TYPE)
(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) 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]
(RETURN RESULT))))
(GEVCOMPPROP
[GLAMBDA (STR:GLTYPE PROPNAME,PROPTYPE:ATOM)
% edited: "22-DEC-82 11:17"
% 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 ~(MEMB PROPTYPE (QUOTE (ADJ ISA PROP MSG)))
(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 (ERROR
"GLISP compiler must be loaded for PROPs which
are not specified with function name equivalents."
(LIST STR PROPTYPE PROPNAME])
(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)
% edited: " 4-NOV-82 16:07"
% Get a flattened list of names and types from a given
% structure description.
(GLOBAL RESULT)
(PROG (TMP)
(IF STR IS ATOMIC
THEN (RETURN)
ELSE (CASE (CAR STR)
OF
(CONS (GEVDATANAMESB (CADR STR)
FILTER)
(GEVDATANAMESB (CADDR STR)
FILTER))
((ALIST PROPLIST LIST)
(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 (RETURN))
ELSE
[IF (GEVFILTER (CADR STR)
FILTER)
THEN (RESULT +_(LIST (CAR STR)
(CADR STR]
((GEVDATANAMESB (CADR STR)
FILTER])
(GEVDISPLAYNEWPROP
(GLAMBDA NIL
% edited: "14-OCT-82 15:35"
% Display a newly added property in the window.
(PROG (Y NEWONE:GSEITEM)
(Y_GEVWINDOWY)
(NEWONE_(CAR (LAST GEVEDITCHAIN:TOPFRAME:PROPS)))
(GEVPPS NEWONE 1 GEVWINDOW Y)
(GEVWINDOWY_Y))))
(GEVDOPROP
[GLAMBDA (ITEM:GSEITEM PROPNAME,COMMANDWORD:ATOM FLG:BOOLEAN)
% edited: "16-OCT-82 16:09"
% 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
% edited: "12-OCT-82 16:34"
% 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 (EDITV GEVTOPITEM:VALUE)
(CHANGEDFLG_T)
ELSE (RETURN))
(IF CHANGEDFLG
THEN (GEVREFILLWINDOW))
(GEVEDITFLG_CHANGEDFLG))))
(GEVEXPROP
[GLAMBDA (OBJ STR PROPNAME,PROPTYPE:ATOM ARGS)
% edited: " 4-NOV-82 15:10"
% 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)
(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)
ELSE (RETURN (APPLY FN (CONS OBJ ARGS])
(GEVFILLWINDOW
(GLAMBDA NIL
% edited: "14-OCT-82 15:23"
% Fill the GEV editor window with the item which is at
% the top of GEVEDITCHAIN.
(PROG (Y TOP)
(_ GEVWINDOW CLEAR)
% Compute an initial Y value for printing titles in the
% window.
(Y_GEVWINDOW:HEIGHT
- 20)
% Print the titles from the edit chain first.
(TOP_GEVEDITCHAIN:TOPFRAME)
(FOR X IN (REVERSE TOP:PREVS) DO (GEVPPS X 1 GEVWINDOW Y))
(GEVHORIZLINE GEVWINDOW)
(FOR X IN TOP:SUBITEMS DO (GEVPPS X 1 GEVWINDOW Y))
(GEVHORIZLINE GEVWINDOW)
(FOR X IN TOP:PROPS DO (GEVPPS X 1 GEVWINDOW Y))
(GEVWINDOWY_Y))))
(GEVFILTER
(GLAMBDA (TYPE FILTER)
% GSN "21-JAN-83 10:24"
% Filter types according to a specified FILTER.
(TYPE_(GEVXTRTYPE TYPE))
(CASE FILTER OF (NUMBER ~(MEMB TYPE (QUOTE (ATOM STRING 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])
(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,PROPTYPE:ATOM)
% edited: "14-OCT-82 12:50"
% 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 (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: "14-OCT-82 09:42"
(GLOBAL Y:INTEGER)
% Draw a horizontal line across window W at Y and decrease Y.
(DRAWLINE 1 Y+4 W:WIDTH Y+4 1 (QUOTE PAINT)
WINDOW)
(Y_-12)))
(GEVINIT
[LAMBDA NIL
% edited: "15-OCT-82 17:16"
(SETQ GLNATOM 0)
(SETQ GEVWINDOW NIL])
(GEVINITEDITWINDOW
[LAMBDA NIL
% edited: " 6-OCT-82 16:29"
% Initialize an edit window for the GLISP structure editor.
(PROG (GEVMENU (LEFT 600)
(BOTTOM 200)
(WIDTH 300)
(HEIGHT 400))
(SETQ GEVWINDOW
(CREATEW (create REGION
LEFT _ LEFT
BOTTOM _ BOTTOM
WIDTH _ WIDTH
HEIGHT _ HEIGHT)
"GEV Structure Editor Window"))
(SETQ GEVMOUSEAREA NIL)
(WINDOWPROP GEVWINDOW (QUOTE BUTTONEVENTFN)
(QUOTE GEVBUTTONEVENTFN))
(WINDOWPROP GEVWINDOW (QUOTE MOVEFN)
(QUOTE GEVMOVEWINDOWFN))
(SETQ GEVMENUWINDOWHEIGHT 40)
(SETQ GEVMENUWINDOW (CREATEW (create REGION
LEFT _ LEFT
BOTTOM _(IDIFFERENCE BOTTOM
GEVMENUWINDOWHEIGHT)
WIDTH _ WIDTH
HEIGHT _ GEVMENUWINDOWHEIGHT)
NIL 0))
(SETQ GEVMENU (create MENU
ITEMS _(QUOTE (QUIT POP EDIT PROGRAM PROP ADJ ISA MSG))
CENTERFLG _ T
MENUROWS _ 2
MENUFONT _(FONTCREATE (QUOTE HELVETICA)
10
(QUOTE BOLD))
ITEMHEIGHT _ 15
ITEMWIDTH _(IDIFFERENCE (IQUOTIENT WIDTH 4)
2)
WHENSELECTEDFN _(QUOTE GEVCOMMANDFN)))
(ADDMENU GEVMENU GEVMENUWINDOW)
(RETURN GEVWINDOW])
(GEVINVERTENTRY
(GLAMBDA (AREA:AREA WINDOW)
% edited: " 5-OCT-82 14:43"
% Invert the area of WINDOW which is covered by the specified AREA.
(BITBLT WINDOW AREA:LEFT AREA:BOTTOM WINDOW
AREA:LEFT AREA:BOTTOM AREA:WIDTH AREA:HEIGHT
(QUOTE INVERT)
(QUOTE REPLACE)
NIL NIL)))
(GEVLENGTHBOUND
[LAMBDA (VAL NCHARS)
% edited: "12-OCT-82 12:12"
% Bound the length of VAL to NCHARS.
(COND
((IGREATERP (NCHARS VAL)
NCHARS)
(CONCAT (SUBSTRING VAL 1 (SUB1 NCHARS))
"-"))
(T VAL])
(GEVMAKENEWFN
[GLAMBDA
[OPERATION,INPUTTYPE:ATOM SET:(LIST (NAME ATOM)
(TYPE GLTYPE))
PATH:(LISTOF (LIST (NAME ATOM)
(TYPE GLTYPE]
% edited: " 6-NOV-82 14:23"
% Make a function to perform OPERATION on set SETNAME
% from INPUTTYPE following PATH to get to the data.
(PROG (LASTPATH)
(SETQ LASTPATH (CAR (LAST PATH)))
(RETURN
(LIST [LIST (QUOTE GLAMBDA)
(LIST (MKATOM (CONCAT (QUOTE GEVNEWFNTOP)
":" INPUTTYPE)))
(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 (QUOTE GEVNEWFNTOP)
":" SET:NAME))
(QUOTE DO)
(LIST (QUOTE GEVNEWFNVALUE)
(QUOTE _)
(DREVERSE
(CONS (QUOTE GEVNEWFNLOOPVAR)
(MAPCONC PATH
(FUNCTION (LAMBDA (X)
(LIST (QUOTE OF)
(CAR X)
(QUOTE THE]
(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)
% edited: "22-DEC-82 15:26"
% 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 (X 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))
ELSE
(IF 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)
% edited: "22-DEC-82 10:04"
% Match the OBJECT structures.
(GLOBAL RESULT)
(PROG ((OBJECTTYPE (CAR STR))
TMP)
(RESULT _+(A GSEITEM WITH NAME =(QUOTE CLASS)
VALUE =[CASE OBJECTTYPE OF ((OBJECT LISTOBJECT)
(TMP-_VAL))
(ATOMOBJECT (GETPROP VAL (QUOTE CLASS]
TYPE =(QUOTE GLTYPE)))
(FOR X IN (CDR STR) DO (CASE OBJECTTYPE OF ((OBJECT 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: "21-DEC-82 17:32"
% Match a RECORD structure.
(PROG (STRNAME FIELDS)
(IF (CADR STR) IS ATOMIC
THEN STRNAME_(CADR STR)
FIELDS_(CDDR STR)
ELSE FIELDS_(CDR STR))
(FOR X IN FIELDS DO (GEVMATCHB X (RECORDACCESS (CAR X)
VAL NIL NIL STRNAME)
NIL NIL])
(GEVMOUSELOOP
(GLAMBDA NIL
% edited: "27-SEP-82 16:24"
% Wait in a loop for mouse actions within the edit
window.
(PROG NIL)))
(GEVMOVEWINDOWFN
[LAMBDA (W NEWPOS)
% edited: " 5-OCT-82 11:36"
(PROG NIL
(MOVEW GEVMENUWINDOW (CONS (CAR NEWPOS)
(IDIFFERENCE (CDR NEWPOS)
GEVMENUWINDOWHEIGHT])
(GEVPOP
(GLAMBDA (FLG:BOOLEAN N:INTEGER)
% GSN "21-JAN-83 13:50"
% 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))
(GEVMOUSELOOP))))
(GEVPOSTEST
(GLAMBDA (POS,TPOS:VECTOR NAME ITEM:GSEITEM FLG N:INTEGER)
% edited: "21-OCT-82 10:54"
(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+12 AND POS:X>=TPOS:X AND
POS:X<TPOS:X+100
THEN (A MOUSESTATE WITH AREA =
(AN AREA WITH START =(A VECTOR WITH X = TPOS:X Y =
TPOS:Y - 1)
SIZE =(A VECTOR WITH X = GEVCHARWIDTH*(NCHARS
NAME)
Y = 12))
ITEM = ITEM FLAG = FLG GROUP = N))))
(GEVPPS
[GLAMBDA (ITEM:GSEITEM COL:INTEGER WINDOW:WINDOW)
% GSN "21-JAN-83 10:25"
(GLOBAL Y:INTEGER)
% Pretty-print a structure defined by ITEM in the window WINDOW, beginning
% at horizontal column COL and vertical
% position Y. The positions in ITEM are modified to match the positions in
% the window.
(PROG (NAMEX VALX TOP)
% Make sure there is room in window.
(IF Y<0
THEN (RETURN))
% Position in window for slot name.
(NAMEX_COL*GEVCHARWIDTH)
(ITEM:NAMEPOS:X_NAMEX)
(ITEM:NAMEPOS:Y_Y)
(MOVETO NAMEX Y WINDOW)
(IF ITEM:NODETYPE='FULLVALUE
THEN (PRIN1 "(expanded)" WINDOW)
ELSEIF ITEM:NAME
THEN (IF ITEM:NAME IS NUMERIC
THEN (PRIN1 "#" WINDOW))
(PRIN1 (GEVLENGTHBOUND ITEM:NAME 11)
WINDOW))
% 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 (VALX_NAMEX+100)
(ITEM:VALUEPOS:X_VALX)
(ITEM:VALUEPOS:Y_Y)
(MOVETO VALX Y WINDOW)
(PRIN1 [ITEM:SHORTVALUE OR
(ITEM:SHORTVALUE _(GEVSHORTVALUE ITEM:VALUE
ITEM:TYPE
(GEVSHORTCHARS
- COL]
WINDOW)
(IF ~(EQ ITEM:SHORTVALUE ITEM:VALUE)
THEN (MOVETO (VALX - 20)
Y WINDOW)
(PRIN1 "~" WINDOW))
(Y_-12)
ELSEIF ITEM:NODETYPE='FULLVALUE
THEN (Y_-12)
(MOVETO 0 Y WINDOW)
(RESETLST (RESETSAVE SYSPRETTYFLG T)
(SHOWPRINT ITEM:VALUE WINDOW))
(Y_WINDOW:YPOSITION
- 12)
ELSEIF ITEM:NODETYPE='DISPLAY
THEN (GEVEXPROP ITEM:VALUE ITEM:TYPE (QUOTE GEVDISPLAY)
(QUOTE MSG)
(LIST WINDOW Y))
ELSE
% This is a subtree
Y_-12
(FOR VSUB IN ITEM:SUBVALUES DO (GEVPPS VSUB COL+2 WINDOW])
(GEVPROGRAM
(GLAMBDA NIL
% GSN "21-JAN-83 10:56"
% 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_(MENU (create MENU
ITEMS _(QUOTE (Quit COLLECT TOTAL AVERAGE MAXIMUM MINIMUM]
='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))
[CASE NEXT OF ((NIL 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
(PROGN (PATH+_NEXT)
(TYPE_(CADR NEXT))
(LAST_(CAR NEXT]
(IF (MEMB TYPE (QUOTE (ATOM INTEGER STRING REAL BOOLEAN NIL)))
DONE_T))
(IF ABORTFLG (RETURN))
(PATH_(DREVERSE PATH))
(NEWFN_(GEVMAKENEWFN COMMAND TOPITEM:TYPE SET (CDDR PATH)))
(PUTD (QUOTE GEVNEWFN)
(CAR NEWFN))
(RESULT_(GEVNEWFN TOPITEM:VALUE))
% Print result as well as displaying it.
(PRIN1 COMMAND)
(SPACES 1)
(FOR X IN (CDDR PATH) DO (PRIN1 (CAR X))
(SPACES 1))
(PRIN1 "OF ")
(PRIN1 (CAAR PATH))
(SPACES 1)
(PRIN1 (CAADR PATH))
(PRIN1 " = ")
(PRINT RESULT)
(GEVEDITCHAIN:TOPFRAME:PROPS_+(A GSEITEM WITH NAME
=(CONCAT COMMAND " " LAST)
TYPE =(CADR NEWFN)
VALUE = RESULT NODETYPE =(QUOTE MSG)))
(GEVDISPLAYNEWPROP))))
(GEVPROPMENU
[GLAMBDA (OBJ:GLTYPE FILTER:ATOM FLG:BOOLEAN)
% GSN "21-JAN-83 10:32"
% 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 MENU)
(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)
% edited: "22-DEC-82 14:52"
% 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_(GEVPROPTYPE! 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,PROPNAME,PROPTYPE:ATOM)
% edited: "22-DEC-82 13:56"
% 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])
(GEVPROPTYPE!
[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 "24-JAN-83 14:14"
% 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
~(GETPROP ITEM:TYPE (QUOTE GLSTRUCTURE))
THEN (CASE ITEM:TYPE OF
[(ATOM NUMBER REAL INTEGER STRING ANYTHING)
(IF ITEM:VALUE=ITEM:SHORTVALUE
THEN (RETURN)
ELSE (NEWITEMS_(LIST (A GSEITEM WITH
NAME = ITEM:NAME VALUE =
ITEM:VALUE SHORTVALUE = ITEM:SHORTVALUE
TYPE = ITEM:TYPE NODETYPE =(QUOTE
FULLVALUE]
ELSE
(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
~(CDR ITEM:VALUE)
THEN (LSTITEM_(CAADAR GEVEDITCHAIN))
(GEVPUSH (CAR LSTITEM:SUBVALUES))
(RETURN))
(GEVMOUSELOOP))))
(GEVPUSHLISTOF
[GLAMBDA (ITEM:GSEITEM FLG:BOOLEAN)
% edited: "16-OCT-82 15:15"
% 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 TOPFRAME N:INTEGER NROOM LST VALS:(LISTOF ANYTHING)
TMP)
% Compute the vertical room available in the window.
(IF ~ITEM:VALUE (RETURN))
(TOPFRAME_GEVEDITCHAIN:TOPFRAME)
(NROOM _(GEVWINDOW:HEIGHT - 50)/12 -(LENGTH TOPFRAME:PREVS))
% If there was a previous display of this list, insert
an ellipsis header.
(IF FLG
THEN (LST+_(A GSEITEM WITH SHORTVALUE = "(..." NODETYPE =(QUOTE BACKUP)))
(N_ITEM:NAME)
(ITEMTYPE_ITEM:TYPE)
(NROOM_-1)
(VALS_ITEM:SUBVALUES)
ELSE (N_1)
(ITEMTYPE_(CADR ITEM:TYPE))
(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 = ITEMTYPE NAME = N SUBVALUES = VALS)))
(RETURN (LIST (A GSEITEM WITH NAME = "expanded" TYPE = ITEMTYPE NODETYPE =(QUOTE
LISTOF)
SUBVALUES =(DREVERSE LST])
(GEVQUIT
(GLAMBDA NIL
% edited: "13-OCT-82 10:55"
(SETQ GEVACTIVEFLG NIL)
(_ GEVWINDOW CLOSE)
(_ 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
% edited: "14-OCT-82 12:46"
% 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)
(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: " 8-OCT-82 15:41"
(COND
((NUMBERP ATM)
(COND
((IGREATERP (NCHARS ATM)
NCHARS)
(GEVSHORTSTRINGVAL (MKSTRING ATM)
NCHARS))
(T ATM)))
((IGREATERP (NCHARS ATM)
NCHARS)
(CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS))
"-"))
(T ATM])
(GEVSHORTCONSVAL
[GLAMBDA (VAL STR NCHARS:INTEGER)
% edited: " 8-OCT-82 15:19"
% 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+_TMP)
(RES +_ " . ")
(NLEFT_-NC)
(TMP_(GEVSHORTVALUE (CDR VAL)
(CADDR STR)
NLEFT))
(NC_(NCHARS TMP))
(IF NC>NLEFT
THEN TMP_ "---" NC_3)
(RES+_TMP)
(RES+_ ")")
(RETURN (APPLY (FUNCTION CONCAT)
(DREVERSE RES])
(GEVSHORTLISTVAL
[GLAMBDA (VAL STR NCHARS:INTEGER)
% edited: " 6-NOV-82 15:01"
% 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+_TMP)
(NLEFT_-NC)
(VAL_(CDR VAL))
(RSTR_(CDR RSTR))
(IF VAL
THEN (RES+_ " ")
(NLEFT_-1]
(IF VAL
THEN (RES+_ "..."))
(RES+_ ")")
(RETURN (APPLY (FUNCTION CONCAT)
(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: " 6-NOV-82 14:37"
% 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)
(NEQ (SETQ TMP (GEVEXPROP VAL STR (QUOTE SHORTVALUE)
(QUOTE PROP)
NIL))
(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 STR NCHARS))
(T "---"])
(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])
(PICTURE-GEVDISPLAY
(GLAMBDA (PICTURE,WINDOW:WINDOW YMAX)
% edited: "14-OCT-82 14:12"
% Display PICTURE in (GLOBAL Y:INTEGER WINDOW within
YMAX.)
(PROG (PWD PHT NEWX NEWY)
(PHT_(MIN (YMAX - 20)
PICTURE:HEIGHT))
(PWD _(MIN (WINDOW:WIDTH - 20)
PICTURE:WIDTH))
(NEWX _(WINDOW:WIDTH - PWD)/2)
(NEWY _ YMAX - PHT - 10)
(MOVEW PICTURE (CONS 0 0))
% Also copy the picture onto the current window.
(BITBLT PICTURE 1 1 WINDOW NEWX NEWY PWD PHT (QUOTE INPUT)
(QUOTE REPLACE)
NIL NIL)
(MOVEW PICTURE (CONS (WINDOW:LEFT+NEWX)
(WINDOW:BOTTOM+NEWY)))
(Y _ NEWY - 12))))
(VECTOR-SHORTVALUE
(GLAMBDA (V:VECTOR)
% edited: " 7-OCT-82 12:58"
(CONCAT "(" (MKSTRING V:X)
","
(MKSTRING V:Y)
")")))
)
(RPAQQ GEVTYPENAMES (CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT))