(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)


(FILECREATED "18-Jul-2023 12:27:33" {DSK}<home>frank>il>medley>gmedley>lispusers>EVALOBJ.;2
 15110  

      :CHANGES-TO (VARS EVALOBJCOMS)

      :PREVIOUS-DATE "11-May-2018 08:22:13" {DSK}<home>frank>il>medley>gmedley>lispusers>EVALOBJ.;1
)


(PRETTYCOMPRINT EVALOBJCOMS)

(RPAQQ EVALOBJCOMS

       [(FILES IMOBJAPPLICATION)
        (DECLARE%: DOEVAL@LOAD DONTCOPY (FILES (FROM LOADUPS)
                                               EXPORTS.ALL))
        (FNS EVALOBJ.BUTTONEVENTINFN EVALOBJ.DISPLAYFN EVALOBJ.IMAGEBOXFN EVALOBJ.COPYFN 
             EVALOBJ.CREATE EVALOBJ.GETFN EVALOBJ.PUTFN)
        (FNS PARAMS TEXTSTREAMPARAM)
        [COMS (FNS EVALOBJ.DISMANTLEFN EVALOBJ.SELTOOBJ)
              (P (AND (GETD 'ADDTOIMOBJAPPLICATIONMENU)
                      (ADDTOIMOBJAPPLICATIONMENU '(Eval% form 'EVALOBJ.SELTOOBJ 
                                                 "Converts current selection to an evaluation object"
                                                         (SUBITEMS [|Eval at Create/Load|
                                                                    (FUNCTION (LAMBDA
                                                                               (TEXTSTREAM SELECTION)
                                                                               (EVALOBJ.SELTOOBJ
                                                                                TEXTSTREAM SELECTION
                                                                                'CREATE/LOAD]
                                                                (|Eval at Hardcopy|
                                                                 (FUNCTION (LAMBDA
                                                                            (TEXTSTREAM SELECTION)
                                                                            (EVALOBJ.SELTOOBJ
                                                                             TEXTSTREAM SELECTION
                                                                             'HARDCOPY]
        [INITVARS (EVALOBJ.IMAGEFNS (IMAGEFNSCREATE 'EVALOBJ.DISPLAYFN 'EVALOBJ.IMAGEBOXFN
                                           'EVALOBJ.PUTFN
                                           'EVALOBJ.GETFN
                                           'EVALOBJ.COPYFN
                                           'EVALOBJ.BUTTONEVENTINFN NIL NIL NIL NIL NIL NIL
                                           '(LAMBDA (OBJ)
                                                   ""]
        (GLOBALVARS EVALOBJ.IMAGEFNS)
        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PARAMS)
                                                                             (NLAML)
                                                                             (LAMA])

(FILESLOAD IMOBJAPPLICATION)
(DECLARE%: DOEVAL@LOAD DONTCOPY 

(FILESLOAD (FROM
 LOADUPS)
       EXPORTS.ALL)
)
(DEFINEQ

(EVALOBJ.BUTTONEVENTINFN

  [LAMBDA (OBJ STREAM)
                                   (* ; "Edited 19-Aug-97 14:03 by rmk:")

                                                             (* jtm%: " 5-Aug-88 15:40")

                                                             (* ; 

                                                "the user has pressed a button inside the eval OBJ")

    (CL:WHEN [MENU (CREATE
 MENU
                          ITEMS _ '((|Edit evaulation form| T 
                                           " Opens a window to edit the evaluation form"]

(* ;;; 

"SEDIT always forks a process.  We hang in that process until it closes (CLOSE-ON-COMPLETION)")


        (ALLOW.BUTTON.EVENTS)
        [IMAGEOBJPROP OBJ 'OBJECTDATUM (LET ((*READTABLE* FILERDTBL))
                                            (DECLARE
 (SPECVARS *READTABLE*))
                                            (EDITE (COPY (IMAGEOBJPROP OBJ 'OBJECTDATUM))
                                                   NIL
                                                   'Evaluation% Form NIL NIL '(:CLOSE-ON-COMPLETION]
        (IMAGEOBJPROP OBJ 'EVALUATED NIL)
        'CHANGED)])

(EVALOBJ.DISPLAYFN

  [LAMBDA (OBJ IMAGESTREAM)
                              (* ; "Edited 19-Aug-97 13:46 by rmk:")

                                                             (* fsg "17-Sep-87 11:14")


    (* ;; "Display an Eval imageobject.  If the stream-type is display, then shows the form.  Otherwise the stream-type is hardcopy and the form is executed.")


    (DECLARE
 (SPECVARS OBJ IMAGESTREAM)
           (USEDFREE TEXTSTREAM))
    (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM)
        (DISPLAY (LET ((FONT (DSPFONT '(TERMINAL 10)
                                    IMAGESTREAM)))
                      (PRIN3 "{Eval: " IMAGESTREAM)
                      (PRIN4 (IMAGEOBJPROP OBJ 'OBJECTDATUM)
                             IMAGESTREAM)
                      (PRIN3 "}" IMAGESTREAM)
                      (DSPFONT FONT IMAGESTREAM)))
        (CL:WHEN (EQMEMB (IMAGEOBJPROP OBJ 'WHEN)
                        '(NIL HARDCOPY))
            (LET [(FORM/FN (IMAGEOBJPROP OBJ 'OBJECTDATUM]
                 (IF
 (LITATOM FORM/FN)
                     THEN
 (APPLY* FORM/FN IMAGESTREAM TEXTSTREAM OBJ)
                   ELSE
 (EVAL FORM/FN))))])

(EVALOBJ.IMAGEBOXFN

  [LAMBDA (OBJ IMAGESTREAM CURRENTX RIGHTMARGIN)
         (* ; "Edited 19-Aug-97 13:43 by rmk:")

                                                             (* ss%: "27-Jun-87 15:50")


    (* ;; "Return the ImageBox for an EVALOBJ.  Evaluates a CREATE/LOAD form that hasn't yet been evaluated (presumably came from the COPYFN).")


    (DECLARE
 (SPECVARS OBJ IMAGESTREAM CURRENTX RIGHTMARGIN)
           (USEDFREE TEXTSTREAM))
    (CL:WHEN [AND (EQ (IMAGEOBJPROP OBJ 'WHEN)
                      'CREATE/LOAD)
                  (NOT (IMAGEOBJPROP OBJ 'EVALUATED]
        (LET [(FORM/FN (IMAGEOBJPROP OBJ 'OBJECTDATUM]
             (IF
 (LITATOM FORM/FN)
                 THEN
 (APPLY* FORM/FN IMAGESTREAM TEXTSTREAM OBJ)
               ELSE
 (EVAL FORM/FN))
             (IMAGEOBJPROP OBJ 'EVALUATED T)))
    (SELECTQ (IMAGESTREAMTYPE IMAGESTREAM)
        (DISPLAY (LET [(FONT (FONTCREATE '(TERMINAL 10]
                      (CREATE
 IMAGEBOX
                             XSIZE _ (PLUS (STRINGWIDTH "{Eval: }" FONT)
                                           (STRINGWIDTH (IMAGEOBJPROP OBJ 'OBJECTDATUM)
                                                  FONT T (FIND-READTABLE "INTERLISP")))
                             YSIZE _ (FONTPROP FONT 'HEIGHT)
                             YDESC _ (FONTPROP FONT 'DESCENT)
                             XKERN _ 0)))
        (CREATE
 IMAGEBOX
               XSIZE _ 0
               YSIZE _ 0
               YDESC _ 0
               XKERN _ 0])

(EVALOBJ.COPYFN

  [LAMBDA (OBJ)
                                          (* ; "Edited 19-Aug-97 13:30 by rmk:")

    (EVALOBJ.CREATE
 (COPY (IMAGEOBJPROP OBJ 'OBJECTDATUM))
           (IMAGEOBJPROP OBJ 'WHEN])

(EVALOBJ.CREATE

  [LAMBDA (FORM WHEN TEXTSTREAM)
                        (* ; "Edited  6-May-2000 09:24 by rmk:")

    (DECLARE
 (SPECVARS TEXTSTREAM))

    (* ;; "For EVAL at CREATE/LOAD.  TEXTSTREAM is NIL on call from COPYFN, since the destination stream isn't known.  The object is not marked as evaluated, so that the imagebox fn will do it  the first time it is displayed/printed.  Hopefully it won't be copied to place where it isn't initially displayed--that's the best we can do.  ")


    (IF
 (AND FORM (OR (LISTP FORM)
                          (LITATOM FORM)))
        THEN
 (LET ((OBJ (IMAGEOBJCREATE FORM EVALOBJ.IMAGEFNS)))
                      (IMAGEOBJPROP OBJ 'DISMANTLEFN (FUNCTION EVALOBJ.DISMANTLEFN))
                      (IMAGEOBJPROP OBJ 'TEDIT-TO-TEX-FN (FUNCTION TRUE))
                      (IMAGEOBJPROP OBJ 'WHEN WHEN)
                      (CL:WHEN (AND TEXTSTREAM (EQ WHEN 'CREATE/LOAD))
                          (IF
 (LITATOM FORM)
                              THEN
 

                                    (* ;; 

      "NIL is image stream.  It should be an error if a CREATE/LOAD form accesses an image stream!")


                                    (APPLY* FORM NIL TEXTSTREAM OBJ)
                            ELSE
 (EVAL FORM))
                          (IMAGEOBJPROP OBJ 'EVALUATED T))
                      OBJ)
      ELSE
 (ERROR!])

(EVALOBJ.GETFN

  [LAMBDA (FILESTREAM TEXTSTREAM)
                        (* ; "Edited 19-Aug-97 13:25 by rmk:")

    (LET ((DATA (HREAD FILESTREAM))
          FORM WHEN)
         (IF
 (LITATOM (CAR (LISTP DATA)))
             THEN
 (SETQ FORM DATA)
           ELSE
 (SETQ FORM (CAR DATA))
                 (SETQ WHEN (CADR DATA)))
         (EVALOBJ.CREATE
 FORM WHEN TEXTSTREAM])

(EVALOBJ.PUTFN

  [LAMBDA (OBJ STREAM)
                                   (* ; "Edited 19-Aug-97 13:28 by rmk:")


    (* ;; "Put a description of an eval object into the file.")


    (HPRINT (LIST (IMAGEOBJPROP OBJ 'OBJECTDATUM)
                  (IMAGEOBJPROP OBJ 'WHEN))
           STREAM])
)
(DEFINEQ

(PARAMS

  [NLAMBDA PARAMS
                                        (* ; "Edited  7-Nov-97 08:41 by rmk:")

    (DECLARE
 (USEDFREE TEXTSTREAM))

    (* ;; "Each P is either")


    (* ;; 

"   a list of the form (name value), in which case value becomes the (new) value of parameter name;")


    (* ;; 

  "   a list of the form (name v1 v2 ...) in which case it is treated as (name (v1 v2 ...))")


    (* ;; "   a list of the form (name), in which case the value for name (even NIL) is removed)")


    (* ;; "   a litatom, in which case it is treated as a list (atom T).")


    (* ;; "The form (name) is different from (name NIL)--the disinction allows the client to distinguish between no value (hence use a default) and a value of NIL.")


    (FOR
 P PCELL [PROP _ (APPEND (STREAMPROP TEXTSTREAM 'PARAMETERS] IN
 PARAMS
       DO
 (IF
 (LISTP P)
                  THEN
 [IF
 (CDDR P)
                               THEN
 (SETQ P (LIST (CAR P)
                                                      (CDR P]
                ELSEIF
 (LITATOM P)
                  THEN
 (SETQ P (LIST P T))
                ELSE
 (PROMPTPRINT P " is not a valid text parameter"))
             (SETQ PCELL (ASSOC (CAR P)
                                PROP))
             (IF
 (CDR P)
                 THEN
 [IF
 PCELL
                              THEN
 (RPLACA (CDR PCELL)
                                              (CADR P))
                            ELSE
 (PUSH
 PROP (LIST (CAR P)
                                                          (CADR P]
               ELSEIF
 PCELL
                 THEN
 (SETQ PROP (DREMOVE PCELL PROP))) FINALLY
 (STREAMPROP TEXTSTREAM
                                                                               'PARAMETERS PROP)
                                                                  (RETURN PROP])

(TEXTSTREAMPARAM

  [LAMBDA (PARAMNAME DEFAULTVALUE)
    (DECLARE
 (USEDFREE TEXTSTREAM))
                  (* ; "Edited  3-Aug-98 13:48 by rmk:")


    (* ;; "Returns the value of the parameter PARAMNAME on a higher-bound TEXTSTREAM, or DEFAULTVALUE if the parameter is not set.")


    (IF
 (AND (BOUNDP 'TEXTSTREAM)
                 (STREAMP TEXTSTREAM))
        THEN
 (LET [(PCELL (ASSOC PARAMNAME (STREAMPROP TEXTSTREAM 'PARAMETERS]
                      (IF
 PCELL
                          THEN
 (CADR PCELL)
                        ELSE
 DEFAULTVALUE))
      ELSE
 DEFAULTVALUE])
)
(DEFINEQ

(EVALOBJ.DISMANTLEFN

  [LAMBDA (TEXTSTREAM OBJ CHAR#)
                         (* ; "Edited 27-Jan-97 18:03 by rmk:")

    (SETFILEPTR TEXTSTREAM (SUB1 CHAR#))
    (RESETLST
        (RESETSAVE %#RPARS)
        (PRINTOUT TEXTSTREAM 2 .PPV (IMAGEOBJPROP OBJ 'OBJECTDATUM)))])

(EVALOBJ.SELTOOBJ

  [LAMBDA (TEXTSTREAM SELECTION WHEN)
                    (* ; "Edited 19-Aug-97 13:23 by rmk:")

    (IF
 (COLLECTIMOBJSINSEL TEXTSTREAM SELECTION)
        THEN
 (TEDIT.PROMPTPRINT TEXTSTREAM "Evaluation form can't contain image object" T)
      ELSE
                                               (* ; "Pack on ]]] to avoid eof errors")

            (LET ((OBJ (EVALOBJ.CREATE
 (READ (OPENSTRINGSTREAM (CONCAT (TEDIT.SEL.AS.STRING
                                                                            TEXTSTREAM SELECTION)
                                                                          "]]]]]"))
                                                 (FIND-READTABLE "INTERLISP"))
                              WHEN TEXTSTREAM)))
                 (REPLACESELWITHOBJ OBJ TEXTSTREAM SELECTION])
)

[AND (GETD 'ADDTOIMOBJAPPLICATIONMENU)
     (ADDTOIMOBJAPPLICATIONMENU '(Eval% form 'EVALOBJ.SELTOOBJ 
                                        "Converts current selection to an evaluation object"
                                        (SUBITEMS [|Eval at Create/Load| (FUNCTION (LAMBDA (
                                                                                           TEXTSTREAM
                                                                                            SELECTION
                                                                                            )
                                                                                     (

                                                                                     EVALOBJ.SELTOOBJ

                                                                                      TEXTSTREAM 
                                                                                      SELECTION
                                                                                      'CREATE/LOAD]
                                               (|Eval at Hardcopy| (FUNCTION (LAMBDA (TEXTSTREAM
                                                                                      SELECTION)
                                                                               (EVALOBJ.SELTOOBJ

                                                                                TEXTSTREAM SELECTION
                                                                                'HARDCOPY]

(RPAQ? EVALOBJ.IMAGEFNS

       [IMAGEFNSCREATE 'EVALOBJ.DISPLAYFN 'EVALOBJ.IMAGEBOXFN 'EVALOBJ.PUTFN 'EVALOBJ.GETFN
              'EVALOBJ.COPYFN
              'EVALOBJ.BUTTONEVENTINFN NIL NIL NIL NIL NIL NIL '(LAMBDA (OBJ)
                                                                       ""])
(DECLARE%: DOEVAL@COMPILE DONTCOPY

(GLOBALVARS EVALOBJ.IMAGEFNS)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 

(ADDTOVAR NLAMA
 PARAMS)

(ADDTOVAR NLAML
 )

(ADDTOVAR LAMA
 )
)
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3016 9297 (EVALOBJ.BUTTONEVENTINFN 3026 . 4219) (EVALOBJ.DISPLAYFN 4221 . 5396) (
EVALOBJ.IMAGEBOXFN 5398 . 6941) (EVALOBJ.COPYFN 6943 . 7166) (EVALOBJ.CREATE 7168 . 8584) (
EVALOBJ.GETFN 8586 . 8987) (EVALOBJ.PUTFN 8989 . 9295)) (9298 11863 (PARAMS 9308 . 11239) (
TEXTSTREAMPARAM 11241 . 11861)) (11864 13009 (EVALOBJ.DISMANTLEFN 11874 . 12157) (EVALOBJ.SELTOOBJ 
12159 . 13007)))))
STOP