Artifact 545799931f84566b193f24694309d6525e5456c4a302031b872b607a9d297ae2:
- File
psl-1983/3-1/glisp/gevt.sl
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 43040) [annotate] [blame] [check-ins using] [more...]
(fluid '(p)) (DE SUBSTRING (STRING FIRST LAST) (COND ((NOT (STRINGP STRING)) (SETQ STRING ( GEVSTRINGIFY STRING)))) (COND ((MINUSP FIRST) (SETQ FIRST (ADD1 (PLUS (ADD1 ( SIZE STRING)) FIRST))))) (COND ((MINUSP LAST) (SETQ LAST (ADD1 (PLUS (ADD1 ( SIZE STRING)) LAST))))) (SUBSEQ STRING (SUB1 FIRST) LAST)) (DE GEVSTRINGIFY (X) (COND ((STRINGP X) X) (T (BLDMSG "%p" X)))) (DE CONCATN (L) (COND ((NULL L) "") ((NULL (CDR L)) (GEVSTRINGIFY (CAR L))) ( T (CONCAT (GEVSTRINGIFY (CAR L)) (CONCATN (CDR L)))))) (DE CONCATLN (L) (COND ((NULL L) "") ((NULL (CDR L)) (GEVSTRINGIFY (EVAL ( CAR L)))) (T (CONCAT (GEVSTRINGIFY (EVAL (CAR L))) (CONCATLN (CDR L)))))) (DF CONCATL (CONCATLARG) (CONCATLN CONCATLARG)) (DE GEVCONCAT (L) (CONCATN L)) (DE DREVERSE (L) (REVERSIP L)) (DE MKATOM (S) (INTERN S)) (DE GEVPUTD (FN FORM) (PUT FN (QUOTE GLORIGINALEXPR) (CONS (QUOTE LAMBDA) ( CDR FORM))) (PUT FN (QUOTE GLCOMPILED) NIL) (REMD FN) (PUTD FN (QUOTE MACRO) ( QUOTE (LAMBDA (GLDGFORM) (GLHOOK GLDGFORM))))) (DE GEVAPPLY (FN ARGS) (COND ((AND (ATOM FN) (OR (NULL (GET FN (QUOTE GLCOMPILED))) (NOT (EQ (GETDDD FN) (GET FN (QUOTE GLCOMPILED)))))) (GLCC FN) ( APPLY FN ARGS)) (T (APPLY FN ARGS)))) (GLOBAL (QUOTE (TERMINAL))) (GLISPOBJECTS (TERMINAL ATOM MSG ((MOVETOXY TERMINAL-MOVETOXY) (PRINTCHAR TERMINAL-PRINTCHAR OPEN T) (PRINTSTRING TERMINAL-PRINTSTRING) (INVERTVIDEO ( NIL)) (NORMALVIDEO (NIL)) (GRAPHICSMODE (NIL)) (NORMALMODE (NIL)) (ERASEEOL (( PBOUT (CHAR ESC)) (PBOUT (CHAR K))))))) (GLISPGLOBALS (TERMINAL TERMINAL)) (GLISPCONSTANTS (BLANKCHAR 32 INTEGER) (HORIZONTALLINECHAR 45 INTEGER) ( HORIZONTALBARCHAR 95 INTEGER) (LVERTICALBARCHAR 124 INTEGER) ( RVERTICALBARCHAR 124 INTEGER) (ESCAPECHAR 27 INTEGER)) (DE TERMINAL-MOVETOXY (TERM X Y) (COND ((LESSP X 0) (SETQ X 0)) ((GREATERP X 79) (SETQ X 79))) (COND ((LESSP Y 0) (SETQ Y 0)) ((GREATERP Y 23) (SETQ Y 23))) (PROG (S) (SETQ S (CHAR ESC)) (PBOUT S)) (PROG (S) (SETQ S (CHAR Y)) ( PBOUT S)) (PROG (S) (SETQ S (DIFFERENCE 55 Y)) (PBOUT S)) (PROG (S) (SETQ S ( PLUS 32 X)) (RETURN (PBOUT S)))) (DE TERMINAL-PRINTCHAR (TERM S) (PBOUT S)) (DE TERMINAL-PRINTSTRING (TERM S) (PROG (I N) (COND ((NOT (STRINGP S)) (SETQ S (GEVSTRINGIFY S)))) (SETQ N (ADD1 (SIZE S))) (SETQ I 0) (PROG NIL GLLABEL1 ( COND ((LESSP I N) (PBOUT (INDX S I)) (SETQ I (ADD1 I)) (GO GLLABEL1)))))) (SETQ TERMINAL (QUOTE VT52)) (GLOBAL (QUOTE (MENUSTART))) (GLISPOBJECTS (MENU (LISTOBJECT (ITEMS (LISTOF ATOM)) (WINDOW WINDOW)) MSG (( SELECT MENU-SELECT RESULT ATOM))) (MOUSE ANYTHING) (WINDOW (LISTOBJECT ( START VECTOR) (SIZE VECTOR) (TITLE STRING) (LASTFILLEDLINE INTEGER)) PROP (( YPOSITION (LASTFILLEDLINE)) (LEFTMARGIN (1)) (RIGHTMARGIN (WIDTH !- 2))) MSG (( CLEAR WINDOW-CLEAR) (OPEN WINDOW-OPEN) (CLOSE WINDOW-CLOSE) (INVERTAREA WINDOW-INVERTAREA OPEN T) (MOVETOXY WINDOW-MOVETOXY OPEN T) (MOVETO WINDOW-MOVETO OPEN T) (PRINTAT WINDOW-PRINTAT OPEN T) (PRETTYPRINTAT WINDOW-PRETTYPRINTAT OPEN T) (UNPRINTAT WINDOW-UNPRINTAT OPEN T) (DRAWLINE WINDOW-DRAWLINE OPEN T) (UNDRAWLINE WINDOW-UNDRAWLINE OPEN T) (CENTEROFFSET WINDOW-CENTEROFFSET OPEN T)) SUPERS (REGION))) (GLISPGLOBALS (MOUSE MOUSE)) (GLISPCONSTANTS (WINDOWCHARWIDTH 1 INTEGER) (WINDOWLINEYSPACING 1 INTEGER)) (SETQ MOUSE (QUOTE MOUSE)) (SETQ GEVMENUWINDOW NIL) (SETQ MENUSTART (A VECTOR WITH X = 50 Y = 3)) (DE MENU-SELECT (M) (PROG (MAXW I N SAVEESC SAVEGLQ SAVEGCG RESULT) (COND (( NOT GEVACTIVEFLG) (GEVENTER))) (SETQ SAVEGLQ GLQUIETFLG) (SETQ GLQUIETFLG T) ( SETQ MAXW 0) (MAPC (CADR M) (FUNCTION (LAMBDA (X) (SETQ MAXW (MAX MAXW (PROG ( SELF) (SETQ SELF (ID2STRING X)) (RETURN (ADD1 (SIZE SELF))))))))) (COND (( GREATERP MAXW 20) (SETQ MAXW 20))) (RPLACA (CDDR M) (LIST (QUOTE WINDOW) MENUSTART (LIST (TIMES (PLUS MAXW 5) 1) (TIMES (MIN (ADD1 (LENGTH (CADR M))) 19) 1)) "Menu" 0)) (WINDOW-OPEN (CADDR M)) (SETQ I 0) (MAPC (CADR M) ( FUNCTION (LAMBDA (X) (SETQ I (ADD1 I)) (PROG (W S POS) (SETQ W (CADDR M)) ( SETQ S (CONCAT (GEVSTRINGIFY I) (CONCAT (COND ((LESSP I 10) " ") (T " ")) ( GEVSTRINGIFY X)))) (SETQ POS (LIST 1 (DIFFERENCE (PROG (SELF) (SETQ SELF ( CADDR M)) (RETURN (CADR (CADDR SELF)))) I))) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) (SETQ X (CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (TERMINAL-PRINTSTRING TERMINAL S) (TERPRI) (COND ((LESSP (CADR POS) (CAR (PNTH W 5))) (RPLACA ( PNTH W 5) (CADR POS)))))))))) (PROG (W) (SETQ W (CADDR M)) ( TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W)))) (PBOUT ( CHAR ESC)) (PBOUT (CHAR K)) LP (PROG (W) (SETQ W (CADDR M)) ( TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W)))) ( TERMINAL-PRINTSTRING TERMINAL "Menu: ") (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) ( ECHOON) (SETQ N (READ)) (ECHOOFF) (COND ((AND (FIXP N) (GREATERP N 0) (NOT ( GREATERP N (LENGTH (CADR M))))) (SETQ RESULT (CAR (PNTH (CADR M) N))) (GO OUT)) ((EQ N (QUOTE Q)) (SETQ RESULT NIL) (GO OUT)) (T (PRIN1 N) (SPACES 1) (TERMINAL-PRINTSTRING TERMINAL "?") (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) ( GO LP))) OUT (WINDOW-CLOSE (CADDR M)) (PROG (W) (SETQ W (CADDR M)) ( TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W)))) (TERPRI) ( PBOUT (CHAR ESC)) (PBOUT (CHAR K)) (SETQ GLQUIETFLG SAVEGLQ) (COND ((NOT GEVACTIVEFLG) (GEVEXIT))) (RETURN RESULT))) (DE PRINTNC (N C) (PROG NIL GLLABEL1 (COND ((GREATERP N 0) (SETQ N (SUB1 N)) ( PBOUT C) (GO GLLABEL1))))) (DE WINDOW-CLEAR (W) (PROG (TTL NBL Y NLINES) (SETQ NLINES 0) NIL (SETQ Y ( SUB1 (CADR (CADDR W)))) (PROG NIL GLLABEL1 (COND ((NOT (LESSP Y (CAR (PNTH W 5)))) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS Y (CADADR W))) ( PBOUT 124) (COND ((LESSP Y (PLUS (CADADR W) (CADR (CADDR W)))) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)))) (PROG (X) (SETQ X (SUB1 (CAADDR W))) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PBOUT 124) (COND ((GREATERP (SETQ NLINES (ADD1 NLINES)) 3) (TERPRI) (SETQ NLINES 0))) (SETQ Y (SUB1 Y)) (GO GLLABEL1)))) NIL (TERMINAL-MOVETOXY TERMINAL ( PLUS 0 (CAADR W)) (PLUS -1 (CADADR W))) (TERPRI) (RPLACA (PNTH W 5) (CADR ( CADDR W))) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W)))) ) (DE WINDOW-CLOSE (W) (PROG (Y NLINES) (SETQ Y (CADR (CADDR W))) (SETQ NLINES 0) (PROG NIL GLLABEL1 (COND ((NOT (LESSP Y 0)) (TERMINAL-MOVETOXY TERMINAL ( PLUS 0 (CAADR W)) (PLUS Y (CADADR W))) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) ( COND ((GREATERP (SETQ NLINES (ADD1 NLINES)) 8) (TERPRI) (SETQ NLINES 0))) ( SETQ Y (SUB1 Y)) (GO GLLABEL1)))) (TERPRI))) (DE WINDOW-DRAWLINE (W FROM TO) (COND ((EQN (CADR FROM) (CADR TO)) (PROG (X Y) (SETQ X (CAR FROM)) (SETQ Y (CADR FROM)) (TERMINAL-MOVETOXY TERMINAL ( PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PRINTNC (ADD1 (DIFFERENCE (CAR TO) ( CAR FROM))) 45) (COND ((LESSP (CADR FROM) (CAR (PNTH W 5))) (CAR (RPLACA ( PNTH W 5) (CADR FROM)))))))) (DE WINDOW-INVERTAREA (W AREA) NIL) (DE WINDOW-MOVETO (W POS) (PROG (X Y) (SETQ X (CAR POS)) (SETQ Y (CADR POS)) ( RETURN (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))))) (DE WINDOW-MOVETOXY (W X Y) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) ( PLUS Y (CADADR W)))) (DE WINDOW-OPEN (W) (PROG (TTL NBL L) (PROG (Y) (SETQ Y (CADR (CADDR W))) ( TERMINAL-MOVETOXY TERMINAL (PLUS 1 (CAADR W)) (PLUS Y (CADADR W)))) (SETQ TTL (OR (CADDDR W) " ")) (SETQ L (ADD1 (SIZE TTL))) NIL (COND ((GREATERP ( ADD1 (SIZE TTL)) (DIFFERENCE (CAADDR W) 2)) (SETQ TTL (SUBSTRING TTL 1 ( DIFFERENCE (CAADDR W) 2))))) (SETQ NBL (SUB1 (QUOTIENT (DIFFERENCE (CAADDR W) ( ADD1 (SIZE TTL))) 2))) (PRINTNC NBL 32) (TERMINAL-PRINTSTRING TERMINAL TTL) ( PRINTNC (DIFFERENCE (DIFFERENCE (DIFFERENCE (CAADDR W) (ADD1 (SIZE TTL))) NBL) 2) 32) NIL (TERPRI) NIL (RPLACA (PNTH W 5) 1) (PROG (Y) (SETQ Y (CADR ( CADDR W))) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS Y (CADADR W)))) (PBOUT 124) (PROG (X Y) (SETQ X (SUB1 (CAADDR W))) (SETQ Y (CADR (CADDR W))) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PBOUT 124) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS 0 (CADADR W))) ( PBOUT 124) (PRINTNC (DIFFERENCE (CAADDR W) 2) 95) (PBOUT 124) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) NIL (TERPRI) (WINDOW-CLEAR W) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR W)) (PLUS -1 (CADADR W))))) (DE WINDOW-PRETTYPRINTAT (W VALUE POSITION) (PROG (X Y) (SETQ X (CAR POSITION)) (SETQ Y (CADR POSITION)) (TERMINAL-MOVETOXY TERMINAL (PLUS X ( CAADR W)) (PLUS Y (CADADR W)))) (RESETLST (RESETSAVE SYSPRETTYFLG T) ( RESETSAVE TTYLINELENGTH (SUB1 (DIFFERENCE (CAADDR W) (CAR POSITION)))) ( SHOWPRINT VALUE) (CAR (RPLACA (PNTH W 5) 1)))) (DE WINDOW-PRINTAT (W S POS) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) ( SETQ X (CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X ( CAADR W)) (PLUS Y (CADADR W)))) (TERMINAL-PRINTSTRING TERMINAL S) (TERPRI) ( COND ((LESSP (CADR POS) (CAR (PNTH W 5))) (CAR (RPLACA (PNTH W 5) (CADR POS))))) ))) (DE WINDOW-UNDRAWLINE (W FROM TO) (COND ((EQN (CADR FROM) (CADR TO)) (PROG ( X Y) (SETQ X (CAR FROM)) (SETQ Y (CADR FROM)) (TERMINAL-MOVETOXY TERMINAL ( PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PRINTNC (ADD1 (DIFFERENCE (CAR TO) ( CAR FROM))) 32)))) (DE WINDOW-UNPRINTAT (W S POS) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) ( SETQ X (CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X ( CAADR W)) (PLUS Y (CADADR W)))) (PRINTNC (ADD1 (SIZE S)) 32)))) (FLUID (QUOTE (N))) (GLOBAL (QUOTE (GEVMENUWINDOW GEVSAVEESC GEVSAVEGLQUIET GEVSAVEGCGAG GEVMOUSEAREA GLQUIETFLG GLLISPDIALECT GEVTYPENAMES GLUSERSTRNAMES MOUSE TERMINAL))) (DE GEVENTER NIL (SETQ GEVSAVEGCGAG *GC) (SETQ *GC NIL) (SETQ GEVSAVEGLQUIET GLQUIETFLG) (SETQ GLQUIETFLG T) (ECHOOFF)) (DE GEVEXIT NIL (SETQ *GC GEVSAVEGCGAG) (SETQ GLQUIETFLG GEVSAVEGLQUIET) ( ECHOON)) (DE GEVINITEDITWINDOW NIL (PROG NIL (SETQ GEVWINDOW (LIST (QUOTE WINDOW) ( APPEND (QUOTE (0 3)) NIL) (APPEND (QUOTE (46 20)) NIL) "GEV Structure Inspector" 0)) (RETURN GEVWINDOW))) (DE GEVMOUSELOOP NIL (PROG (INP N TMP) LP (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR GEVWINDOW)) (PLUS -1 (CADADR GEVWINDOW))) (PBOUT (CHAR ESC)) (PBOUT ( CHAR K)) (TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR GEVWINDOW)) (PLUS -1 ( CADADR GEVWINDOW))) (TERMINAL-PRINTSTRING TERMINAL "GEV: ") (ECHOON) (SETQ INP (READ)) (ECHOOFF) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) (COND ((AND (EQUAL INP T) (NUMBERP (SETQ N (READ)))) (GEVNSELECT N NIL) (GO LP)) ((NUMBERP INP) ( GEVNSELECT INP T) (GO LP)) ((SETQ TMP (ASSOC INP (QUOTE ((Q QUIT) (POP POP) ( E EDIT) (PR PROGRAM) (P PROP) (A ADJ) (I ISA) (M MSG))))) (GEVCOMMANDFN ( CADR TMP)) (COND ((OR (EQ (CADR TMP) (QUOTE QUIT)) (NOT GEVACTIVEFLG)) ( TERMINAL-MOVETOXY TERMINAL (PLUS 0 (CAADR GEVWINDOW)) (PLUS -1 (CADADR GEVWINDOW))) (PBOUT (CHAR ESC)) (PBOUT (CHAR K)) (RETURN NIL)) (T (GO LP)))) (( EQ INP (QUOTE R)) (WINDOW-OPEN GEVWINDOW) (GEVFILLWINDOW) (GO LP)) (T (PRIN1 "? Quit POP Edit PRogram Prop Adj Isa Msg Redraw") (TERPRI) (GO LP))))) (DE GEVNSELECT (N FLAG) (PROG (L TOP SUBLIST GROUP ITEM) (SETQ GROUP 0) ( SETQ TOP (CAR GEVEDITCHAIN)) LP (COND ((NOT TOP) (RETURN NIL))) (SETQ SUBLIST (CAR TOP)) (SETQ TOP (CDR TOP)) (SETQ GROUP (ADD1 GROUP)) (COND (( AND (EQN GROUP 1) (NOT (LESSP (SETQ L (LENGTH SUBLIST)) N))) (SETQ ITEM (CAR ( PNTH SUBLIST (DIFFERENCE (ADD1 L) N))))) ((NOT (SETQ ITEM (GEVNTHITEM SUBLIST))) (GO LP))) (COND ((MEMQ (CAR (PNTH ITEM 5)) (QUOTE (STRUCTURE SUBTREE LISTOF))) (RETURN NIL)) (T (RETURN (GEVITEMEVENTFN ITEM GROUP FLAG)))))) (DE GEVNTHITEM (L) (PROG (TMP RES) (COND ((NOT (GREATERP N 0)) (ERROR 0 NIL)) (( NOT L) (RETURN NIL)) ((EQN N 1) (RETURN (CAR L))) (T (SETQ N (SUB1 N)) (SETQ TMP (CAR L)) (SETQ L (CDR L)) (COND ((AND (MEMQ (CAR (PNTH TMP 5)) (QUOTE ( STRUCTURE SUBTREE LISTOF))) (SETQ RES (GEVNTHITEM (CAR (PNTH TMP 6))))) ( RETURN RES)) (T (RETURN (GEVNTHITEM L)))))))) (GLISPCONSTANTS (GEVNUMBERCHARS 2 INTEGER) (GEVNUMBERPOS 1 INTEGER)) (SETQ GEVMENUWINDOW NIL) (SETQ GEVMOUSEAREA NIL) (FLUID (QUOTE (GLNATOM RESULT Y))) (GLOBAL (QUOTE (GEVACTIVEFLG GEVEDITCHAIN GEVEDITFLG GEVLASTITEMNUMBER GEVMENUWINDOW GEVMENUWINDOWHEIGHT GEVMOUSEAREA GEVSHORTCHARS GEVWINDOW GEVWINDOWY))) (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 (GEVNUMBERPOS !+ (IF GEVNUMBERCHARS > 0 THEN (GEVNUMBERCHARS !+ 1) *WINDOWCHARWIDTH ELSE 0)) INTEGER) (GEVTILDEPOS ( GEVNAMEPOS !+ (GEVNAMECHARS+1) *WINDOWCHARWIDTH) INTEGER) (GEVVALUEPOS ( GEVTILDEPOS !+ !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)))) (DF GEV (ARGS) (GEVA (CAR ARGS) (EVAL (CAR ARGS)) (AND (CDR ARGS) (COND ((OR ( NOT (ATOM (CADR ARGS))) (NOT (UNBOUNDP (CADR ARGS)))) (EVAL (CADR ARGS))) (T ( CADR ARGS)))))) (DE GEVA (VAR VAL STR) (PROG (GLNATOM TMP HEADER) (GEVENTER) (COND ((OR (NOT ( NOT (UNBOUNDP (QUOTE GEVWINDOW)))) (NULL GEVWINDOW)) (GEVINITEDITWINDOW))) ( COND (GEVMENUWINDOW (WINDOW-OPEN GEVMENUWINDOW))) (WINDOW-OPEN GEVWINDOW) ( SETQ GEVACTIVEFLG T) (SETQ GEVEDITFLG NIL) (SETQ GLNATOM 0) (SETQ GEVSHORTCHARS 27) (COND ((AND (PAIRP VAR) (EQ (CAR VAR) (QUOTE QUOTE))) ( SETQ VAR (CONCAT "'" (GEVSTRINGIFY (CADR VAR)))))) (COND ((NOT STR) (COND (( AND (ATOM VAL) (GET VAL (QUOTE GLSTRUCTURE))) (SETQ STR (QUOTE GLTYPE))) (( GEVGLISPP) (SETQ STR (GLCLASS VAL)))))) (SETQ HEADER (LIST VAR VAL STR NIL NIL NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL))) (SETQ GEVEDITCHAIN (LIST (LIST (LIST HEADER) NIL NIL))) (GEVREFILLWINDOW) ( GEVMOUSELOOP) (GEVEXIT))) (DE GEVCOMMANDFN (COMMANDWORD) (PROG (PL SUBPL PROPNAME VAL PROPNAMES TOPITEM) (CASEQ COMMANDWORD (EDIT (GEVEDIT)) (QUIT (COND (GEVMOUSEAREA (PROG ( AREA) (SETQ AREA (CAR GEVMOUSEAREA))) (SETQ GEVMOUSEAREA NIL)) (T (GEVQUIT)))) ( POP (GEVPOP T 1)) (PROGRAM (GEVPROGRAM)) ((PROP ADJ ISA MSG) (SETQ TOPITEM ( CAAAR GEVEDITCHAIN)) (GEVCOMMANDPROP TOPITEM COMMANDWORD NIL)) (T (ERROR 0 NIL))))) (DE GEVCOMMANDPROP (ITEM COMMANDWORD PROPNAME) (PROG (VAL PROPNAMES FLG) ( COND (PROPNAME (SETQ FLG T))) (COND ((ATOM (CADDR ITEM)) (SETQ PROPNAMES ( GEVCOMMANDPROPNAMES (CADDR ITEM) COMMANDWORD (CAR GEVEDITCHAIN))))) (COND (( OR (ATOM (CADDR ITEM)) (EQ COMMANDWORD (QUOTE PROP))) (COND ((EQ COMMANDWORD ( QUOTE PROP)) (COND ((CDR PROPNAMES) (SETQ PROPNAMES (CONS (QUOTE ALL) PROPNAMES)))) (SETQ PROPNAMES (CONS (QUOTE SELF) PROPNAMES)))) (COND ((NOT PROPNAMES) (RETURN NIL))) (COND ((NOT PROPNAME) (SETQ PROPNAME (MENU-SELECT ( LIST (QUOTE MENU) PROPNAMES (COPY (QUOTE (WINDOW (0 0) (0 0) NIL 0)))))))) ( COND ((NOT PROPNAME) (RETURN NIL)) ((EQ PROPNAME (QUOTE SELF)) (PRIN1 PROPNAME) (PRINC " = ") (PRINT (CADR ITEM))) ((AND (EQ COMMANDWORD (QUOTE PROP)) (EQ PROPNAME (QUOTE ALL))) (MAPC (OR (CDDR PROPNAMES) (CDR PROPNAMES)) ( FUNCTION (LAMBDA (X) (GEVDOPROP ITEM X COMMANDWORD FLG))))) (T (GEVDOPROP ITEM PROPNAME COMMANDWORD FLG))) (COND ((EQ COMMANDWORD (QUOTE MSG)) ( GEVREFILLWINDOW) (SETQ GEVEDITFLG T))))))) (DE GEVCOMMANDPROPNAMES (OBJ PROPTYPE TOPFRAME) (PROG (RESULT TYPE) (SETQ RESULT (MAPCAN (CASEQ PROPTYPE (PROP (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE PROP))) (ADJ (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE ADJ))) (ISA (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE ISA))) ( MSG (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE MSG)))) (FUNCTION ( LAMBDA (P) (AND (NOT (AND (NE PROPTYPE (QUOTE MSG)) (CAR (SOME (CADDR TOPFRAME) (FUNCTION (LAMBDA (GLVAR1) (EQ (CAR GLVAR1) (CAR P)))))))) (NOT ( AND (EQ PROPTYPE (QUOTE PROP)) (MEMQ (CAR P) (QUOTE (SHORTVALUE DISPLAYPROPS)))) ) (NOT (AND (EQ PROPTYPE (QUOTE MSG)) (ATOM (CADR P)) (OR (NOT (GETDDD (CADR P))) (GREATERP (LENGTH (CADR (GETDDD (CADR P)))) 1)))) (CONS (CAR P) NIL)))))) ( MAPC (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE SUPERS)) (FUNCTION ( LAMBDA (S) (SETQ RESULT (NCONC RESULT (GEVCOMMANDPROPNAMES S PROPTYPE TOPFRAME)))))) (RETURN RESULT))) (DE GEVCOMPPROP (STR PROPNAME PROPTYPE) (PROG (PROPENT) (COND ((NOT (MEMQ PROPTYPE (QUOTE (ADJ ISA PROP MSG)))) (RETURN (QUOTE GEVERROR)))) (COND (( AND (SETQ PROPENT (GEVGETPROP STR PROPNAME PROPTYPE)) (ATOM (CADR PROPENT))) ( RETURN (CADR PROPENT)))) (RETURN (COND ((GEVGLISPP) (OR (GLCOMPPROP STR PROPNAME PROPTYPE) (QUOTE GEVERROR))) (T (ERROR 0 (LIST "GLISP compiler must be loaded for PROPs which" "are not specified with function name equivalents." STR PROPTYPE PROPNAME))))))) (DE GEVDATANAMES (OBJ FILTER) (PROG (RESULT) (GEVDATANAMESB (CAR (GET OBJ ( QUOTE GLSTRUCTURE))) FILTER) (RETURN (REVERSIP RESULT)))) (DE GEVDATANAMESB (STR FILTER) (PROG (TMP) (COND ((ATOM STR) (RETURN NIL)) ( T (CASEQ (CAR STR) (CONS (GEVDATANAMESB (CADR STR) FILTER) (GEVDATANAMESB ( CADDR STR) FILTER)) ((ALIST PROPLIST LIST) (MAPC (CDR STR) (FUNCTION (LAMBDA ( X) (GEVDATANAMESB X FILTER))))) (RECORD (MAPC (CDDR STR) (FUNCTION (LAMBDA ( X) (GEVDATANAMESB X FILTER))))) (ATOM (GEVDATANAMESB (CADR STR) FILTER) ( GEVDATANAMESB (CADDR STR) FILTER)) (BINDING (GEVDATANAMESB (CADR STR) FILTER)) ( LISTOF (RETURN NIL)) (T (COND ((GEVFILTER (CADR STR) FILTER) (SETQ RESULT ( CONS (LIST (CAR STR) (CADR STR)) RESULT)))) (GEVDATANAMESB (CADR STR) FILTER)))) ))) (DE GEVDISPLAYNEWPROP NIL (PROG (Y NEWONE) (SETQ Y GEVWINDOWY) (SETQ NEWONE ( CAR (LASTPAIR (CADDAR GEVEDITCHAIN)))) (GEVPPS NEWONE 0 GEVWINDOW) (SETQ GEVWINDOWY Y))) (DE GEVDOPROP (ITEM PROPNAME COMMANDWORD FLG) (PROG (VAL) (SETQ VAL ( GEVEXPROP (CADR ITEM) (CADDR ITEM) PROPNAME COMMANDWORD NIL)) (RPLACA (CDDAR GEVEDITCHAIN) (ACONC (CADDAR GEVEDITCHAIN) (LIST PROPNAME VAL (GEVPROPTYPE ( CADDR ITEM) PROPNAME COMMANDWORD) NIL COMMANDWORD NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))) (COND ((NOT FLG) (GEVDISPLAYNEWPROP))))) (DE GEVEDIT NIL (PROG (CHANGEDFLG GEVTOPITEM) (SETQ GEVTOPITEM (CAAAR GEVEDITCHAIN)) (COND ((AND (ATOM (CADDR GEVTOPITEM)) (NE (GEVEXPROP (CADR GEVTOPITEM) (CADDR GEVTOPITEM) (QUOTE EDIT) (QUOTE MSG) NIL) (QUOTE GEVERROR))) (SETQ CHANGEDFLG T)) ((PAIRP (CADR GEVTOPITEM)) (EDITV (CADR GEVTOPITEM)) ( SETQ CHANGEDFLG T)) (T (RETURN NIL))) (COND (CHANGEDFLG (WINDOW-OPEN GEVWINDOW) (GEVREFILLWINDOW))) (SETQ GEVEDITFLG CHANGEDFLG))) (DE GEVEXPROP (OBJ STR PROPNAME PROPTYPE ARGS) (PROG (FN) (COND ((OR (NOT ( MEMQ PROPTYPE (QUOTE (ADJ ISA PROP MSG)))) (AND ARGS (NE PROPTYPE (QUOTE MSG)))) (RETURN (QUOTE GEVERROR)))) (COND ((EQ (SETQ FN (GEVCOMPPROP STR PROPNAME PROPTYPE)) (QUOTE GEVERROR)) (RETURN FN)) (T (RETURN (GEVAPPLY FN (CONS OBJ ARGS))))))) (DE GEVFILLWINDOW NIL (PROG (Y TOP) (WINDOW-CLEAR GEVWINDOW) (SETQ Y (SUB1 ( CADR (CADDR GEVWINDOW)))) (SETQ GEVLASTITEMNUMBER 0) (SETQ TOP (CAR GEVEDITCHAIN)) (MAPC (REVERSE (CAR TOP)) (FUNCTION (LAMBDA (X) (GEVPPS X 0 GEVWINDOW)))) (GEVHORIZLINE GEVWINDOW) (MAPC (CADR TOP) (FUNCTION (LAMBDA ( X) (GEVPPS X 0 GEVWINDOW)))) (GEVHORIZLINE GEVWINDOW) (MAPC (CADDR TOP) ( FUNCTION (LAMBDA (X) (GEVPPS X 0 GEVWINDOW)))) (SETQ GEVWINDOWY Y))) (DE GEVFILTER (TYPE FILTER) (SETQ TYPE (GEVXTRTYPE TYPE)) (CASEQ FILTER ( NUMBER (AND (NOT (MEMQ TYPE (QUOTE (ATOM STRING BOOLEAN ANYTHING)))) (NOT ( AND (PAIRP TYPE) (EQ (CAR TYPE) (QUOTE LISTOF)))))) (LIST (AND (PAIRP TYPE) ( EQ (CAR TYPE) (QUOTE LISTOF)))) (T T))) (DE GEVFINDITEMPOS (POS ITEM N) (OR (GEVPOSTEST POS (CAR (PNTH ITEM 7)) (CAR ITEM) ITEM NIL N) (GEVPOSTEST POS (CAR (PNTH ITEM 8)) (CADDDR ITEM) ITEM T N) ( AND (OR (EQ (CAR (PNTH ITEM 5)) (QUOTE STRUCTURE)) (EQ (CAR (PNTH ITEM 5)) (QUOTE SUBTREE)) (EQ (CAR (PNTH ITEM 5)) (QUOTE LISTOF))) ( GEVFINDLISTPOS POS (CAR (PNTH ITEM 6)) N)))) (DE GEVFINDLISTPOS (POS ITEMS N) (COND (ITEMS (OR (GEVFINDITEMPOS POS (CAR ITEMS) N) (GEVFINDLISTPOS POS (CDR ITEMS) N))))) (DE GEVFINDPOS (POS FRAME) (PROG (TMP N ITEMS) (SETQ N 0) (PROG NIL GLLABEL1 ( COND ((AND FRAME (NOT TMP)) (SETQ N (ADD1 N)) (SETQ ITEMS (CAR FRAME)) (SETQ FRAME (CDR FRAME)) (SETQ TMP (GEVFINDLISTPOS POS ITEMS N)) (GO GLLABEL1)))) ( RETURN TMP))) (DE GEVGETNAMES (OBJ FILTER) (PROG (DATANAMES PROPNAMES) (SETQ DATANAMES ( GEVDATANAMES OBJ FILTER)) (SETQ PROPNAMES (GEVPROPNAMES OBJ (QUOTE PROP) FILTER)) (RETURN (NCONC DATANAMES PROPNAMES)))) (DE GEVGETPROP (STR PROPNAME PROPTYPE) (PROG (PL SUBPL PROPENT) (COND ((NOT ( MEMQ PROPTYPE (QUOTE (ADJ ISA PROP MSG)))) (ERROR 0 NIL))) (RETURN (AND ( SETQ PL (GET STR (QUOTE GLSTRUCTURE))) (SETQ SUBPL (LISTGET (CDR PL) PROPTYPE)) (SETQ PROPENT (ASSOC PROPNAME SUBPL)))))) (DE GEVGLISPP NIL (NOT (UNBOUNDP (QUOTE GLBASICTYPES)))) (DE GEVHORIZLINE (W) (PROG (FROM TO) (SETQ FROM (LIST 1 (PLUS Y 0))) (SETQ TO (LIST (DIFFERENCE (CAADDR W) 2) (PLUS Y 0))) (COND ((EQN (CADR FROM) ( CADR TO)) (PROG (X Y) (SETQ X (CAR FROM)) (SETQ Y (CADR FROM)) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR W)) (PLUS Y (CADADR W)))) (PRINTNC ( ADD1 (DIFFERENCE (CAR TO) (CAR FROM))) 45) (COND ((LESSP (CADR FROM) (CAR ( PNTH W 5))) (RPLACA (PNTH W 5) (CADR FROM))))))) (SETQ Y (SUB1 Y))) (DE GEVINIT NIL (SETQ GLNATOM 0) (COND ((NOT (NOT (UNBOUNDP (QUOTE GLLISPDIALECT)))) (SETQ GLLISPDIALECT (QUOTE INTERLISP)))) (SETQ GEVWINDOW NIL)) (DE GEVITEMEVENTFN (ITEM GROUP FLAG) (PROG (TMP TOP N) (COND (FLAG (COND (( EQN GROUP 1) (SETQ TMP (CAAR GEVEDITCHAIN)) (SETQ N 0) (PROG NIL GLLABEL1 ( COND ((AND TMP (NOT (EQUAL (PROG1 (SETQ TOP (CAR TMP)) (SETQ TMP (CDR TMP))) ITEM))) (SETQ N (ADD1 N)) (GO GLLABEL1)))) (GEVPOP NIL N)) (T (GEVPUSH ITEM)))) (T (PRIN1 (CAR ITEM)) (PRINC " is ") (PRIN1 (CADDR ITEM)) (TERPRI))))) (DE GEVLENGTHBOUND (VAL NCHARS) (COND ((GREATERP (FLATSIZE2 VAL) NCHARS) ( CONCAT (SUBSTRING VAL 1 (SUB1 NCHARS)) "-")) (T VAL))) (DE GEVMAKENEWFN (OPERATION INPUTTYPE SET PATH) (PROG (LASTPATH VIEWSPEC) ( SETQ LASTPATH (CAR (LASTPAIR PATH))) (RETURN (LIST (LIST (QUOTE GLAMBDA) ( LIST (MKATOM (CONCAT "GEVNEWFNTOP:" (ID2STRING INPUTTYPE)))) (LIST (QUOTE PROG) (CONS (QUOTE GEVNEWFNVALUE) (CASEQ OPERATION (COLLECT (QUOTE ( GEVNEWFNRESULT))) ((MAXIMUM MINIMUM) (QUOTE (GEVNEWFNTESTVAL GEVNEWFNINSTANCE))) (TOTAL (QUOTE ((GEVNEWFNSUM 0)))) (AVERAGE (QUOTE (( GEVNEWFNSUM 0.0) (GEVNEWFNCOUNT 0)))) (T (ERROR 0 NIL)))) (NCONC (LIST ( QUOTE FOR) (QUOTE GEVNEWFNLOOPVAR) (QUOTE IN) (MKATOM (CONCAT "GEVNEWFNTOP:" ( ID2STRING (CAR SET)))) (QUOTE DO) (LIST (QUOTE GEVNEWFNVALUE) (QUOTE _) ( PROGN (SETQ VIEWSPEC (LIST (QUOTE GEVNEWFNLOOPVAR))) (MAPC PATH (FUNCTION ( LAMBDA (X) (SETQ VIEWSPEC (CONS (QUOTE OF) VIEWSPEC)) (SETQ VIEWSPEC (CONS ( CAR X) VIEWSPEC)) (SETQ VIEWSPEC (CONS (QUOTE THE) VIEWSPEC))))) VIEWSPEC))) ( COPY (CASEQ OPERATION (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) ( CASEQ OPERATION (COLLECT (QUOTE (DREVERSE GEVNEWFNRESULT))) ((MAXIMUM MINIMUM) (QUOTE (LIST GEVNEWFNTESTVAL GEVNEWFNINSTANCE))) (AVERAGE (QUOTE ( QUOTIENT GEVNEWFNSUM (FLOAT GEVNEWFNCOUNT)))) (TOTAL (QUOTE GEVNEWFNSUM)))))) ( CASEQ OPERATION (COLLECT (LIST (QUOTE LISTOF) (CADR LASTPATH))) ((MAXIMUM MINIMUM) (LIST (QUOTE LIST) (COPY LASTPATH) (LIST (QUOTE WINNER) (CADADR SET)))) (AVERAGE (QUOTE REAL)) (TOTAL (CADR LASTPATH))))))) (DE GEVMATCH (STR VAL FLG) (PROG (RESULT) (GEVMATCHB STR VAL NIL FLG) ( RETURN (REVERSIP RESULT)))) (DE GEVMATCHA (STR VAL FLG) (PROG (RES) (SETQ RES (GEVMATCH STR VAL FLG)) ( COND ((NOT (CDR RES)) (RETURN (CAR RES))) (T (RETURN (LIST NIL VAL STR NIL ( QUOTE SUBTREE) RES (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL))))))) (DE GEVMATCHATOM (STR VAL NAME) (PROG (L STRB TMP) (COND ((OR (NOT (ATOM VAL)) ( NULL VAL)) (RETURN NIL))) (SETQ STRB (CADR STR)) (COND ((NE (CAR STRB) ( QUOTE PROPLIST)) (RETURN NIL))) (SETQ L (CDR STRB)) (MAPC L (FUNCTION ( LAMBDA (X) (COND ((SETQ TMP (GET VAL (CAR X))) (GEVMATCHB X TMP NIL NIL)))))))) (DE GEVMATCHALIST (STR VAL NAME) (PROG (L TMP) (SETQ L (CDR STR)) (MAPC L ( FUNCTION (LAMBDA (X) (COND ((SETQ TMP (ASSOC (CAR X) VAL)) (GEVMATCHB X (CDR TMP) NIL NIL)))))))) (DE GEVMATCHB (STR VAL NAME FLG) (PROG (X Y STRB XSTR TOP TMP) (SETQ XSTR ( GEVXTRTYPE STR)) (COND ((ATOM STR) (COND ((AND FLG (SETQ STRB (CAR (GET STR ( QUOTE GLSTRUCTURE))))) (SETQ RESULT (CONS (LIST NAME VAL STR NIL (QUOTE STRUCTURE) (GEVMATCH STRB VAL NIL) (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE ( 0 0)) NIL)) RESULT))) (T (SETQ RESULT (CONS (LIST NAME VAL STR NIL NIL NIL ( APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) RESULT)))) (RETURN NIL)) ( T (CASEQ (CAR STR) (CONS (GEVMATCHB (CADR STR) (CAR VAL) NIL NIL) (GEVMATCHB ( CADDR STR) (CDR VAL) NIL NIL)) (LIST (MAPC (CDR STR) (FUNCTION (LAMBDA (X) ( COND (VAL (GEVMATCHB X (CAR VAL) NIL NIL) (SETQ 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)) (T (COND (NAME (SETQ TMP (GEVMATCH STR VAL NIL)) ( SETQ TOP (CAR TMP)) (SETQ RESULT (CONS (COND ((AND (NOT (CDR TMP)) (NOT (CAR TOP))) (RPLACA TOP NAME) TOP) (T (LIST NAME VAL XSTR NIL (QUOTE SUBTREE) TMP ( APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))) RESULT))) ((ATOM ( SETQ STRB (GEVXTRTYPE (CADR STR)))) (GEVMATCHB STRB VAL (CAR STR) NIL)) (( SETQ TMP (GEVMATCH (CADR STR) VAL NIL)) (SETQ TOP (CAR TMP)) (SETQ RESULT ( CONS (COND ((AND (NOT (CDR TMP)) (NOT (CAR TOP))) (RPLACA TOP (CAR STR)) TOP) ( T (LIST (CAR STR) VAL (CADR STR) NIL (QUOTE SUBTREE) TMP (APPEND (QUOTE ( 0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))) RESULT))) (T (PRINT "GEVMATCHB Failed") )))))))) (DE GEVMATCHLISTOF (STR VAL NAME) (SETQ RESULT (CONS (LIST NAME VAL STR NIL NIL NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) RESULT))) (DE GEVMATCHOBJECT (STR VAL NAME) (PROG (OBJECTTYPE TMP) (SETQ OBJECTTYPE ( CAR STR)) (SETQ RESULT (ACONC RESULT (LIST (QUOTE CLASS) (CASEQ OBJECTTYPE (( OBJECT LISTOBJECT) (PROG1 (SETQ TMP (CAR VAL)) (SETQ VAL (CDR VAL)))) ( ATOMOBJECT (GET VAL (QUOTE CLASS)))) (QUOTE GLTYPE) NIL NIL NIL (APPEND ( QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))) (MAPC (CDR STR) (FUNCTION ( LAMBDA (X) (CASEQ OBJECTTYPE ((OBJECT LISTOBJECT) (COND (VAL (GEVMATCHB X ( PROG1 (SETQ TMP (CAR VAL)) (SETQ VAL (CDR VAL))) NIL NIL)))) (ATOMOBJECT ( COND ((SETQ TMP (GET VAL (CAR X))) (GEVMATCHB X TMP NIL NIL)))))))))) (DE GEVMATCHPROPLIST (STR VAL NAME) (PROG (L TMP) (SETQ L (CDR STR)) (MAPC L ( FUNCTION (LAMBDA (X) (COND ((SETQ TMP (LISTGET VAL (CAR X))) (GEVMATCHB X TMP NIL NIL)))))))) (DE GEVMATCHRECORD (STR VAL NAME) (PROG (STRNAME FIELDS N) (COND ((ATOM ( CADR STR)) (SETQ STRNAME (CADR STR)) (SETQ FIELDS (CDDR STR))) (T (SETQ FIELDS (CDR STR)))) (SETQ N 0) (MAPC FIELDS (FUNCTION (LAMBDA (X) (SETQ N ( ADD1 N)) (GEVMATCHB X (GETV VAL N) (CAR X) NIL)))))) (DE GEVPOP (FLG N) (PROG (TMP TOP TMPITEM) (COND ((LESSP N 1) (RETURN NIL))) LP (SETQ TMP (CAR GEVEDITCHAIN)) (SETQ GEVEDITCHAIN (CDR GEVEDITCHAIN)) ( COND ((NOT GEVEDITCHAIN) (RETURN (GEVQUIT)))) (SETQ TOP (CAAAR GEVEDITCHAIN)) ( SETQ TMPITEM (CAAR TMP)) (COND ((AND FLG (EQ (CAR (PNTH TMPITEM 5)) (QUOTE FORWARD))) (GO LP))) (COND ((GREATERP (SETQ N (SUB1 N)) 0) (GO LP))) (COND (( AND (PAIRP (CADDR TOP)) (EQ (CAADDR TOP) (QUOTE LISTOF)) (NOT (CDADR TOP))) ( GO LP))) (COND ((AND GEVEDITFLG (NOT (MEMBER (CADDDR TMPITEM) (QUOTE ("(...)" "---"))))) (GEVREFILLWINDOW)) (T (SETQ GEVEDITFLG NIL) (GEVFILLWINDOW))))) (DE GEVPOSTEST (POS TPOS NAME ITEM FLG N) (COND ((AND (NOT (LESSP (CADR POS) ( CADR TPOS))) (NOT (GREATERP (CADR POS) (ADD1 (CADR TPOS)))) (NOT (LESSP (CAR POS) (CAR TPOS))) (LESSP (CAR POS) (PLUS (CAR TPOS) 11))) (LIST (LIST (LIST ( CAR TPOS) (SUB1 (CADR TPOS))) (LIST (TIMES 1 (ADD1 (SIZE NAME))) 1)) ITEM FLG N)))) (DE GEVPPS (ITEM COL WINDOW) (PROG (NAMEX TOP) (COND ((LESSP Y 0) (RETURN NIL))) (SETQ GEVLASTITEMNUMBER (ADD1 GEVLASTITEMNUMBER)) (PROG (S POS) (SETQ S (GEVSTRINGIFY GEVLASTITEMNUMBER)) (SETQ POS (LIST 1 Y)) (COND ((GREATERP ( CADR POS) 0) (PROG (X Y) (SETQ X (CAR POS)) (SETQ Y (CADR POS)) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) ( TERMINAL-PRINTSTRING TERMINAL S) (TERPRI) (COND ((LESSP (CADR POS) (CAR ( PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))) (SETQ NAMEX (PLUS 4 (TIMES COL 1))) (RPLACA (CAR (PNTH ITEM 7)) NAMEX) (RPLACA (CDAR (PNTH ITEM 7)) Y) (COND ((EQ (CAR (PNTH ITEM 5)) (QUOTE FULLVALUE)) (PROG (POS) ( SETQ POS (LIST NAMEX Y)) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) (SETQ X ( CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) (TERMINAL-PRINTSTRING TERMINAL "(expanded)") (TERPRI) (COND ((LESSP (CADR POS) (CAR (PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS)))))))) ((CAR ITEM) (COND ((NUMBERP (CAR ITEM)) (PROG ( POS) (SETQ POS (LIST NAMEX Y)) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) ( SETQ X (CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X ( CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) (TERMINAL-PRINTSTRING TERMINAL "#") ( TERPRI) (COND ((LESSP (CADR POS) (CAR (PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))) (SETQ NAMEX (ADD1 NAMEX)))) (PROG (S POS) (SETQ S ( GEVLENGTHBOUND (CAR ITEM) 11)) (SETQ POS (LIST NAMEX Y)) (COND ((GREATERP ( CADR POS) 0) (PROG (X Y) (SETQ X (CAR POS)) (SETQ Y (CADR POS)) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) ( TERMINAL-PRINTSTRING TERMINAL S) (TERPRI) (COND ((LESSP (CADR POS) (CAR ( PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))))) (COND ((OR (NOT ( CAR (PNTH ITEM 5))) (MEMQ (CAR (PNTH ITEM 5)) (QUOTE (FORWARD BACKUP PROP ADJ MSG ISA)))) (RPLACA (CAR (PNTH ITEM 8)) 18) (RPLACA (CDAR (PNTH ITEM 8)) Y) (PROG (S POS) (SETQ S (OR (CADDDR ITEM) (CAR (RPLACA (CDDDR ITEM) ( GEVSHORTVALUE (CADR ITEM) (CADDR ITEM) (DIFFERENCE GEVSHORTCHARS COL)))))) ( SETQ POS (LIST 18 Y)) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) (SETQ X ( CAR POS)) (SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) (TERMINAL-PRINTSTRING TERMINAL S) ( TERPRI) (COND ((LESSP (CADR POS) (CAR (PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))) (COND ((NE (CADDDR ITEM) (CADR ITEM)) (PROG (POS) (SETQ POS (LIST 16 Y)) (COND ((GREATERP (CADR POS) 0) (PROG (X Y) (SETQ X (CAR POS)) ( SETQ Y (CADR POS)) (TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) (TERMINAL-PRINTSTRING TERMINAL "~") (TERPRI) (COND (( LESSP (CADR POS) (CAR (PNTH WINDOW 5))) (RPLACA (PNTH WINDOW 5) (CADR POS))))))) )) (SETQ Y (SUB1 Y))) ((EQ (CAR (PNTH ITEM 5)) (QUOTE FULLVALUE)) (SETQ Y ( SUB1 Y)) (PROG (VALUE POSITION) (SETQ VALUE (CADR ITEM)) (SETQ POSITION ( LIST 1 Y)) (PROG (X Y) (SETQ X (CAR POSITION)) (SETQ Y (CADR POSITION)) ( TERMINAL-MOVETOXY TERMINAL (PLUS X (CAADR WINDOW)) (PLUS Y (CADADR WINDOW)))) ( RESETLST (RESETSAVE SYSPRETTYFLG T) (RESETSAVE TTYLINELENGTH (SUB1 ( DIFFERENCE (CAADDR WINDOW) (CAR POSITION)))) (SHOWPRINT VALUE) (CAR (RPLACA ( PNTH WINDOW 5) 1)))) (SETQ Y (SUB1 (CAR (PNTH WINDOW 5))))) ((EQ (CAR (PNTH ITEM 5)) (QUOTE DISPLAY)) (GEVEXPROP (CADR ITEM) (CADDR ITEM) (QUOTE GEVDISPLAY) (QUOTE MSG) (LIST WINDOW Y))) (T (SETQ Y (SUB1 Y)) (MAPC (CAR ( PNTH ITEM 6)) (FUNCTION (LAMBDA (VSUB) (GEVPPS VSUB (PLUS COL 2) WINDOW)))))))) (DE GEVPROGRAM NIL (PROG (TOPITEM COMMAND SET PATH DONE NEXT TYPE NEWFN RESULT LAST ABORTFLG) (SETQ TOPITEM (CAAAR GEVEDITCHAIN)) (COND ((OR (EQ ( SETQ COMMAND (MENU-SELECT (COPY (QUOTE (MENU (QUIT COLLECT TOTAL AVERAGE MAXIMUM MINIMUM) (WINDOW (0 0) (0 0) NIL 0)))))) (QUOTE QUIT)) (NOT COMMAND)) ( RETURN NIL))) (COND ((OR (EQ (SETQ SET (GEVPROPMENU (CADDR TOPITEM) (QUOTE LIST) NIL)) (QUOTE QUIT)) (EQ SET (QUOTE POP)) (NOT SET)) (RETURN NIL))) ( SETQ PATH (LIST SET (LIST (CAR TOPITEM) (CADDR TOPITEM)))) (SETQ NEXT SET) ( SETQ TYPE (CADADR SET)) (PROG NIL GLLABEL1 (COND ((AND (NOT DONE) (NOT ABORTFLG)) (SETQ NEXT (GEVPROPMENU TYPE (AND (NE COMMAND (QUOTE COLLECT)) ( QUOTE NUMBER)) (EQ COMMAND (QUOTE COLLECT)))) (COND ((ATOM NEXT) (CASEQ NEXT (( NIL QUIT) (SETQ ABORTFLG T)) (POP (COND ((NOT (CDDR PATH)) (SETQ ABORTFLG T)) ( T (SETQ NEXT (CAR PATH)) (SETQ PATH (CDR PATH)) (SETQ NEXT (CAR PATH)) (SETQ TYPE (CADR NEXT)) (COND ((PAIRP TYPE) (SETQ TYPE (CADR TYPE)))) (SETQ LAST ( CAR NEXT))))) (DONE (SETQ DONE T)))) (T (SETQ PATH (CONS NEXT PATH)) (SETQ TYPE (CADR NEXT)) (SETQ LAST (CAR NEXT)))) (COND ((MEMQ TYPE (QUOTE (ATOM INTEGER STRING REAL BOOLEAN NIL))) (SETQ DONE T))) (GO GLLABEL1)))) (COND ( ABORTFLG (RETURN NIL))) (SETQ PATH (REVERSIP PATH)) (SETQ NEWFN ( GEVMAKENEWFN COMMAND (CADDR TOPITEM) SET (CDDR PATH))) (GEVPUTD (QUOTE GEVNEWFN) (CAR NEWFN)) (SETQ RESULT (GEVdoNEWFN (CADR TOPITEM))) (PRIN1 COMMAND) (SPACES 1) (MAPC (CDDR PATH) (FUNCTION (LAMBDA (X) (PRIN1 (CAR X)) ( SPACES 1)))) (PRINC "OF ") (PRIN1 (CAAR PATH)) (SPACES 1) (PRIN1 (CAADR PATH)) ( PRINC " = ") (PRINT RESULT) (RPLACA (CDDAR GEVEDITCHAIN) (ACONC (CADDAR GEVEDITCHAIN) (LIST (CONCAT (GEVSTRINGIFY COMMAND) (CONCAT " " (GEVSTRINGIFY LAST))) RESULT (CADR NEWFN) NIL (QUOTE MSG) NIL (APPEND (QUOTE (0 0)) NIL) ( APPEND (QUOTE (0 0)) NIL)))) (GEVDISPLAYNEWPROP))) (DE GEVPROPMENU (OBJ FILTER FLG) (PROG (PROPS SEL PNAMES MENU) (SETQ PROPS ( GEVGETNAMES OBJ FILTER)) (COND ((NOT PROPS) (RETURN NIL)) (T (SETQ PNAMES ( MAPCAR PROPS (FUNCTION CAR))) (SETQ SEL (MENU-SELECT (LIST (QUOTE MENU) ( CONS (QUOTE QUIT) (CONS (QUOTE POP) (COND (FLG (CONS (QUOTE DONE) PNAMES)) ( T PNAMES)))) (COPY (QUOTE (WINDOW (0 0) (0 0) NIL 0)))))) (RETURN (CASEQ SEL (( QUIT POP DONE NIL) SEL) (T (ASSOC SEL PROPS)))))))) (DE GEVPROPNAMES (OBJ PROPTYPE FILTER) (PROG (RESULT TYPE) (SETQ RESULT ( MAPCAN (CASEQ PROPTYPE (PROP (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) ( QUOTE PROP))) (ADJ (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE ADJ))) ( ISA (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE ISA))) (MSG (LISTGET ( CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE MSG)))) (FUNCTION (LAMBDA (P) (AND ( SETQ TYPE (GEVPROPTYPES OBJ (CAR P) (QUOTE PROP))) (GEVFILTER TYPE FILTER) ( CONS (LIST (CAR P) TYPE) NIL)))))) (MAPC (LISTGET (CDR (GET OBJ (QUOTE GLSTRUCTURE))) (QUOTE SUPERS)) (FUNCTION (LAMBDA (S) (SETQ RESULT (NCONC RESULT (GEVPROPNAMES S PROPTYPE FILTER)))))) (RETURN RESULT))) (DE GEVPROPTYPE (STR PROPNAME PROPTYPE) (PROG (PL SUBPL PROPENT TMP) (COND (( NOT (ATOM STR)) (RETURN NIL)) ((AND (SETQ PROPENT (GEVGETPROP STR PROPNAME PROPTYPE)) (SETQ TMP (LISTGET (CDDR PROPENT) (QUOTE RESULT)))) (RETURN TMP)) (( AND PROPENT (ATOM (CADR PROPENT)) (SETQ TMP (GET (CADR PROPENT) (QUOTE GLRESULTTYPE)))) (RETURN TMP)) ((AND (SETQ PL (GET STR (QUOTE GLPROPFNS))) ( SETQ SUBPL (ASSOC PROPTYPE PL)) (SETQ PROPENT (ASSOC PROPNAME (CDR SUBPL))) ( SETQ TMP (CADDR PROPENT))) (RETURN TMP)) ((EQ PROPTYPE (QUOTE ADJ)) (RETURN ( QUOTE BOOLEAN)))))) (DE GEVPROPTYPES (OBJ NAME TYPE) (OR (GEVPROPTYPE OBJ NAME TYPE) (AND ( GEVCOMPPROP OBJ NAME TYPE) (GEVPROPTYPE OBJ NAME TYPE)))) (DE GEVPUSH (ITEM) (PROG (NEWITEMS TOPITEM LSTITEM) (COND ((EQ (CAR (PNTH ITEM 5)) (QUOTE BACKUP)) (GEVPOP NIL 1) (RETURN NIL))) (SETQ TOPITEM (CAAAR GEVEDITCHAIN)) (COND ((EQ (CAR (PNTH ITEM 5)) (QUOTE FORWARD)) (SETQ NEWITEMS (GEVPUSHLISTOF ITEM T))) ((AND (ATOM (CADDR ITEM)) (NOT (GET (CADDR ITEM) (QUOTE GLSTRUCTURE)))) (CASEQ (CADDR ITEM) ((ATOM NUMBER REAL INTEGER STRING ANYTHING) (COND ((EQ (CADR ITEM) (CADDDR ITEM)) (RETURN NIL)) (T ( SETQ NEWITEMS (LIST (LIST (CAR ITEM) (CADR ITEM) (CADDR ITEM) (CADDDR ITEM) ( QUOTE FULLVALUE) NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL))))))) (T (RETURN NIL)))) ((AND (PAIRP (CADDR ITEM)) (EQ (CAADDR ITEM) (QUOTE LISTOF))) (SETQ NEWITEMS (GEVPUSHLISTOF ITEM NIL)))) (SETQ GEVEDITCHAIN ( CONS (LIST (CONS ITEM (CAAR GEVEDITCHAIN)) NEWITEMS NIL) GEVEDITCHAIN)) ( GEVREFILLWINDOW) (COND ((AND (PAIRP (CADDR ITEM)) (EQ (CAADDR ITEM) (QUOTE LISTOF)) (NOT (CDADR ITEM))) (SETQ LSTITEM (CAADAR GEVEDITCHAIN)) (GEVPUSH ( CAAR (PNTH LSTITEM 6))) (RETURN NIL))))) (DE GEVPUSHLISTOF (ITEM FLG) (PROG (ITEMTYPE TOPFRAME N NROOM LST VALS TMP) ( COND ((NOT (CADR ITEM)) (RETURN NIL))) (SETQ TOPFRAME (CAR GEVEDITCHAIN)) ( SETQ NROOM (DIFFERENCE (DIFFERENCE (QUOTIENT (CADR (CADDR GEVWINDOW)) 1) 4) (LENGTH (CAR TOPFRAME)))) (COND (FLG (SETQ LST (CONS (LIST NIL NIL NIL "(..." (QUOTE BACKUP) NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) LST)) (SETQ N (CAR ITEM)) (SETQ ITEMTYPE (CADDR ITEM)) (SETQ NROOM ( SUB1 NROOM)) (SETQ VALS (CAR (PNTH ITEM 6)))) (T (SETQ N 1) (SETQ ITEMTYPE ( CADR (CADDR ITEM))) (SETQ VALS (CADR ITEM)))) (PROG NIL GLLABEL1 (COND ((AND VALS (OR (GREATERP NROOM 1) (AND (EQN NROOM 1) (NOT (CDR VALS))))) (SETQ LST ( CONS (LIST N (PROG1 (SETQ TMP (CAR VALS)) (SETQ VALS (CDR VALS))) ITEMTYPE NIL NIL NIL (APPEND (QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) LST)) ( SETQ NROOM (SUB1 NROOM)) (SETQ N (ADD1 N)) (GO GLLABEL1)))) (COND (VALS ( SETQ LST (CONS (LIST N NIL ITEMTYPE "...)" (QUOTE FORWARD) VALS (APPEND ( QUOTE (0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)) LST)))) (RETURN (LIST (LIST "expanded" NIL ITEMTYPE NIL (QUOTE LISTOF) (REVERSIP LST) (APPEND (QUOTE ( 0 0)) NIL) (APPEND (QUOTE (0 0)) NIL)))))) (DE GEVQUIT NIL (SETQ GEVACTIVEFLG NIL) (WINDOW-CLOSE GEVWINDOW) (COND ( GEVMENUWINDOW (WINDOW-CLOSE GEVMENUWINDOW)))) (DE GEVREDOPROPS (TOP) (PROG (ITEM L) (SETQ ITEM (CAAR TOP)) (COND ((AND ( NOT (CADDR TOP)) (NE (SETQ L (GEVEXPROP (CADR ITEM) (CADDR ITEM) (QUOTE DISPLAYPROPS) (QUOTE PROP) NIL)) (QUOTE GEVERROR))) (COND ((ATOM L) ( GEVCOMMANDPROP ITEM (QUOTE PROP) (QUOTE ALL))) ((PAIRP L) (MAPC L (FUNCTION ( LAMBDA (X) (GEVCOMMANDPROP ITEM (QUOTE PROP) X))))))) (T (MAPC (CADDR TOP) ( FUNCTION (LAMBDA (X) (COND ((NE (CAR (PNTH X 5)) (QUOTE MSG)) (RPLACA (CDR X) ( GEVEXPROP (CADR ITEM) (CADDR ITEM) (CAR X) (CAR (PNTH X 5)) NIL)) (RPLACA ( CDDDR X) NIL)))))))))) (DE GEVREFILLWINDOW NIL (PROG (TOP TOPITEM SUBS TOPSUB) (SETQ TOP (CAR GEVEDITCHAIN)) (SETQ TOPITEM (CAAAR GEVEDITCHAIN)) (SETQ TOPSUB (CAADR TOP)) ( COND ((OR (NOT TOPSUB) (AND (NE (CAR (PNTH TOPSUB 5)) (QUOTE FULLVALUE)) (NE ( CAR (PNTH TOPSUB 5)) (QUOTE LISTOF)))) (COND ((GEVGETPROP (CADDR TOPITEM) ( QUOTE GEVDISPLAY) (QUOTE MSG)) (RPLACA (CDR TOP) (LIST (LIST NIL (CADR TOPITEM) (CADDR TOPITEM) NIL (QUOTE DISPLAY) NIL (APPEND (QUOTE (0 0)) NIL) ( APPEND (QUOTE (0 0)) NIL))))) (T (SETQ SUBS (GEVMATCH (CADDR TOPITEM) (CADR TOPITEM) T)) (SETQ TOPSUB (CAR SUBS)) (RPLACA (CDR TOP) (COND ((AND (NOT ( CDR SUBS)) (EQ (CAR (PNTH TOPSUB 5)) (QUOTE STRUCTURE)) (EQUAL (CADR TOPSUB) ( CADR TOPITEM)) (EQUAL (CADDR TOPSUB) (CADDR TOPITEM))) (CAR (PNTH TOPSUB 6))) (T SUBS))))))) (GEVREDOPROPS TOP) (GEVFILLWINDOW))) (DE GEVSHORTATOMVAL (ATM NCHARS) (COND ((NUMBERP ATM) (COND ((GREATERP ( FLATSIZE2 ATM) NCHARS) (GEVSHORTSTRINGVAL (GEVSTRINGIFY ATM) NCHARS)) (T ATM))) ((GREATERP (FLATSIZE2 ATM) NCHARS) (CONCAT (SUBSTRING ATM 1 (SUB1 NCHARS)) "-")) (T ATM))) (DE GEVSHORTCONSVAL (VAL STR NCHARS) (PROG (NLEFT RES TMP NC) (SETQ RES ( CONS "(" RES)) (SETQ NLEFT (DIFFERENCE NCHARS 5)) (SETQ TMP (GEVSHORTVALUE ( CAR VAL) (CADR STR) (DIFFERENCE NLEFT 3))) (SETQ NC (FLATSIZE2 TMP)) (COND (( GREATERP NC (DIFFERENCE NLEFT 3)) (SETQ TMP "---") (SETQ NC 3))) (SETQ RES ( CONS (GEVSTRINGIFY TMP) RES)) (SETQ RES (CONS " . " RES)) (SETQ NLEFT ( DIFFERENCE NLEFT NC)) (SETQ TMP (GEVSHORTVALUE (CDR VAL) (CADDR STR) NLEFT)) ( SETQ NC (FLATSIZE2 TMP)) (COND ((GREATERP NC NLEFT) (SETQ TMP "---") (SETQ NC 3))) (SETQ RES (CONS (GEVSTRINGIFY TMP) RES)) (SETQ RES (CONS ")" RES)) ( RETURN (GEVCONCAT (REVERSIP RES))))) (DE GEVSHORTLISTVAL (VAL STR NCHARS) (PROG (NLEFT RES TMP QUIT NC NCI REST RSTR) (SETQ RES (CONS "(" RES)) (SETQ REST 4) (SETQ NLEFT (DIFFERENCE NCHARS 2)) (SETQ RSTR (CDR STR)) (PROG NIL GLLABEL1 (COND ((AND VAL (NOT QUIT) ( GREATERP (SETQ NCI (COND ((CDR VAL) (DIFFERENCE NLEFT REST)) (T NLEFT))) 2)) (SETQ TMP (GEVSHORTVALUE (CAR VAL) (COND ((EQ (CAR STR) (QUOTE LISTOF)) ( CADR STR)) ((EQ (CAR STR) (QUOTE LIST)) (CAR RSTR))) NCI)) (SETQ QUIT ( MEMBER TMP (QUOTE (GEVERROR "(...)" "---" "???")))) (SETQ NC (FLATSIZE2 TMP)) ( COND ((AND (GREATERP NC NCI) (CDR RES)) (SETQ QUIT T)) (T (COND ((GREATERP NC NCI) (SETQ TMP "---") (SETQ NC 3) (SETQ QUIT T))) (SETQ RES (CONS ( GEVSTRINGIFY TMP) RES)) (SETQ NLEFT (DIFFERENCE NLEFT NC)) (SETQ VAL (CDR VAL)) (SETQ RSTR (CDR RSTR)) (COND (VAL (SETQ RES (CONS " " RES)) (SETQ NLEFT (SUB1 NLEFT)))))) (GO GLLABEL1)))) (COND (VAL (SETQ RES (CONS "..." RES)))) (SETQ RES (CONS ")" RES)) (RETURN (GEVCONCAT (REVERSIP RES))))) (DE GEVSHORTSTRINGVAL (VAL NCHARS) (COND ((STRINGP VAL) (GEVLENGTHBOUND VAL NCHARS)) (T "???"))) (DE GEVSHORTVALUE (VAL STR NCHARS) (PROG (TMP) (SETQ STR (GEVXTRTYPE STR)) ( RETURN (COND ((AND (ATOM STR) (MEMQ STR (QUOTE (ATOM INTEGER REAL)))) ( GEVSHORTATOMVAL VAL NCHARS)) ((EQ STR (QUOTE STRING)) (GEVSHORTSTRINGVAL VAL NCHARS)) ((AND (ATOM STR) (NE (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)) ((PAIRP STR) (CASEQ (CAR STR) ((LISTOF LIST) ( COND ((PAIRP VAL) (GEVSHORTLISTVAL VAL STR NCHARS)) (T "???"))) (CONS (COND (( PAIRP VAL) (GEVSHORTCONSVAL VAL STR NCHARS)) (T "???"))) (T "---"))) ((PAIRP VAL) (GEVSHORTLISTVAL VAL (QUOTE (LISTOF ANYTHING)) NCHARS)) (T "---"))))) (DE GEVXTRTYPE (TYPE) (COND ((ATOM TYPE) TYPE) ((NOT (PAIRP TYPE)) NIL) (( AND (MEMQ (CAR TYPE) (QUOTE (A AN A AN AN TRANSPARENT))) (CDR TYPE) (ATOM ( CADR TYPE))) (CADR TYPE)) ((MEMQ (CAR TYPE) GEVTYPENAMES) TYPE) ((AND (NOT ( UNBOUNDP GLUSERSTRNAMES)) (ASSOC (CAR TYPE) GLUSERSTRNAMES)) TYPE) ((AND ( ATOM (CAR TYPE)) (CDR TYPE)) (GEVXTRTYPE (CADR TYPE))) (T (ERROR 0 (LIST ( QUOTE GEVXTRTYPE) (LIST TYPE "is an illegal type specification."))) NIL))) (SETQ GEVTYPENAMES (QUOTE (CONS LIST RECORD LISTOF ALIST ATOM OBJECT LISTOBJECT ATOMOBJECT)))