(FILECREATED "30-Aug-84 15:39:12" {ICE}<TRILLIUM>BIRTHDAY84>BETA>TRI-EDITCLASS.;2 7217
changes to: (FNS ADD.CLASS.MEMBER)
previous date: "17-Aug-84 22:08:44" {ICE}<TRILLIUM>BIRTHDAY84>BETA>TRI-EDITCLASS.;1)
(* Copyright (c) 1984 by Xerox Corporation)
(PRETTYCOMPRINT TRI-EDITCLASSCOMS)
(RPAQQ TRI-EDITCLASSCOMS ((FNS ADD.CLASS ADD.CLASS.MEMBER CLASSNAME.FROM.MENUNAME DELETE.CLASS
DELETE.CLASS.MEMBER EDIT.CLASS GET.CLASS.EDITOR.COMMAND.MENU
MENUCLASSNAMEP MENUNAME.FROM.CLASSNAME SELECT.CLASS)
(VARS (CLASS.EDITOR.MENU)
(CURRENT.FRAME.CLASSES)
(CURRENT.ITYPE.CLASSES))))
(DEFINEQ
(ADD.CLASS
[LAMBDA (CLASSLIST CLASSTYPE) (* HaKo "16-Aug-84 14:43")
(TRILLIUM.PRINTOUT ON PROMPTWINDOW "Enter name of new class: ")
(PROG ((CLASSNAME (PROMPT.READ)))
(COND
((NOT (LITATOM CLASSNAME))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Not a valid name: " CLASSNAME
" -- command ignored."))
((MEMB CLASSNAME CLASSLIST)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS CLASSNAME " already exists.")
(RETURN CLASSNAME))
(CLASSNAME (TRILLIUM.PRINTOUT ON TRILLIUM.TRACE CLASSNAME " added to classes of "
CLASSTYPE)
(LISTPUT CLASSLIST CLASSNAME)
(RETURN CLASSNAME))
(T (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Null selection -- command ignored."])
(ADD.CLASS.MEMBER
[LAMBDA (CLASSNAME CLASSLIST CLASSTYPE) (* PH "30-Aug-84 15:38")
(DECLARE (GLOBALVARS CURRENT.INTERFACE FRAME.NAME.MENU ITEM.TYPE.MENU))
(PROG (NEWMEMBER (MEMBERLST (LISTGET CLASSLIST CLASSNAME)))
(COND
((NULL CLASSNAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Please select a class to work on first."))
([NULL (SETQ NEWMEMBER (SELECTQ CLASSTYPE
(FRAMES (ACQUIRE.FRAME.NAME CURRENT.INTERFACE))
(ITEM.TYPES (ACQUIRE.ITEM.TYPE NIL CLASSLIST))
(SHOULDNT]
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Null selection -- command ignored."))
((MEMB NEWMEMBER MEMBERLST)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS NEWMEMBER " is already a member of " CLASSNAME))
(T [COND
(MEMBERLST (MERGEINSERT NEWMEMBER MEMBERLST))
(T (LISTPUT CLASSLIST CLASSNAME (LIST NEWMEMBER]
(SELECTQ CLASSTYPE
(FRAMES (SETQ FRAME.NAME.MENU))
(ITEM.TYPES (SETQ ITEM.TYPE.MENU))
(SHOULDNT))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE NEWMEMBER " added to the class " CLASSNAME)
(RETURN NEWMEMBER])
(CLASSNAME.FROM.MENUNAME
[LAMBDA (MENUNAME) (* HK "28-JUL-82 15:26")
(PACK (DREVERSE (CDDDR (DREVERSE (CDDDR (UNPACK MENUNAME])
(DELETE.CLASS
[LAMBDA (CLASSNAME CLASSLIST CLASSTYPE) (* HaKo "16-Aug-84 14:45")
(DECLARE (GLOBALVARS FRAME.NAME.MENU ITEM.TYPE.MENU))
(COND
((NULL CLASSNAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Please select a class to work on first.")
NIL)
((CONFIRM (CONCAT "Delete class " CLASSNAME "?"))
(LISTPUT CLASSLIST CLASSNAME)
(SELECTQ CLASSTYPE
(FRAMES (SETQ FRAME.NAME.MENU))
(ITEM.TYPES (SETQ ITEM.TYPE.MENU))
(SHOULDNT))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE CLASSNAME " removed from classes of " CLASSTYPE)
T)
(T (TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Delete command ignored.")
NIL])
(DELETE.CLASS.MEMBER
[LAMBDA (CLASSNAME CLASSLIST CLASSTYPE) (* HaKo "16-Aug-84 14:45")
(DECLARE (GLOBALVARS FRAME.NAME.MENU ITEM.TYPE.MENU))
(PROG (OLDMEMBER (MEMBERLST (LISTGET CLASSLIST CLASSNAME)))
(COND
((NULL CLASSNAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Please select a class to work on first."))
((NULL (SETQ OLDMEMBER (CREATE.ONEOF MEMBERLST)))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Null selection -- command ignored."))
(T (OR (CDR (DREMOVE OLDMEMBER MEMBERLST))
(LISTPUT CLASSLIST CLASSNAME NIL))
(SELECTQ CLASSTYPE
(FRAMES (SETQ FRAME.NAME.MENU))
(ITEM.TYPES (SETQ ITEM.TYPE.MENU))
(SHOULDNT))
(TRILLIUM.PRINTOUT ON TRILLIUM.TRACE OLDMEMBER " removed from the class " CLASSNAME)
(RETURN OLDMEMBER])
(EDIT.CLASS
[LAMBDA (ORIGCLASSLIST CLASSTYPE) (* HaKo "16-Aug-84 14:46")
(bind [CLASSNAME (CLASSLIST ←(OR ORIGCLASSLIST (LIST NIL NIL]
do (SELECTQ (MENU (GET.CLASS.EDITOR.COMMAND.MENU CLASSTYPE CLASSNAME))
(NIL NIL)
(QUIT (COMPRESS.PROPLIST CLASSLIST)
(RETURN (AND (CADR CLASSLIST)
CLASSLIST)))
(SELECT.CLASS (SETQ CLASSNAME (SELECT.CLASS CLASSLIST)))
(ADD.CLASS (SETQ CLASSNAME (ADD.CLASS CLASSLIST CLASSTYPE)))
(DELETE.CLASS (AND (DELETE.CLASS CLASSNAME CLASSLIST CLASSTYPE)
(SETQ CLASSNAME)))
[SHOW.CLASS (COND
((NULL CLASSNAME)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS
"Please select a class to work on first."))
(T (TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS CLASSNAME
" contains: ")
(for CLASSMEMBER in (OR (LISTGET CLASSLIST CLASSNAME)
(QUOTE (*none*)))
do (TRILLIUM.PRINTOUT ON TRILLIUM.DESCRIPTIONS 10 CLASSMEMBER]
(ADD.MEMBER (ADD.CLASS.MEMBER CLASSNAME CLASSLIST CLASSTYPE))
(DELETE.MEMBER (DELETE.CLASS.MEMBER CLASSNAME CLASSLIST CLASSTYPE))
(SHOULDNT])
(GET.CLASS.EDITOR.COMMAND.MENU
[LAMBDA (CLASSTYPE CLASSNAME) (* DAHJr "17-FEB-83 11:58")
(DECLARE (GLOBALVARS CLASS.EDITOR.MENU))
[COND
((OR (NULL CLASS.EDITOR.MENU)
(NEQ CLASSNAME (CAR CLASS.EDITOR.MENU)))
(SETQ CLASS.EDITOR.MENU (CONS CLASSNAME (create MENU
ITEMS ←(QUOTE (SELECT.CLASS ADD.CLASS
DELETE.CLASS
SHOW.CLASS
ADD.MEMBER
DELETE.MEMBER
QUIT))
TITLE ←(COND
(CLASSNAME (CONCAT "Class editor: "
CLASSNAME))
(T (CONCAT "Class editor for " CLASSTYPE)))
CENTERFLG ← T
CHANGEOFFSETFLG ← T]
(CDR CLASS.EDITOR.MENU])
(MENUCLASSNAMEP
[LAMBDA (NAME) (* HK "28-JUL-82 15:23")
(EQ (CHCON1 NAME)
(CONSTANT (CHCON1 (QUOTE >])
(MENUNAME.FROM.CLASSNAME
[LAMBDA (CLASSNAME) (* HK "28-JUL-82 15:27")
(PACK* (QUOTE >>>)
CLASSNAME
(QUOTE <<<])
(SELECT.CLASS
[LAMBDA (CLASSLIST) (* HaKo "25-Jul-84 16:26")
(PROG [(CLASSNAMELIST (SORT (for CLASSDEFN on CLASSLIST by (CDDR CLASSDEFN) when (CADR CLASSDEFN)
collect (CAR CLASSDEFN]
(COND
((NULL CLASSNAMELIST)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "No classes have been defined yet."))
((NULL (CDR CLASSNAMELIST))
(RETURN (CAR CLASSNAMELIST)))
(T (RETURN (CREATE.ONEOF CLASSNAMELIST])
)
(RPAQQ CLASS.EDITOR.MENU NIL)
(RPAQQ CURRENT.FRAME.CLASSES NIL)
(RPAQQ CURRENT.ITYPE.CLASSES NIL)
(PUTPROPS TRI-EDITCLASS COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (637 7020 (ADD.CLASS 647 . 1414) (ADD.CLASS.MEMBER 1416 . 2543) (CLASSNAME.FROM.MENUNAME
2545 . 2726) (DELETE.CLASS 2728 . 3393) (DELETE.CLASS.MEMBER 3395 . 4232) (EDIT.CLASS 4234 . 5443) (
GET.CLASS.EDITOR.COMMAND.MENU 5445 . 6173) (MENUCLASSNAMEP 6175 . 6336) (MENUNAME.FROM.CLASSNAME 6338
. 6510) (SELECT.CLASS 6512 . 7018)))))
STOP