(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