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

(FILECREATED "10-Nov-87 08:49:22" {DSK}<LISPFILES>ADD-SEDIT-COMMANDS.;2
 12581  

      changes to%:  (FUNCTIONS ADD-COMMAND)

      previous date%: "14-Oct-87 15:30:42" {DSK}<LISPFILES>ADD-SEDIT-COMMANDS.;1)


(* "
Copyright (c) 1987 by Beckman Instruments, Inc.  All rights reserved.
")

(PRETTYCOMPRINT ADD-SEDIT-COMMANDSCOMS)

(RPAQQ ADD-SEDIT-COMMANDSCOMS
 ((FUNCTIONS ADD-COMMAND COPY-EditENV EXAMPLE-NEW-SEDIT-COMMANDFN 
                                      EXAMPLE2-NEW-SEDIT-COMMANDFN GET-SEDIT-ROOT-STRUCTURE 
                                      GET-SEDIT-SELECTION-STRUCTURE)
                               [DECLARE%: EVAL@COMPILE 
          
          (* ;; "This hackery is necessary since these DATATYPE definitions are not in EXPORTS.ALL")


                                      (P (for DT in '(EditContext EditENV EditNode EditSelection) do
                                              (EVAL (SYSRECLOOK1 DT]
                               (PROP MAKEFILE-ENVIRONMENT ADD-SEDIT-COMMANDS)))

(CL:DEFUN ADD-COMMAND
 (TheENV CHARCODE COMMANDFN &REST EXTRA-COMMANDFN-ARGS) 

                                                      (* ; "Edited 14-Oct-87 10:52 by Matt Heffron")

          
          (* ;; "The EXTRA-COMMANDFN-ARGS will be passed to the COMMANDFN (after the |context| and |charcode| arguments) unEVALuated.")


 (LET ((CommandTable (fetch
 (EditENV CommandTable) of
 TheENV)))
      (PUTHASH (\\charcode CHARCODE)
             (CONS COMMANDFN EXTRA-COMMANDFN-ARGS)
             CommandTable)))


(CL:DEFUN COPY-EditENV
 (SOURCE-ENV) 
                  (* ; "Edited 13-Oct-87 17:28 by Matt Heffron")

 (LET ((ENV (NCREATE 'EditENV))
       OrigHashTable HashTable)
      (replace
 (EditENV ParseInfo) of
 ENV with
 (fetch
 (EditENV ParseInfo) of
 SOURCE-ENV))
      (replace
 (EditENV ParseInfoUnknown) of
 ENV with
 (fetch
 (EditENV ParseInfoUnknown) of
 SOURCE-ENV
                                                             ))
      (replace
 (EditENV UserData) of
 ENV with
 (fetch
 (EditENV UserData) of
 SOURCE-ENV))
      (replace
 (EditENV DefaultFont) of
 ENV with
 (fetch
 (EditENV DefaultFont) of
 SOURCE-ENV))
      (replace
 (EditENV ItalicFont) of
 ENV with
 (fetch
 (EditENV ItalicFont) of
 SOURCE-ENV))
      (replace
 (EditENV KeywordFont) of
 ENV with
 (fetch
 (EditENV KeywordFont) of
 SOURCE-ENV))
      (replace
 (EditENV CommentFont) of
 ENV with
 (fetch
 (EditENV CommentFont) of
 SOURCE-ENV))
      (replace
 (EditENV BrokenAtomFont) of
 ENV with
 (fetch
 (EditENV BrokenAtomFont) of
 SOURCE-ENV))
      (replace
 (EditENV SpaceWidth) of
 ENV with
 (fetch
 (EditENV SpaceWidth) of
 SOURCE-ENV))
      (replace
 (EditENV DefaultLineSkip) of
 ENV with
 (fetch
 (EditENV DefaultLineSkip) of
 SOURCE-ENV))
      (replace
 (EditENV DefaultIndent) of
 ENV with
 (fetch
 (EditENV DefaultIndent) of
 SOURCE-ENV))
      (replace
 (EditENV MinIndent) of
 ENV with
 (fetch
 (EditENV MinIndent) of
 SOURCE-ENV))
      (replace
 (EditENV MaxIndent) of
 ENV with
 (fetch
 (EditENV MaxIndent) of
 SOURCE-ENV))
      (replace
 (EditENV MaxWidth) of
 ENV with
 (fetch
 (EditENV MaxWidth) of
 SOURCE-ENV))
      (replace
 (EditENV CommentWidthPercent) of
 ENV with
 (fetch
 (EditENV CommentWidthPercent)
                                                            of
 SOURCE-ENV))
      (replace
 (EditENV InitCommentSeparation) of
 ENV with
 (fetch
 (EditENV InitCommentSeparation)
                                                              of
 SOURCE-ENV))
      (replace
 (EditENV LParenString) of
 ENV with
 (fetch
 (EditENV LParenString) of
 SOURCE-ENV))
      (replace
 (EditENV RParenString) of
 ENV with
 (fetch
 (EditENV RParenString) of
 SOURCE-ENV))
      (replace
 (EditENV DotString) of
 ENV with
 (fetch
 (EditENV DotString) of
 SOURCE-ENV))
      (replace
 (EditENV QuoteString) of
 ENV with
 (fetch
 (EditENV QuoteString) of
 SOURCE-ENV))
      (replace
 (EditENV CommentString) of
 ENV with
 (fetch
 (EditENV CommentString) of
 SOURCE-ENV))
      (replace
 (EditENV DefaultCharHandler) of
 ENV with
 (fetch
 (EditENV DefaultCharHandler)
                                                           of
 SOURCE-ENV))
      (replace
 (EditENV HelpMenu) of
 ENV with
 (fetch
 (EditENV HelpMenu) of
 SOURCE-ENV))
          
          (* ;; "The CommandTable field must have a new HashTable created for it")


      (SETQ OrigHashTable (fetch
 (EditENV CommandTable) of
 SOURCE-ENV))
      [SETQ HashTable (HASHARRAY (HARRAYPROP OrigHashTable 'SIZE)
                             (HARRAYPROP OrigHashTable 'OVERFLOW)
                             (HARRAYPROP OrigHashTable 'HASHBITSFN)
                             (HARRAYPROP OrigHashTable 'EQUIVFN]
      [MAPHASH OrigHashTable #'(CL:LAMBDA (VAL KEY)
                                      (PUTHASH KEY VAL HashTable]
      (replace
 (EditENV CommandTable) of
 ENV with
 HashTable)
      ENV))


(CL:DEFUN EXAMPLE-NEW-SEDIT-COMMANDFN
 (context charcode &REST EXTRA-COMMANDFN-ARGS) 

                                                      (* ; "Edited 13-Oct-87 17:30 by Matt Heffron")

          
          (* ;; "The EXTRA-COMMANDFN-ARGS are ignored in this example, but can be anything you want to have passed to this function.")


 (LET ((PromptWindow (GETPROMPTWINDOW (fetch
 (EditContext DisplayWindow) of
 context)))
       RootStructure RootNode NewStructure NewStructureSymbol)
          
          (* ;; "Get the Root Structure of this edit. (i.e. the WHOLE structure being edited).")


      (CL:MULTIPLE-VALUE-SETQ (RootStructure RootNode)
             (GET-SEDIT-ROOT-STRUCTURE context))
          
          (* ;; "Clear the PromptWindow & go to the beginning of the line.")


      (TERPRI PromptWindow)
          
          (* ;; "Read the STRINGP name of a symbol from the user")


      [SETQ NewStructureSymbol (PROMPTFORWORD "RPLACD of entire structure with value of: " NIL NIL 
                                      PromptWindow NIL NIL '(13 24]
      [CL:WHEN 
          
          (* ;; "This reads the symbol from the string read in above.  Of course, if you want the string (as a string), then you don't need to do this(but don't do the CL:SYMBOL-VALUE below either!)")


             (SETQ NewStructureSymbol (IGNORE-ERRORS (READ (OPENSTRINGSTREAM NewStructureSymbol
                                                                  'INPUT]
      (CL:IF NewStructureSymbol (CL:IF (BOUNDP NewStructureSymbol)
                                       (PROGN 
          
          (* ;; "Making a copy of the RootStructure make this safe, in that it's effects are confined to the edit, and don't affect the outside world.")


                                              (SETQ NewStructure (CL:COPY-TREE RootStructure))
          
          (* ;; "Do the structure modification.")


                                              (CL:SETF (CDR NewStructure)
                                                     (CL:COPY-TREE (CL:SYMBOL-VALUE 
                                                                          NewStructureSymbol)))
          
          (* ;; "Replace the RootNode with the newly parsed NewStructure")


                                              (\\replace.node context RootNode (\\parse.new 
                                                                                      NewStructure 
                                                                                      context)))
                                       (CL:FORMAT PromptWindow "~&Error: Unbound SYMBOL: ~S" 
                                              NewStructureSymbol))
             (CL:PRINC "...aborted" PromptWindow))
      T))


(CL:DEFUN EXAMPLE2-NEW-SEDIT-COMMANDFN
 (context charcode &REST EXTRA-COMMANDFN-ARGS) 

                                                      (* ; "Edited 14-Oct-87 10:52 by Matt Heffron")

 

(* ;;; "This is almost the same as the EXAMPLE-NEW-SEDIT-COMMANDFN, but it RPLACD's the current selection using the sub-function of the Mutate command that does all the work..")


 (LET ((PromptWindow (GETPROMPTWINDOW (fetch
 (EditContext DisplayWindow) of
 context)))
       CurrentSelection NewStructure NewStructureSymbol)
          
          (* ;; 

      "Get the CurrentSelection of this edit.  It is an EditNode datatype, NOT the actual structure.")


      (SETQ CurrentSelection (fetch
 (EditSelection SelectNode) of
 (fetch
 (EditContext Selection)
                                                                     of
 context)))
      (CL:IF CurrentSelection
             (PROGN 
          
          (* ;; "Clear the PromptWindow & go to the beginning of the line.")


                    (TERPRI PromptWindow)
          
          (* ;; "Read the STRINGP name of a symbol from the user")


                    [SETQ NewStructureSymbol (PROMPTFORWORD 
                                                    "RPLACD of current selection with value of: " NIL 
                                                    NIL PromptWindow NIL NIL '(13 24]
                    [CL:WHEN 
          
          (* ;; "This reads the symbol from the string read in above.  Of course, if you want the string (as a string), then you don't need to do this(but don't do the CL:SYMBOL-VALUE below either!)")


                           (SETQ NewStructureSymbol (IGNORE-ERRORS (READ (OPENSTRINGSTREAM
                                                                          NewStructureSymbol
                                                                          'INPUT]
                    (CL:IF NewStructureSymbol
                           (CL:IF (BOUNDP NewStructureSymbol)
                                  (PROGN 
          
          (* ;; "Use \\do.mutation to do the structure modification.")


                                         (CL:UNLESS [\\do.mutation context CurrentSelection
                                                           #'(CL:LAMBDA (X)
                                                                    (CL:SETF (CDR X)
                                                                           (CL:SYMBOL-VALUE 
                                                                                  NewStructureSymbol]
          
          (* ;; "\\do.mutation returns NIL if it failed (e.g. an error occurred)")


                                                (CL:FORMAT PromptWindow 
                                      "~&Error during RPLACD of current selection.  No changes made."
                                                       ))
          
          (* ;; "If the \\do.mutation succeeded, the it will have updated the internal structure and displayed the new structure in the edit window.")


                                         )
                                  (CL:FORMAT PromptWindow "~&Error: Unbound SYMBOL: ~S" 
                                         NewStructureSymbol))
                           (CL:PRINC "...aborted" PromptWindow)))
             (CL:FORMAT PromptWindow "~&Select whole structure to RPLACD."))
      T))


(CL:DEFUN GET-SEDIT-ROOT-STRUCTURE
 (context) 
         (* ; "Edited 13-Oct-87 14:32 by Matt Heffron")

 (LET (Node)
      [SETQ Node (CADR (fetch
 (EditNode SubNodes) of
 (fetch
 (EditContext Root) of
 context]
      (CL:VALUES (fetch
 (EditNode Structure) of
 Node)
             Node)))


(CL:DEFUN GET-SEDIT-SELECTION-STRUCTURE
 (context) 
    (* ; "Edited 14-Oct-87 14:30 by Matt Heffron")

 (LET (Node)
      (SETQ Node (fetch
 (EditSelection SelectNode) of
 (fetch
 (EditContext Selection) of
 context)))
      (CL:WHEN Node (CL:VALUES (fetch
 (EditNode Structure) of
 Node)
                           Node))))

(DECLARE%: EVAL@COMPILE 
(for DT in '(EditContext EditENV EditNode EditSelection) do (EVAL (SYSRECLOOK1 DT)))
)

(PUTPROPS ADD-SEDIT-COMMANDS MAKEFILE-ENVIRONMENT
 (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
(PUTPROPS ADD-SEDIT-COMMANDS COPYRIGHT ("Beckman Instruments, Inc" 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL)))
STOP