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

(FILECREATED "11-May-2018 08:22:13" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>EVALOBJ.;2
 15206  

      changes to%:  (VARS EVALOBJCOMS)

      previous date%: " 6-May-2000 09:24:45" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>lispusers>EVALOBJ.;1)


(* ; "
Copyright (c) 1997, 1998, 1999, 2000, 2018 by Xerox Corporation.  All rights reserved.
")

(PRETTYCOMPRINT EVALOBJCOMS)

(RPAQQ EVALOBJCOMS

       [(FILES IMOBJAPPLICATION)
        (DECLARE%: DOEVAL@LOAD DONTCOPY (FILES 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 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
 )
)
(PUTPROPS EVALOBJ COPYRIGHT ("Xerox Corporation" 1997 1998 1999 2000 2018))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (3038 9319 (EVALOBJ.BUTTONEVENTINFN 3048 . 4241) (EVALOBJ.DISPLAYFN 4243 . 5418) (
EVALOBJ.IMAGEBOXFN 5420 . 6963) (EVALOBJ.COPYFN 6965 . 7188) (EVALOBJ.CREATE 7190 . 8606) (
EVALOBJ.GETFN 8608 . 9009) (EVALOBJ.PUTFN 9011 . 9317)) (9320 11885 (PARAMS 9330 . 11261) (
TEXTSTREAMPARAM 11263 . 11883)) (11886 13031 (EVALOBJ.DISMANTLEFN 11896 . 12179) (EVALOBJ.SELTOOBJ 
12181 . 13029)))))
STOP