home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / custom.lisp < prev    next >
Encoding:
Text File  |  1991-06-11  |  9.3 KB  |  265 lines
  1. ; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SCHEME-INTERNAL; -*-
  2. ; File custom.lisp / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; Customizations for particular Common Lisp implementations
  5.  
  6. (in-package "SCHEME-INTERNAL")
  7.  
  8. #+Symbolics
  9. ; ASSUME REL 7 OR AFTER
  10.  
  11. (progn
  12.  
  13. ; Meta-. stuff adapted from OZ:<DAM.PROVER>METAP.LISP.2.  Thanks to
  14. ; DAM for figuring this out.
  15.  
  16. ; The value of the property ZWEI:DEFINITION-FUNCTION-SPEC-FINDER
  17. ; should be a function which takes the ZWEI point after the definition
  18. ; symbol (e.g. DEFINE) and returns the point at the begining of the fspec.
  19. ; See the function ZWEI:GET-DEFINITION-FUNCTION-SPEC
  20. ;
  21. ; DEFINE-FSPEC-FINDER goes forward to the begining of the next atom.
  22. ; This means skipping white space and left parenthesis.
  23.  
  24. (defun define-fspec-finder (bp)
  25.   (zwei:forward-over (cons #\(  zwei:*whitespace-chars*)
  26.              bp))
  27.  
  28. (mapc #'(lambda (definer)
  29.       (setf (get definer 'zwei:definition-function-spec-finder)
  30.         #'define-fspec-finder)
  31.       (setf (get definer 'zwei:definition-function-spec-type)
  32.         'defun))
  33.       '(scheme::define
  34.     scheme::define-macro))
  35.  
  36. (let ((type *scheme-file-type*))
  37.   (cond ((not (member type fs:*its-uninteresting-types* :test #'equal))
  38.      (push type fs:*its-uninteresting-types*))))
  39.  
  40. (fs:define-canonical-type :scheme #,*scheme-file-type*) ;Scheme source
  41.  
  42. ; Default mode for scheme source is lisp.
  43.  
  44. (unless (assoc :scheme fs:*file-type-mode-alist*)
  45.   (setq fs:*file-type-mode-alist*
  46.     (append fs:*file-type-mode-alist* (list (cons :scheme :lisp)))))
  47.  
  48. ; Allow one to write  -*- Syntax: Scheme; -*-
  49. ; (Thanks to Alan Bawden and Thomas A. Russ.)
  50.  
  51. (defun (:scheme fs:syntax-attribute-handler) ()
  52.   (values (list 'zl:readtable) (list roadblock-readtable)))
  53.  
  54. (si:define-lisp-syntax :scheme (:readtable-place roadblock-readtable  ;???
  55.                 :external-name "Scheme"
  56.                 :packages-must-use (("SCHEME")))
  57.   (zl:ferror "Cannot Set Lisp Context to Scheme.  Call SCHI:SCHEME instead."))
  58.  
  59. ; The following allows one to write -*- Mode: Scheme; -*-
  60.  
  61. (zl:defflavor scheme-mode () (zwei:lisp-syntax-mode-forms-mixin
  62.                    zwei:lisp-language-mixin
  63.                    zwei:major-mode))
  64.  
  65. (zl:defmethod (:mode-line-name scheme-mode) ()
  66.   "Scheme")
  67.  
  68. (zl:defmethod (:get-default-attribute scheme-mode :base) ()
  69.   10)
  70.  
  71. (zl:defmethod (:get-default-attribute scheme-mode :syntax) ()
  72.   :scheme)
  73.  
  74. (zl:defmethod (:mode-forms scheme-mode) ()
  75.   '((zwei:set-syntax-table-indirection zwei:*mode-list-syntax-table*
  76.                        zwei:*cl-list-syntax-table*)
  77.     (zwei:set-comtab zwei:*mode-comtab*
  78.              '(#\Meta-Z         zwei:com-compile-and-exit
  79.                #\Control-Meta-Z zwei:com-evaluate-and-exit
  80.                #\Meta-Q        zwei:com-fill-long-comment))))
  81.  
  82. (zl:defmethod (:eval-print-function scheme-mode) ()
  83.   #'scheme-evaluate-and-print)
  84.  
  85. (defun scheme-evaluate-and-print (object)
  86.   (declare (special zwei:*use-typeout*))
  87.   (let ((val (roadblock-eval object
  88.                  (get-file-context si:fdefine-file-pathname
  89.                            nil
  90.                            "Evaluating"))))
  91.     (if zwei:*use-typeout*
  92.     (write-result val)
  93.     (zwei:typein-line "~A" (with-output-to-string (stream)
  94.                  (write-result val stream))))
  95.     (values val object)))
  96.  
  97. (zl:defmethod (:compiler-function scheme-mode) ()
  98.   (zl:let-closed ((compiler:*correspondences* nil))
  99.     #'scheme-compiler-function))
  100.  
  101. (defun scheme-compiler-function (request-type &rest args)
  102.   (if (and (eq request-type :macro-expand)
  103.        (consp (car args))
  104.        (eq (caar args) 'scheme-form))
  105.       (translate-in-context (cadr (car args))
  106.                 (get-file-context si:fdefine-file-pathname
  107.                           nil
  108.                           "Compiling"))
  109.       (apply #'compiler:compile-to-core request-type args)))
  110.  
  111. (zwei:defmode zwei:com-scheme-mode scheme-mode
  112.   "Sets things up for editing Scheme.
  113. Like Lisp Mode -- if you've only got 8 fingers..."
  114.   :scheme)
  115.  
  116. ; Why is this commented out?  I don't have the courage to test it right now...
  117. ;(setq zwei:*lisp-syntax-alist*
  118. ;      (cons '("Scheme" :scheme scheme-mode zwei:*cl-list-syntax-table*)
  119. ;        (remove :scheme zwei:*lisp-syntax-alist* :key #'cadr)))
  120.  
  121. (zwei:set-comtab zwei:*standard-comtab*
  122.          '()
  123.          (zwei:make-command-alist '(zwei:com-scheme-mode)))
  124.  
  125. (zl:defmethod (:default-source-file-type scheme-mode) ()
  126.   :scheme)
  127.  
  128. (setq fs:*file-type-mode-alist*
  129.       (cons '(:Scheme . :Scheme)
  130.         (remove-if #'(lambda (x)
  131.                (or (eq (car x) :Scheme)
  132.                    (eq (cdr x) :Scheme)))
  133.                fs:*file-type-mode-alist*)))
  134. )  ;(... ngorp) scilobmyS+#
  135.  
  136. ; Start Explorer specifics
  137. ; (Courtesy of Dan Cerys)
  138.  
  139. #+Explorer
  140. (progn
  141.  
  142. ; Define Scheme major mode for Zmacs  
  143. zwei:
  144. (defmajor com-scheme-mode scheme-mode "Scheme"
  145.       "Sets things up for editing Scheme code." ()
  146.   (setq *space-indent-flag* t)
  147.   (setq *paragraph-delimiter-list* '(#\. #\space #\tab #\"))
  148.   (setq *comment-start* 'lisp-find-comment-start-and-end)
  149.   ;;The following three are non-Zmacs vars that are made settable by the setf's below
  150.   (setq *print-array* t)            ;print arrays readably
  151.   (setq ucl:*default-prompt* 'scheme-internal:scheme-prompt-when-appropriate)
  152.   (setq ucl:*default-read-function* 'scheme-internal:scheme-read-when-apropriate)
  153.   (set-char-syntax list-slash *mode-list-syntax-table* #\\)
  154.   (set-char-syntax list-alphabetic *mode-list-syntax-table* #\/)
  155.   (set-comtab *mode-comtab*
  156.           '(#\tab com-indent-for-lisp
  157.         #\rubout com-tab-hacking-rubout
  158.         #\c-rubout com-rubout
  159.         #\m-z com-compile-and-exit
  160.         #\c-m-z com-evaluate-and-exit))
  161.   )
  162.  
  163. ; This doesn't clobber any of the other Lisp modes (eg Common Lisp), since they
  164. ; set their readtable when the major mode switch occurs.
  165. (defvar scheme-mode-hook #'(lambda ()
  166.                  (setq *readtable* roadblock-readtable))
  167.   "Simple function which specifies the use of the Scheme readtable within Scheme.")
  168.  
  169. ; Make these variables settable (and thus undoable) in Zmacs modes.
  170. (dolist (symbol '(*print-array* ucl:*default-prompt* ucl:*default-read-function*))
  171.   (setf (get symbol 'zwei:mode-settable-p) t))
  172.  
  173. ; The following must be :common-lisp rather than the more intuitive
  174. ; value of :scheme.  The purpose of this system variable is to tell the difference
  175. ; between kludgy Zetalisp and modern Common Lisp.  We are doing Scheme on top
  176. ; of Common Lisp.
  177. (defvar *scheme-value-for-sys-lisp-mode* :common-lisp "Appropriate Scheme value for the variable sys:*lisp-mode*")
  178.  
  179. ; Use the correct readtable when compiling Scheme forms/files
  180. (ticl:advise (:property :mode fs:file-attribute-bindings) :around get-scheme-bindings-if-appropriate nil
  181.   (let ((mode-keyword (third arglist)))
  182.     (if (eq :scheme mode-keyword)
  183.     (values '(sys:*lisp-mode* sys:*readtable* sys:*reader-symbol-substitutions* zwei::*default-major-mode*)
  184.         `(,*scheme-value-for-sys-lisp-mode* ,roadblock-readtable nil :scheme))
  185.     :do-it)))
  186.  
  187. ; Compile the above advice
  188. (eval-when (eval load compile)
  189.   (ticl:compile-encapsulations '(:property :mode fs:file-attribute-bindings)))
  190.  
  191. (ticl:defprop scheme-mode t zwei:all-uppercase) ;;case is insignificant
  192. (ticl:defprop scheme-mode :lisp zwei:editing-type)   ;;Scheme is Lisp
  193.  
  194. ; Handle DEFINE... top-level forms for sectionizing (yes, a hack, but this is better than including the complete function)
  195. (ticl:advise zwei:symbol-from-string :around check-for-define nil
  196.   (let ((str (first arglist))
  197.          (line (second arglist))
  198.          (sym (fourth arglist)))
  199.     (if (and (consp sym) ;;eg (foo a)
  200.          (not (null line))
  201.          (> (length line) 10.)
  202.          (string-equal "(define" line :end2 7))
  203.     (values (first sym) str)
  204.     :do-it)))
  205.  
  206. ; Compile advise
  207. (eval-when (eval load compile)
  208.   (ticl:compile-encapsulations 'zwei:symbol-from-string))
  209.  
  210. ; Treat "SCM" just like "LISP"
  211. (let ((type (string *scheme-file-type*)))
  212.   (cond ((not (member type fs:*its-uninteresting-types* :test #'equal))
  213.      (push type fs:*its-uninteresting-types*))))
  214.  
  215. ; "One should always use canonical types"
  216. (fs:define-canonical-type :scheme #,*scheme-file-type*) ;Scheme source
  217.  
  218. ; Default Zmacs Major Mode for Scheme source is Scheme
  219. (unless (assoc :scheme fs:*file-type-mode-alist*)
  220.   (setq fs:*file-type-mode-alist*
  221.     (append fs:*file-type-mode-alist* (list (cons :scheme :scheme)))))
  222.  
  223. ; Make Scheme Mode accessible
  224. (zwei:set-comtab zwei:*standard-comtab*
  225.          '()
  226.          (zwei:make-command-alist '(zwei:com-scheme-mode)))
  227.  
  228. (defun in-scheme? ()
  229.   "Boolean, which is true when we are in Scheme, meaning that the current package
  230. is the Scheme package."
  231.   (eq? *package* scheme-package))
  232.  
  233. (defvar *saved-prompt*  ucl:*default-prompt*
  234.   "Saved old prompt; used when we temporarily want to set it")     
  235.  
  236. (defun scheme-prompt-when-appropriate ()
  237.   "When in Scheme (using the Scheme package), present the user with the Scheme prompt (==>),
  238. else use the standard default prompt."
  239.   (let* ((scheme-prompt "==> ")
  240.      (default-non-scheme-prompt "> ")
  241.      (prompt (if (eq *saved-prompt* 'scheme-prompt-when-appropriate)
  242.              default-non-scheme-prompt
  243.              *saved-prompt*))) ;avoid infinite loop
  244.     (if (in-scheme?)
  245.       scheme-prompt
  246.       (if (stringp prompt)            ; can either be a string or a function
  247.       prompt
  248.       (funcall prompt)))))
  249.  
  250. (defvar *saved-read-function* ucl:*default-read-function*)
  251.  
  252. (defun scheme-read-when-apropriate ()
  253.   "When in Scheme (using the Scheme package), do Scheme preprocessing."
  254.   (let* ((read-function (if (eq *saved-read-function*  ucl:*default-read-function*)
  255.                 'ucl:read-for-ucl    ;avoid endless recursion
  256.                 *saved-read-function*))
  257.      (expression (funcall read-function)))
  258.     (if (in-scheme?)
  259.     (translate-in-context expression *current-rep-context*)
  260.     expression)))
  261.  
  262. ) ;(... ngorp) rerolpxE+#
  263.  
  264. ; end Explorer specific things
  265.