;;;-*- Mode:Common-Lisp; Package:SI; Base:10; Fonts:(CPTFONT HL12B HL12BI); Patch-file:T -*-

;;; 1Copyright (C) 1987,1988 Texas Instruments Incorporated. All rights reserved.*

;;Revised:
;; 12/05/87 DNG - Add Scheme canonical type to FS:*GENERIC-BASE-TYPE-ALIST*.
;;  1/16/88 DNG - Fix ZWEI:SYMBOL-FROM-STRING to not trip on (DEFINE ((ADDN N) X) ...).
;;  2/23/88 DNG - Fix updating of FS:*GENERIC-BASE-TYPE-ALIST* to avoid breaking META-.
;;  4/16/88 DNG - Fix WITH-SCHEME-ON and TURN-SCHEME-ON to permit *PACKAGE* to be SCHEME-PACKAGE.
;;  5/19/88 DNG - Update TURN-SCHEME-ON to set UCL:*DEFAULT-PRINT-FUNCTION* to use SCHEME:PP.
;;  4/22/89 DNG - Use new extensible version of LISP-MODE-KEYWORD-P .

2;;; Scheme canonical file type*

;; This belongs in "SYS:PATHNAME;CANONICAL-TYPES.LISP"
(FS:DEFINE-CANONICAL-TYPE :SCHEME "SCHEME"
  (:UNIX  "SCM" "SCH" "SCHEME")
  ((:LMFS :LISPM :UNIX-UCB :TOPS20 :TENEX :VMS4) "SCHEME" "SCM" "SCH")
  (:MSDOS "S" "SCM" "SCH")
  (:VMS "SCM" "SCH")
  (:ITS "SCM") ; this is what they seem to prefer at MIT
  )

(FS:DEFINE-CANONICAL-TYPE :ASM "S"
  (:MSDOS "ASM")) ; need to re-define this one to avoid confusion.

(unless (member ':scheme FS:*COPY-FILE-KNOWN-TEXT-TYPES*) ; in "SYS:IO;OPEN"
  (push-end ':scheme FS:*COPY-FILE-KNOWN-TEXT-TYPES*))

(unless (assoc ':scheme FS:*FILE-TYPE-MODE-ALIST*)  ; in "SYS:IO;OPEN"
  (push '(:scheme . :scheme) FS:*FILE-TYPE-MODE-ALIST*))

;;Treat "SCM" just like "LISP"
(when (boundp 'fs:*its-uninteresting-types*) ; in "SYS:PATHNAME;ITS"
  (pushnew "SCM" fs:*its-uninteresting-types* :test #'equal) )

(unless (assoc :scheme FS:*GENERIC-BASE-TYPE-ALIST*) ; in "SYS:NETWORK-SUPPORT;HOSTS"
  ;; Don't push on front of list; must add to the end or else 
  ;; FS:GENERIC-PATHNAME-SOURCE-PATHNAME will return a ".SCHEME" pathname when 
  ;; it should be returning a ".LISP" pathname, and that breaks META-. .
  (setf FS:*GENERIC-BASE-TYPE-ALIST*
	(append FS:*GENERIC-BASE-TYPE-ALIST* '((:scheme . :unspecific)))))

2;;; Permit mode of :SCHEME*

(unless (boundp '*VALID-LISP-MODES*) ; was added to kernel on 4/22/89

  (DEFVAR *VALID-LISP-MODES* (copy-list '(:COMMON-LISP :ZETALISP)))

  (DEFSUBST LISP-MODE-KEYWORD-P (LISP-MODE-KEYWORD)
    "Returns T if LISP-MODE-KEYWORD is a valid value for *LISP-MODE*. Otherwise, it returns NIL."
    (AND (MEMBER LISP-MODE-KEYWORD *VALID-LISP-MODES* :TEST #'EQ) T))

  2;; The following is not changed; just recompiled to use the above defsubst.*

  (DEFMACRO CHANGE-ZWEI-DEFAULT (LISP-MODE-KEYWORD)
    "Sets ZWEI:*DEFAULT-MAJOR-MODE* to LISP-MODE-KEYWORD as long as current value is
:LISP, :COMMON-LISP or :ZETALISP"
    `(IF (OR (EQ ZWEI:*DEFAULT-MAJOR-MODE* :LISP)
	     (SI:LISP-MODE-KEYWORD-P ZWEI:*DEFAULT-MAJOR-MODE*))
	 ,LISP-MODE-KEYWORD
       ZWEI:*DEFAULT-MAJOR-MODE*))
 
 ; From file ZMNEW.LISP#> ZMACS; MR-X:
 #8R ZWEI#:
 (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: ZMACS; ZMNEW.#"


 (DEFUN CHECK-PLIST-FOR-IMPORTANT-ATTRIBUTES (PLIST BUFFER)
  (MULTIPLE-VALUE-BIND (NIL PARSING-ERROR)
      (FS:EXTRACT-ATTRIBUTE-LIST (INTERVAL-STREAM BUFFER))
    (IF PARSING-ERROR
	(PROGN
	  (FORMAT *QUERY-IO* "~&Invalid syntax in the -*- line of buffer ~A." BUFFER)
	  NIL)
	(WHEN (AND PLIST
		   *UPDATE-PLIST-ON-WRITE-OK*
		   (SI::LISP-MODE-KEYWORD-P (GETF PLIST :MODE))	; Not just :lisp anymore.
		   (BUFFER-PATHNAME BUFFER)
		   (NULL (GETF PLIST :BASE))
		   ;; Don't mess with login-inits, since they may SETQ *PRINT-BASE*.
		   (LET ((ALPHABETIC-CASE-AFFECTS-STRING-COMPARISON NIL))
		     (NOT (STRING-EQUAL (SEND (BUFFER-PATHNAME BUFFER) :NAME)
					(SEND (INIT-FILE-PATHNAME 'LOGIN
								  (SEND (BUFFER-PATHNAME BUFFER) :HOST)
								  'T)
					      :NAME))))
		   (NOT (SEND BUFFER :GET-ATTRIBUTE :NO-BASE-ATTRIBUTE)))
	  ;; insert a base attribute.
	  (FORMAT *QUERY-IO* "~&Updating base attribute of ~A to ~D.~%" BUFFER *PRINT-BASE*)
	  (STORE-ATTRIBUTE-LIST BUFFER (SETQ PLIST (APPEND `(:BASE ,*PRINT-BASE*) PLIST)))
	  T))))
 ))
 )

(unless (member ':SCHEME *VALID-LISP-MODES*)
  (push-end ':SCHEME *VALID-LISP-MODES*))

2;;; Add :SCHEME mode*

(defvar *scheme-prompt* "==> ") ; this is what MIT PseudoScheme uses

(DEFUN (:PROPERTY :MODE FS:FILE-ATTRIBUTE-BINDINGS) (IGNORE IGNORE MODE-KEYWORD)
  "If MODE in the file attribute line is a legal Lisp Mode keyword, then this function
will return a set of bindings suitable for use by PROGV which are equivalent to using the
WITH-X special form.  If MODE is not a valid Lisp Mode keyword, this function returns
empty bindings lists."
  (DECLARE (VALUES LISP-MODE-VARIABLES-LIST LISP-MODE-VALUES-LIST))
  (IF (EQ MODE-KEYWORD :LISP) (SETQ MODE-KEYWORD :ZETALISP))      ;Equate :LISP with :ZETALISP
  (IF (NOT (LISP-MODE-KEYWORD-P MODE-KEYWORD))
      ;; then MODE was not anything recognized as a Lisp Mode keyword, so return nothing
      (VALUES NIL NIL)
    ;; else MODE was a recognized Lisp Mode keyword, so return the appropiate bindings
    (VALUES ;; Maintenance Note:  IF this list of bindings is changed, then corresponding
            ;; changes will probably be needed in the other mode switching functions.
            (LIST* '*LISP-MODE*
		   '*READTABLE*
		   'SI:*READER-SYMBOL-SUBSTITUTIONS*
		   'ZWEI:*DEFAULT-MAJOR-MODE*
		   nil)
	    (CASE MODE-KEYWORD
		  (:COMMON-LISP
		   (LIST* :COMMON-LISP                          ;*LISP-MODE*
			  SI:COMMON-LISP-READTABLE	;*READTABLE*
			  SI:*COMMON-LISP-SYMBOL-SUBSTITUTIONS*	;*READER-SYMBOL-SUBSTITUTIONS*
			  :COMMON-LISP		;ZWEI:*DEFAULT-MAJOR-MODE*
			  nil))
		  (:ZETALISP
		   (LIST* :ZETALISP                             ;*LISP-MODE*
			  SI:STANDARD-READTABLE		       ;*READTABLE*
			  si:*ZETALISP-SYMBOL-SUBSTITUTIONS*    ;*READER-SYMBOL-SUBSTITUTIONS*
                          :ZETALISP		               ;ZWEI:*DEFAULT-MAJOR-MODE*
			  nil ))
		  (:SCHEME
		   (LIST* :SCHEME                          ;*LISP-MODE*
			  SI:SCHEME-READTABLE	;*READTABLE*
			  NIL			;*READER-SYMBOL-SUBSTITUTIONS*
			  :COMMON-LISP		;ZWEI:*DEFAULT-MAJOR-MODE*
			  nil))
		  ))))

(DEFUN TURN-COMMON-LISP-ON (&OPTIONAL GLOBALLY)
  "This function sets the current Lisp Mode to :COMMON-LISP. It returns :COMMON-LISP.
If GLOBALLY is non-NIL, the global bindings, instead of the local bindings, are changed."
  (DECLARE (VALUES :COMMON-LISP))
  (IF GLOBALLY
      (SETQ-GLOBALLY *READTABLE*                      COMMON-LISP-READTABLE
                     *READER-SYMBOL-SUBSTITUTIONS*    *COMMON-LISP-SYMBOL-SUBSTITUTIONS*
		     ZWEI:*DEFAULT-MAJOR-MODE*        (CHANGE-ZWEI-DEFAULT :COMMON-LISP)
		     *LISP-MODE*                      :COMMON-LISP)
      (SETQ *READTABLE*                      COMMON-LISP-READTABLE
	    *READER-SYMBOL-SUBSTITUTIONS*    *COMMON-LISP-SYMBOL-SUBSTITUTIONS*
	    ZWEI:*DEFAULT-MAJOR-MODE*        (CHANGE-ZWEI-DEFAULT :COMMON-LISP)
	    *LISP-MODE*                      :COMMON-LISP))
  (UNDO-SCHEME)
   :COMMON-LISP)

(DEFUN TURN-ZETALISP-ON (&OPTIONAL GLOBALLY)
  "This function sets the current Lisp Mode to :ZETALISP.  It returns :ZETALISP.
If GLOBALLY is non-NIL, the global bindings, instead of the local bindings, are changed."
  (DECLARE (VALUES :ZETALISP))
  (IF GLOBALLY
      (SETQ-GLOBALLY *READTABLE*                      STANDARD-READTABLE
		     *READER-SYMBOL-SUBSTITUTIONS*    si:*ZETALISP-SYMBOL-SUBSTITUTIONS*    
		     ZWEI:*DEFAULT-MAJOR-MODE*        (CHANGE-ZWEI-DEFAULT :ZETALISP)
		     *LISP-MODE*                      :ZETALISP)
      (SETQ *READTABLE*                      STANDARD-READTABLE
	    *READER-SYMBOL-SUBSTITUTIONS*    si:*ZETALISP-SYMBOL-SUBSTITUTIONS*    
	    ZWEI:*DEFAULT-MAJOR-MODE*        (CHANGE-ZWEI-DEFAULT :ZETALISP)
	    *LISP-MODE*                      :ZETALISP))
  (UNDO-SCHEME)
  :ZETALISP)

(DEFUN SET-LISP-MODE (LISP-MODE-KEYWORD &OPTIONAL GLOBALLY)
  "This function sets the current Lisp Mode to LISP-MODE-KEYWORD
which must be either :COMMON-LISP or :ZETALISP.  It returns the current Lisp Mode.
If GLOBALLY is non-NIL, the global bindings, instead of the local bindings, are changed."
  (DECLARE (VALUES CURRENT-LISP-MODE-KEYWORD))
  (CCASE LISP-MODE-KEYWORD
    (:ZETALISP		(TURN-ZETALISP-ON GLOBALLY))
    (:COMMON-LISP	(TURN-COMMON-LISP-ON GLOBALLY))
    (:SCHEME		(TURN-SCHEME-ON GLOBALLY))))

(DEFSUBST SCHEME-ON-P (&OPTIONAL GLOBALLY)
  "Returns true if the current Lisp Mode is :SCHEME and returns false otherwise.
If GLOBALLY is non-NIL, the global bindings, instead of the local bindings, are checked."
  (IF GLOBALLY
      (EQ (SYMEVAL-GLOBALLY '*LISP-MODE*) :SCHEME)
      (EQ *LISP-MODE* :SCHEME)))

(DEFMACRO WITH-SCHEME-ON (&BODY BODY)
  "Executes BODY in Scheme Mode with the appropiate variables bound such that the 
previous Lisp Mode is restored on exit.  This form is not appropiate for typing into a
Listener because the entire body is read in the current Lisp Mode BEFORE any mode changes have
a chance to take effect."
  `(LET (;; Maintenance Note:  If this list of bindings is changed, change
         ;; the corresponding bindings in (:PROPERTY :MODE FILE-ATTRIBUTE-BINDINGS)
	 (SI:*LISP-MODE*                      :SCHEME)
	 (SI:*READTABLE*                      SI:SCHEME-READTABLE)
	 (SI:*READER-SYMBOL-SUBSTITUTIONS*    NIL)
	 (ZWEI:*DEFAULT-MAJOR-MODE*           :COMMON-LISP)
	 (*PACKAGE* (IF (OR (MEMBER SCHEME-PACKAGE (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ)
			    (EQ SCHEME-PACKAGE *PACKAGE*))
			*PACKAGE*
		      SCHEME-USER-PACKAGE))
	 (UCL:*DEFAULT-PROMPT* *SCHEME-PROMPT*)
	 (*PRINT-ARRAY* T)
	 )
     ,@BODY))

(DEFMACRO SET-SCHEME-BINDINGS ()
  "used by APPLY-LAMBDA to turn on Scheme when a SCHEME:LAMBDA is seen and
  the current mode is ZETALISP or COMMON-LISP."
  `(PROGN
     (BIND (LOCF SI:*LISP-MODE*)                     :SCHEME)
     (BIND (LOCF SI:*READTABLE*)                      SI:SCHEME-READTABLE)
     (BIND (LOCF ZWEI:*DEFAULT-MAJOR-MODE*)          (SI:CHANGE-ZWEI-DEFAULT :COMMON-LISP))
     (BIND (LOCF SI:*READER-SYMBOL-SUBSTITUTIONS*)    NIL)
     (BIND (LOCF UCL:*DEFAULT-PROMPT*)		      *SCHEME-PROMPT*)))

(DEF TURN-SCHEME-ON)
(LET ((*SAVED-PROMPT* UCL:*DEFAULT-PROMPT*) ; Saved old prompt; used when we temporarily want to set it.
      (*SAVED-PRINT-ARRAY* NIL)) ; Saved value of *PRINT-ARRAY*
  (DEFUN TURN-SCHEME-ON (&OPTIONAL GLOBALLY)
    "This function sets the current Lisp Mode to :SCHEME. It returns :SCHEME.
If GLOBALLY is non-NIL, the global bindings, instead of the local bindings, are changed."
    (DECLARE (VALUES :SCHEME))
    (IF GLOBALLY
	(SETQ-GLOBALLY *READTABLE*                      SCHEME-READTABLE
		       *READER-SYMBOL-SUBSTITUTIONS*    NIL
		       ZWEI:*DEFAULT-MAJOR-MODE*        (CHANGE-ZWEI-DEFAULT :COMMON-LISP)
		       *LISP-MODE*                      :SCHEME)
      (SETQ *READTABLE*                      SCHEME-READTABLE
	    *READER-SYMBOL-SUBSTITUTIONS*    NIL
	    ZWEI:*DEFAULT-MAJOR-MODE*        (CHANGE-ZWEI-DEFAULT :COMMON-LISP)
	    *LISP-MODE*                      :SCHEME))
    (unless (eq ucl:*default-prompt* 'si:scheme-prompt-when-appropriate)
      (setq *saved-prompt* ucl:*default-prompt*)
      (SETQ *SAVED-PRINT-ARRAY* *PRINT-ARRAY*)
      (setq ucl:*default-prompt* 'si:scheme-prompt-when-appropriate))
    (setq *print-array* t)			;print arrays readably
    ;; (setq ucl:*default-read-function* 'si:scheme-read-when-apropriate)  ; <-- maybe add this later???
    (UNLESS (OR (MEMBER SCHEME-PACKAGE (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ)
		(EQ SCHEME-PACKAGE *PACKAGE*))
      (SETQ *PACKAGE* SCHEME-USER-PACKAGE))
    (when (and (eq ucl:*default-print-function* 'pprin1)
	       (fboundp 'scheme:pp))
      (setq ucl:*default-print-function*
	    #'(lambda (object &optional (stream *standard-output*))
		(if (scheme-on-p)
		    (scheme:pp object stream)
		  (pprin1 object stream)))))
    :SCHEME)
  
  (DEFUN UNDO-SCHEME ()
    ;; Restore special variables that were SETQ'd by TURN-SCHEME-ON
    (UNLESS (MEMBER *LISP-PACKAGE* (PACKAGE-USE-LIST *PACKAGE*) :TEST #'EQ)
      (SETQ *PACKAGE* *USER-PACKAGE*))
    (WHEN (EQ UCL:*DEFAULT-PROMPT* 'SI:SCHEME-PROMPT-WHEN-APPROPRIATE)
      (SETQ UCL:*DEFAULT-PROMPT* *SAVED-PROMPT*)
      (SETQ *PRINT-ARRAY* *SAVED-PRINT-ARRAY*))
    (VALUES))
  
  (defun si:scheme-prompt-when-appropriate ()
    "When in Scheme mode, present the user with the Scheme prompt from *SCHEME-PROMPT*,
else use the standard default prompt."
    (if (scheme-on-p)
	*scheme-prompt*				; ** ==>  is specified in Revised^3
      (let* ((default-non-scheme-prompt "> ")
	     (prompt (if (eq *saved-prompt* 'scheme-prompt-when-appropriate)
			 default-non-scheme-prompt *saved-prompt*)))
	(if (stringp prompt)			; can either be a string or a function
	    prompt
	  (funcall prompt)))))
  ) ; end LET


2;;;  The following adapted form COM-COMMON-LISP-MODE in "SYS:ZMACS;MODES.LISP"*

zwei:
(progn
(DEFMAJOR COM-SCHEME-MODE SCHEME-MODE "Scheme"
	  "Sets things up for editing Scheme code." ()
  (SETQ *SPACE-INDENT-FLAG* T)
  (SETQ *PARAGRAPH-DELIMITER-LIST* '(#\. #\SPACE #\TAB #\"))
  (SETQ *COMMENT-START* 'LISP-FIND-COMMENT-START-AND-END)
  (SET-CHAR-SYNTAX LIST-SLASH *MODE-LIST-SYNTAX-TABLE* #\\)
  (SET-CHAR-SYNTAX LIST-ALPHABETIC *MODE-LIST-SYNTAX-TABLE* #\/)
  (SET-COMTAB *MODE-COMTAB*
	      '(#\TAB COM-INDENT-FOR-LISP
		#\RUBOUT COM-TAB-HACKING-RUBOUT
		#\c-RUBOUT COM-RUBOUT
		#\m-Z COM-COMPILE-AND-EXIT
		#\c-m-Z COM-EVALUATE-AND-EXIT))
  (SI:TURN-SCHEME-ON)) 

;;Make these variables settable (and thus undoable) in Zmacs modes.
(dolist (symbol '(*print-array* ucl:*default-prompt* ucl:*default-read-function*))
  (setf (get symbol 'zwei:mode-settable-p) lisp:t))

(DEFPROP SCHEME-MODE T ALL-UPPERCASE)		; case is insignificant
(DEFPROP SCHEME-MODE :LISP EDITING-TYPE)	; Scheme is Lisp
)

#!C
; From file MODES.LISP#> ZMACS; MR-X:
#8R ZWEI#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: ZMACS; MODES.#"


(DEFUN EVALUATE-FORMING-UNDO-LIST (FORM-LIST)
  (LET ((RESULT NIL))
    (DOLIST (FORM FORM-LIST)
      (CASE (CAR FORM)
	(SETQ
	 (OR (GET (SECOND FORM) 'MODE-SETTABLE-P)
	     (FERROR NIL "Illegal to SETQ ~A inside a mode macro" (SECOND FORM)))
	 (PUSH `(SETQ ,(SECOND FORM) ',(SYMBOL-VALUE (SECOND FORM))) RESULT)
	 (EVAL FORM))
	(ASET
	 (PUSH `(SETF (AREF ,@(CDDR FORM)) ',(EVAL `(AREF ,@(CDDR FORM)))) RESULT)  
	 (EVAL FORM))
	(SET-COMTAB
	 ;; Knowledge of how to reverse SET-COMTAB is kept in the COMTAB > file.
	 (PUSH (MAKE-SET-COMTAB-UNDO-LIST FORM) RESULT)
	 (EVAL FORM))
	(PUSH
	 (LET ((THING (EVAL (SECOND FORM))))
	   (PUSH `(SETF ,(THIRD FORM) (DELETE ',THING ,(THE LIST (THIRD FORM)) :TEST #'EQ))
		 RESULT)	   
	   (EVAL `(PUSH ',THING ,(THIRD FORM)))))
	(COMMAND-HOOK
	 (LET ((THING (EVAL (SECOND FORM))))
	   (PUSH `(SETF ,(THIRD FORM) (DELETE ',THING ,(THE LIST (THIRD FORM)) :TEST #'EQ))
		 RESULT)
	   (COMMAND-HOOK THING (THIRD FORM))))
	(SET-CHAR-SYNTAX
	 (LET ((SYNTAX-TABLE (SYMBOL-VALUE (THIRD FORM)))
	       (CHAR (FOURTH FORM)))
	   (PUSH `(SET-CHAR-SYNTAX ,(CHAR-SYNTAX CHAR SYNTAX-TABLE) ',SYNTAX-TABLE ,CHAR)
		 RESULT))
	 (EVAL FORM))
	(SET-MODE-LINE-LIST
	 (PUSH `(SET-MODE-LINE-LIST ',*MODE-LINE-LIST*) RESULT)
	 (EVAL FORM))
	(SET-SYNTAX-TABLE-INDIRECTION
	 (LET ((OF (SYMBOL-VALUE (SECOND FORM)))
	       (TO (SYMBOL-VALUE (THIRD FORM))))
	   (PUSH `(RPLACA ',OF ',(CAR OF)) RESULT)
	   (RPLACA OF TO)))
	(PROGN
	 (EVAL FORM))
	((TURN-ZETALISP-ON TURN-COMMON-LISP-ON SI:TURN-SCHEME-ON)
	 (PUSH `(SETF (LISP-MODE) ,(LISP-MODE)) RESULT) ; Eval-undo-list, below, recognises this setf.
	 (SI::EVAL1 FORM))
	(SET-MOUSE-DOCUMENTATION
	 (PUSH `(SET-MOUSE-DOCUMENTATION ',(SEND *WINDOW* :MOUSE-DOCUMENTATION-STRING))
	       RESULT)
	 (SET-MOUSE-DOCUMENTATION))
	(OTHERWISE
	 (FERROR NIL "The form ~S cannot be used in a mode, because I can't invert it." FORM))))
    RESULT)) 

))

2;; The following patch is so that Zmacs sectionization will recognize 
;; forms like (DEFINE (1name arg* ...) ...) as being a definition of 1name.**

(when (< (si:get-system-version :zmacs) 6)2 ; this change is included in relase 6 of Zmacs*
  ; From file SECTIO.LISP#33 ZMACS; MR-X:
  #8R ZWEI#:
  (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "ZWEI"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* SYS:COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: ZMACS; SECTIO.#"


 (DEFUN SYMBOL-FROM-STRING (STR &OPTIONAL LINE OK-TO-ASK SYM &AUX (EOF '(NIL)) ERROR-P)
  "Given a string STR as found after DEF..., return the name of the object being defined.
LINE is the line that the string was found in.  It is used for
finding the particular defining construct used; this affects the result
since (DEFUN (FOO BAR) defines (:PROPERTY FOO BAR)
while (DEFMETHOD (FOO BAR) defines (:METHOD FOO BAR).
OK-TO-ASK means in certain circumstances
where things are not clear, ask the user.  Otherwise we guess.

The arg can also be an object; then its printed representation is used as the string.

The second value is a canonicalized string for the object
 (maybe the same string specified, maybe not).
The third is T if there was a problem
 in parsing the string (such as unbalanced parens).

You can pass the read-in form of the object as the fourth arg
if you already know it."
  (DECLARE (VALUES SYM STR ERROR-P))
  (IF (ARRAYP STR)
      (UNLESS SYM
	(MULTIPLE-VALUE-SETQ (SYM ERROR-P)
			     (CATCH-ERROR (READ-FROM-STRING STR NIL EOF) NIL))
	(SETQ ERROR-P (AND (NULL SYM) ERROR-P)))	; chk 4 error on multi-val funct
							; patch 94.68 ddd/gsl 2/28/84.
      (SETQ SYM STR
	    STR (FORMAT NIL "~S" STR)))
  (COND (ERROR-P
	 (VALUES NIL NIL ERROR-P))
	((SYMBOLP SYM)
	 (VALUES SYM (SYMBOL-NAME SYM)))
	((OR (ATOM SYM) (EQUAL SYM EOF))
	 (VALUES NIL NIL T))
	(T
	 ;; Here SYM is a list.  Certain types of function specs have two ways to
	 ;; type them, with and without the leading type keyword.  Also certain types
	 ;; of functions and other definitions do not follow the standard form
	 ;; of (DEFxxx name options...).  What we do here is to recognize and
	 ;; standardize those cases.  The variables are:
	 ;;	TYPE - the type of function spec or non-function definition
	 ;;	SYM - the function spec or definition name
	 ;;	SPEC - the variant of SYM which appears in the source code
	 ;;	STR - SPEC converted to a string
	 ;; :HANDLER doesn't appear in source files, but gets translated into
	 ;; an appropriate :METHOD here, by analyzing the combined method.
	 ;; :INTERNAL doesn't appear in source files, but might be given as the argument
	 ;; to M-X Disassemble.  The code here just tries not to destory it.
	 (LET ((TYPE (CAR SYM))
	       DELIM-IDX SPEC)
	   (IF (AND (SYMBOLP TYPE)		; Beware of pathological cases.
		    (GET TYPE 'SYSTEM:FUNCTION-SPEC-HANDLER))
	       (SETQ SPEC (CDR SYM)
		     STR (DEFINITION-NAME-AS-STRING TYPE SPEC))
	       (SETQ SPEC SYM
		     DELIM-IDX (AND LINE (STRING-SEARCH-SET "( " LINE 1))
		     TYPE (COND ((NULL LINE)
				 :MAYBE-METHOD)
				((AND (EQL DELIM-IDX 12)
				      (SYS:%STRING-EQUAL LINE 0 "(DEFMETHOD" 0 12))
				 :ALWAYS-METHOD)
				((AND (EQL DELIM-IDX 13)
				      (SYS:%STRING-EQUAL LINE 0 "(DEFWRAPPER" 0 13))
				 (SETQ SPEC (LIST (CAR SPEC) :WRAPPER (SECOND SPEC)))
				 :ALWAYS-METHOD)
				((AND (EQL DELIM-IDX 12)
				      (SYS:%STRING-EQUAL LINE 0 "(DEFSTRUCT" 0 12))
				 :DEFSTRUCT)
				((AND (EQL DELIM-IDX 12)
				      (SYS:%STRING-EQUAL LINE 0 "(DEFSELECT" 0 12))
				 :DEFSELECT)
				((AND (EQL DELIM-IDX 7)
				      (SYS:%STRING-EQUAL LINE 0 "(DEFINE " 0 8)) ; Scheme DEFINE
				 :DEFSTRUCT) ; use (CAR SPEC)
				(T
				 :PROPERTY))))
	   (OR (CASE TYPE
		 (:ALWAYS-METHOD
		  (SETQ SYM (CONS :METHOD SPEC)))
		 ((:METHOD :HANDLER :MAYBE-METHOD)
		  (LET ((FLAVOR (CAR SPEC))
			(MESSAGE (IF (CDDR SPEC)
				     (CADDR SPEC)
				     (CADR SPEC)))
			FL)
		    (COND ((SETQ FL (GET FLAVOR 'SI:FLAVOR)))
			  (OK-TO-ASK
			   (DOLIST (SYMBOL (PACKAGE-LOOKALIKE-SYMBOLS FLAVOR NIL '(SI:FLAVOR)))
			     (IF (FQUERY '(:SELECT T) "Do you mean ~S? "
					 `(:METHOD ,SYMBOL ,@(CDR SPEC)))
				 (RETURN (SETQ FLAVOR SYMBOL
					       SPEC (CONS FLAVOR (CDR SPEC))
					       FL (GET FLAVOR 'SI:FLAVOR)))))))
		    (COND ((SYMBOLP FL)			;T or NIL
			   (AND (EQ TYPE :MAYBE-METHOD)
				(VALIDATE-2-LONG-LIST SPEC)
				(SETQ SYM (CONS :PROPERTY SPEC))))
			  ((FDEFINEDP `(:METHOD . ,SPEC))
			   (SETQ SYM `(:METHOD . ,SPEC)))
			  (OK-TO-ASK
			   (DOLIST (SYMBOL (OR (FIND-COMBINED-METHODS FLAVOR MESSAGE NIL)
					       (SI:FLAVOR-ALL-INHERITABLE-METHODS FLAVOR MESSAGE)))
			     (IF (FQUERY '(:SELECT T) "Do you mean ~S? " SYMBOL)
				 (RETURN (SETQ SYM SYMBOL))))))))
		 (:DEFSTRUCT
		  (SETQ SYM (CAR SPEC))
		  (LOOP WHILE (CONSP SYM)
			DO (SETQ SYM (CAR SYM)))
		   (SETQ STR (SYMBOL-NAME SYM)))
		 (:DEFSELECT
		  (SETQ SYM (CAR SPEC))
		   (IF (SYMBOLP SYM)
		       (SETQ STR (SYMBOL-NAME SYM))
		       (MULTIPLE-VALUE-SETQ (SYM STR)
			 (SYMBOL-FROM-STRING SYM))))
		 (:PROPERTY
		  (AND (VALIDATE-2-LONG-LIST SPEC)
		       (SETQ SYM (CONS TYPE SPEC))))
		 (:INTERNAL
		  (SETQ SYM (CONS TYPE SPEC))
		  (SETQ STR (DEFINITION-NAME-AS-STRING NIL (CAR SPEC)))))
	       ;; Something we don't understand, make a bogus symbol to use as a property
	       ;; list to remember the location of this definition
	       (SETQ SYM (INTERN STR *UTILITY-PACKAGE*))))
	 (IF (NOT (SYSTEM:VALIDATE-FUNCTION-SPEC SYM))
	     (VALUES NIL NIL T)
	     (VALUES SYM STR)))))
 )) )


2;;* 2Make Scheme Mode accessible*

(zwei:set-comtab zwei:*standard-comtab*
		 '()
		 (zwei:make-command-alist '(zwei:com-scheme-mode)))