(FILECREATED "14-Mar-85 14:13:26"
{PHYLUM}<TRILLIUM>BIRTHDAY84>ENHANCEMENTS>RECORDS-NHB>TRI-RECORD-IO.;14 12472
changes to: (FNS EXTERNALIZE.FRAME EXTERNALIZE.INTERFACE INTERNALIZE.FRAME
INTERNALIZE.INTERFACE)
previous date: "12-Mar-85 17:19:55"
{PHYLUM}<TRILLIUM>BIRTHDAY84>ENHANCEMENTS>RECORDS-NHB>TRI-RECORD-IO.;13)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT TRI-RECORD-IOCOMS)
(RPAQQ TRI-RECORD-IOCOMS ((FNS CREATE.INTERFACE GETDEF.INTERFACE HASDEF.INTERFACE DELDEF.INTERFACE
DUMP.INTERFACE REGISTER.INTERFACE RESET.INTERFACE INSERT.ITEM.VERSIONS
EXTERNALIZE.FRAME EXTERNALIZE.INTERFACE INTERNALIZE.FRAME
INTERNALIZE.INTERFACE INTERNALIZE.ITEM READ.INTERFACE UPDATE.INTERFACE
PUTDEF.INTERFACE)))
(DEFINEQ
(CREATE.INTERFACE
[LAMBDA (INTERFACE) (* N.H.Briggs "31-Jan-85 18:45")
(* * when an interface is instantiated this function will be applied to the new instance, allowing us to remember
the definition as a property on the atom that is the name of the interface (unless the name is unspecified, in which
case we do nothing))
(PROG ((INTERFACE.NAME (fetch (INTERFACE NAME) of INTERFACE)))
(if INTERFACE.NAME
then (PUTPROP INTERFACE.NAME (QUOTE InternalInterfaceRepresentation)
INTERFACE))
(RETURN INTERFACE])
(GETDEF.INTERFACE
[LAMBDA (NAME TYPE) (* N.H.Briggs "21-Feb-85 14:58")
(PROG ((INTERFACE (FIND.INTERFACE NAME)))
(COND
(INTERFACE (RETURN (EXTERNALIZE.INTERFACE INTERFACE])
(HASDEF.INTERFACE
[LAMBDA (NAME TYPE SOURCE) (* N.H.Briggs "31-Jan-85 18:53")
(* * Provides a fast check for existance of a current definition for an interface, depends on CREATE.INTERFACE
saving definition on property list)
(NOT (NULL (GETPROP NAME (QUOTE InternalInterfaceRepresentation])
(DELDEF.INTERFACE
[LAMBDA (NAME TYPE) (* N.H.Briggs "25-Feb-85 11:47")
(REMPROP NAME (QUOTE InternalInterfaceRepresentation])
(DUMP.INTERFACE
[LAMBDA (NAME) (* N.H.Briggs "21-Feb-85 11:13")
(DECLARE (GLOBALVARS TRILLIUM.INTERFACE.REPRESENTATION.VERSION))
(PROG (INTERFACE)
(COND
((NOT (HASDEF.INTERFACE NAME (QUOTE INTERFACE)))
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS NAME " has no definition as an INTERFACE."))
(T (SETQ INTERFACE (FIND.INTERFACE NAME))
(RESET.INTERFACE INTERFACE T)
(INSERT.ITEM.VERSIONS INTERFACE)
(PRINT (LIST (QUOTE READ.INTERFACEQ)
NAME TRILLIUM.INTERFACE.REPRESENTATION.VERSION))
(HPRINT (EXTERNALIZE.INTERFACE INTERFACE)
NIL T])
(REGISTER.INTERFACE
[LAMBDA (INTERFACE)
(PUTPROP (fetch.interface.fieldq INTERFACE NAME)
(QUOTE InternalInterfaceRepresentation)
INTERFACE])
(RESET.INTERFACE
[LAMBDA (INTERFACE RESET.ITEMS) (* N.H.Briggs " 1-Feb-85 09:39")
(RESET.FRAMES (fetch.interface.fieldq INTERFACE FRAMES)
RESET.ITEMS])
(INSERT.ITEM.VERSIONS
[LAMBDA (INTERFACE) (* N.H.Briggs " 1-Feb-85 09:40")
(for FRAME in (fetch.interface.fieldq INTERFACE FRAMES)
do (for ITEM in (DEFINING.ITEMS.OF.FRAME FRAME) bind (ITEM.VERSION ITYPE.VERSION)
do (SETQ ITEM.VERSION (OR (GET.FIELDQ ITEM VERSION)
0))
(SETQ ITYPE.VERSION (OR (GETPROP (ITEM.TYPE ITEM)
(QUOTE VERSION))
0))
(COND
((IGREATERP ITEM.VERSION ITYPE.VERSION)
(TRILLIUM.PRINTOUT ON TRILLIUM.WARNINGS "Item of type " (ITEM.TYPE ITEM)
" encountered has a more recent version (" ITEM.VERSION
") than loaded itemtype ("
ITYPE.VERSION ")."))
((ILESSP ITEM.VERSION ITYPE.VERSION)
(* * No need to update. The item was either created during this session or updated when loaded.
Only case to worry about is loaded and updated or created before loading in older version of itemtype.
Only thing we could do then is to undo updates. Forget it!)
(SET.FIELDQ ITEM VERSION ITYPE.VERSION])
(EXTERNALIZE.FRAME
[LAMBDA (FRAME) (* N.H.Briggs "13-Mar-85 16:42")
(* * Converts internal record-based interface representation to external proplist-based format.)
(PROG (FRAME.DESCRIPTION)
[for FIELD in (RECORDFIELDNAMES (QUOTE FRAME)) when (NOT (EQ FIELD (QUOTE OTHER)))
do (SETQ FRAME.DESCRIPTION (CONS (RECORDACCESS FIELD FRAME (RECLOOK (QUOTE FRAME))
(QUOTE FFETCH))
(CONS FIELD FRAME.DESCRIPTION]
(RETURN (NCONC (DREVERSE FRAME.DESCRIPTION)
(ffetch (FRAME OTHER) of FRAME])
(EXTERNALIZE.INTERFACE
[LAMBDA (INTERFACE) (* N.H.Briggs "13-Mar-85 16:38")
(* * Converts internal record-based interface representation to external proplist-based format.)
(PROG (INTERFACE.DESCRIPTION)
[for FIELD in (RECORDFIELDNAMES (QUOTE INTERFACE)) when (NOT (EQ FIELD (QUOTE OTHER)))
do (SETQ INTERFACE.DESCRIPTION (CONS (RECORDACCESS FIELD INTERFACE (RECLOOK
(QUOTE INTERFACE))
(QUOTE FFETCH))
(CONS FIELD INTERFACE.DESCRIPTION]
(RETURN (NCONC (DREVERSE INTERFACE.DESCRIPTION)
(ffetch (INTERFACE OTHER) of INTERFACE])
(INTERNALIZE.FRAME
[LAMBDA (FRAME.DESCRIPTION) (* N.H.Briggs "13-Mar-85 16:26")
(* * Converts external proplist-based frame representation to internal record-based format.)
(PROG (FRAME FRAME.NAME)
(SETQ FRAME.NAME (LISTGET FRAME.DESCRIPTION (QUOTE NAME)))
(SETQ FRAME (create FRAME))
(replace.frame.fieldq FRAME ITEMS (for ITEM.DESCRIPTION in (LISTGET FRAME.DESCRIPTION
(QUOTE ITEMS))
collect (INTERNALIZE.ITEM ITEM.DESCRIPTION)))
[for FIELD&VALUE on FRAME.DESCRIPTION by (CDDR FIELD&VALUE)
do (COND
([NOT (FMEMB (CAR FIELD&VALUE)
(QUOTE (\TYPE ITEMS]
(replace.frame.field FRAME (CAR FIELD&VALUE)
(CADR FIELD&VALUE]
(RETURN FRAME])
(INTERNALIZE.INTERFACE
[LAMBDA (INTERFACE.DESCRIPTION) (* N.H.Briggs "13-Mar-85 16:26")
(* * Converts external proplist-based interface representation to internal record-based format.)
(PROG (INTERFACE INTERFACE.NAME INTERFACE.RECORD.FIELDS)
(SETQ INTERFACE.NAME (LISTGET INTERFACE.DESCRIPTION (QUOTE NAME)))
(SETQ INTERFACE (if (FIND.INTERFACE INTERFACE.NAME)
else (create INTERFACE)))
(replace.interface.fieldq INTERFACE FRAMES (for F in (LISTGET INTERFACE.DESCRIPTION
(QUOTE FRAMES))
collect (INTERNALIZE.FRAME F)))
[for FIELD&VALUE on INTERFACE.DESCRIPTION by (CDDR FIELD&VALUE)
do (if [NOT (FMEMB (CAR FIELD&VALUE)
(QUOTE (\TYPE FRAMES]
then (replace.interface.field INTERFACE (CAR FIELD&VALUE)
(CADR FIELD&VALUE]
(RETURN INTERFACE])
(INTERNALIZE.ITEM
[LAMBDA (ITEM.DESCRIPTION)
ITEM.DESCRIPTION])
(READ.INTERFACE
[LAMBDA (NAME VERSION) (* N.H.Briggs " 1-Feb-85 10:25")
(DECLARE (SPECVARS FILE))
(PROG (INTERFACE.DESCRIPTION)
(if (LISTP VERSION)
then (SHOULDNT "Attempt to read an interface definition that is *too* old")
(* * (PROG ((OLD.FORM VERSION)) (* * BEFORE VERSION NUMBERS: ITEMS REPRESENTED AS TYPERECORDS)
(SETQ INTERFACE.DESCRIPTION (CONVERT.DIALOG.RECORDS.TO.PROPLISTS OLD.FORM)) (for FRAME in (LISTGET
INTERFACE.DESCRIPTION (QUOTE FRAMES)) do (for ITEM in (LISTGET FRAME (QUOTE ITEMS)) when (EQ
(ITEM.TYPE ITEM) (QUOTE BITMAP)) do (LISTPUT ITEM (QUOTE BITMAP) (EVALV (LISTGET ITEM (QUOTE \BITMAP.NAME))))))
(SETQ VERSION 2)))
elseif (OR (NULL VERSION)
(IEQP VERSION 1))
then (SHOULDNT "Attempt to read an interface definition that is *too* old")
(* * (PROG ((OLD.FORM (HREAD))) (* * NIL: SAME AS 1, BUT UNMARKED) (* * 1: ITEMS AS PROPLISTS;
INTERFACES, FRAMES AS TYPERECORDS 82/4/15?) (SETQ INTERFACE.DESCRIPTION (CONVERT.DIALOG.RECORDS.TO.PROPLISTS
OLD.FORM)) (SETQ VERSION 2)))
else (SETQ INTERFACE.DESCRIPTION (HREAD)))
(UPDATE.INTERFACE INTERFACE.DESCRIPTION VERSION)
(PUTDEF.INTERFACE NAME (QUOTE INTERFACE)
INTERFACE.DESCRIPTION)
(ADD.OBJECT.TO.FILE NAME (QUOTE INTERFACE.NAMES)
(LISTGET (UNPACKFILENAME FILE)
(QUOTE NAME])
(UPDATE.INTERFACE
[LAMBDA (INTERFACE.DESCRIPTION INTERFACE.VERSION) (* N.H.Briggs "22-Feb-85 12:23")
[COND
((IEQP INTERFACE.VERSION 2)
(PROG (PROFILE CLASS FRAME ITYPE DESCRIPTION GTYPE PNAME PVAL)
(* * DIALOG => INTERFACE)
(RPLACA (CDR INTERFACE.DESCRIPTION)
(QUOTE INTERFACE))
(* * IF PROFILE IS PRESENT, DELETE IT, AND PUT FRAME CLASS INFO WHERE NEEDED)
(COND
((SETQ PROFILE (GET.FIELDQ INTERFACE.DESCRIPTION (QUOTE PROFILE)))
[for ELEM on (LISTGET PROFILE (QUOTE FRAME.CLASSES)) by (CDDR ELEM)
do (SETQ CLASS (CAR ELEM))
(for FRAME.NAME in (CADR ELEM) do (COND
((SETQ FRAME (FIND.FRAME
INTERFACE.DESCRIPTION
FRAME.NAME))
(ADD.FRAME.CLASS FRAME CLASS]
(LISTPUT INTERFACE.DESCRIPTION (QUOTE PROFILE)
NIL)))
(* * 3; CONVERT ALL VALUES OF GRID PTYPES " 9-AUG-83")
[for FRAME in (LISTGET INTERFACE.DESCRIPTION (QUOTE FRAMES))
do (for ITEM in (DEFINING.ITEMS.OF.FRAME FRAME)
do (SETQ ITYPE (ITEM.TYPE ITEM))
(SETQ DESCRIPTION (ITEM.TYPE.DESCRIPTION ITYPE))
(for PARAMETER in (GET.FIELDQ DESCRIPTION PARAMETERS)
do (COND
((SETQ GTYPE (GET.FIELDQ PARAMETER GRID.TYPE))
(SETQ PNAME (GET.FIELDQ PARAMETER NAME))
(COND
((SETQ PVAL (LISTGET ITEM PNAME))
(SET.PARAM ITEM PNAME (COORDS PVAL]
(SETQ INTERFACE.VERSION 3]
(COND
((NOT (IEQP INTERFACE.VERSION 3))
(SHOULDNT "Unrecognized interface version number" INTERFACE.VERSION)))
(OR (LISTGET INTERFACE.DESCRIPTION (QUOTE BACKGROUND.COLOR))
(LISTPUT INTERFACE.DESCRIPTION (QUOTE BACKGROUND.COLOR)
(QUOTE WHITE)))
(HELP "needs work... this won't work now")
(WALK.INTERFACE INTERFACE.DESCRIPTION NIL (FUNCTION (LAMBDA (OBJECT)
(COND
((ITEMP OBJECT)
(UPDATE.ITEM OBJECT)))
NIL])
(PUTDEF.INTERFACE
[LAMBDA (NAME TYPE INTERFACE.DESCRIPTION) (* N.H.Briggs " 5-Mar-85 14:26")
(PROG [(INTERFACE (INTERNALIZE.INTERFACE INTERFACE.DESCRIPTION))
(INTERFACE.NAME (LISTGET INTERFACE.DESCRIPTION (QUOTE NAME]
(for I on TRILLIUM.INTERFACES when (EQ (fetch.interface.fieldq (CAR I)
NAME)
INTERFACE.NAME)
do (RPLACA I INTERFACE)
(RETURN)
finally (push TRILLIUM.INTERFACES INTERFACE)
(REGISTER.INTERFACE INTERFACE))
(RETURN INTERFACE.NAME])
)
(PUTPROPS TRI-RECORD-IO COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (826 12383 (CREATE.INTERFACE 836 . 1492) (GETDEF.INTERFACE 1494 . 1754) (
HASDEF.INTERFACE 1756 . 2133) (DELDEF.INTERFACE 2135 . 2321) (DUMP.INTERFACE 2323 . 3051) (
REGISTER.INTERFACE 3053 . 3223) (RESET.INTERFACE 3225 . 3425) (INSERT.ITEM.VERSIONS 3427 . 4572) (
EXTERNALIZE.FRAME 4574 . 5268) (EXTERNALIZE.INTERFACE 5270 . 6008) (INTERNALIZE.FRAME 6010 . 6917) (
INTERNALIZE.INTERFACE 6919 . 7932) (INTERNALIZE.ITEM 7934 . 8007) (READ.INTERFACE 8009 . 9587) (
UPDATE.INTERFACE 9589 . 11777) (PUTDEF.INTERFACE 11779 . 12381)))))
STOP