home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / NotInROM / NotInROM-u.lisp < prev    next >
Encoding:
Text File  |  1992-02-21  |  6.0 KB  |  174 lines
  1. ;; -*- package: NotInROM -*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;; NotInROM-u.Lisp
  4. ;;
  5. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  6. ;; All Rights Reserved
  7. ;;
  8. ;; author: Michael S. Engber
  9. ;;
  10. ;; Provides a syntax for defining and calling "Not in ROM" ToolBox Routines
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;; 
  15. ;; Modification History
  16. ;;
  17. ;; 02/11/92 bill   EXPORT goes after IN-PACKAGE, PROVIDE at end of file.
  18. ;;
  19.  
  20. (defpackage :NotInROM
  21.   (:use :common-lisp :common-lisp-user :ccl))
  22.  
  23. (in-package :NotInROM)
  24.  
  25. (export '(require-trap-NotInROM deftrap-NotInROM deftrap-alt-name))
  26.  
  27. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  28.  
  29.  
  30. ;; for Not in ROM traps requiring a fn defn
  31. (defmacro deftrap-NotInROM (symbol result-type (&rest typed-arglist) &body body)
  32.   (declare (ignore result-type))
  33.   (let* ((trap-sym       (ensure-trap-sym symbol))
  34.          (fn-sym         (gen-NIR-fn-sym trap-sym))
  35.          (macro-sym      (gen-NIR-macro-sym trap-sym))
  36.          (arglist        (mapcar #'first typed-arglist))
  37.          (type-spec-list (mapcar #'second typed-arglist)))
  38.     
  39.     `(eval-when (:compile-toplevel :load-toplevel :execute)
  40.        (setf (get ',trap-sym :NotInROM-fn-sym)    ',fn-sym)
  41.        (setf (get ',trap-sym :NotInROM-macro-sym) ',macro-sym)
  42.        
  43.        (defmacro ,macro-sym ,arglist
  44.          (NIR-arglist-check ',fn-sym ',arglist ',type-spec-list)
  45.          `(,',fn-sym ,,@arglist))
  46.        
  47.        (defun ,fn-sym ,arglist ,@body))))
  48.  
  49.  
  50. ;; for Not in ROM traps simply requiring a renaming
  51. (defmacro deftrap-alt-name (alt-trap-symbol asm-trap-symbol)
  52.   (let ((alt-trap-sym (ensure-trap-sym alt-trap-symbol))
  53.         (asm-trap-sym (ensure-trap-sym asm-trap-symbol)))
  54.     `(eval-when (:compile-toplevel :load-toplevel :execute)
  55.        (setf (get ',alt-trap-sym :NotInROM-macro-sym) ',asm-trap-sym))))
  56.  
  57.  
  58. ;;analogous to require-trap
  59. (defmacro require-trap-NotInROM (trap-symbol &rest arglist)
  60.   (if (trap-prefixp trap-symbol)
  61.     `(require-trap ,trap-symbol ,@arglist)
  62.     `(,trap-symbol ,@arglist)))
  63.  
  64. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  65.  
  66.  
  67. ;;takes a potential trap symbol, makes sure it in the right package and begins with an _
  68. (defun ensure-trap-sym (symbol)
  69.   (if (trap-prefixp symbol)
  70.     (if (eq (symbol-package symbol) ccl::*traps-package*)
  71.       symbol
  72.       (intern (symbol-name symbol) :traps))
  73.     (error "trap symbol ~s does not start with an _" symbol)))
  74.  
  75. ;;generates a symbol for the Not in ROM fn
  76. (defun gen-NIR-fn-sym (symbol)
  77.   (intern (concatenate 'string "NIR" (symbol-name symbol)) :traps))
  78.  
  79. ;;generates a symbol for the macro to do compile time arg checking for the Not in ROM fn
  80. (defun gen-NIR-macro-sym (symbol)
  81.   (intern (concatenate 'string "TCHECK-NIR" (symbol-name symbol)) :traps))
  82.  
  83. ;;checks if a symbol starts with an _
  84. (defun trap-prefixp (symbol)
  85.   (char= #\_ (char (symbol-name symbol) 0)))
  86.  
  87. ;;compile time type checking
  88. (defun NIR-arglist-check (fn-symbol arglist type-spec-list)
  89.   (flet ((arg-check (arg type-spec)
  90.            (when (constantp arg)
  91.              (unless (funcall (ccl::mactype-ct-type-check (ccl::find-arg-mactype type-spec))
  92.                               (typecase arg (symbol (symbol-value arg)) (t arg)))
  93.                (error "~s value ~s is not of expected type: ~s" fn-symbol arg type-spec)))))
  94.     (declare (dynamic-extent #'arg-check))
  95.     (mapc #'arg-check arglist type-spec-list)))
  96.  
  97.  
  98. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99. ;;stream for reading symbols adding an underscore prefix
  100.  
  101. (defclass 1char-prefix-stream (input-stream)
  102.   ((prefix-char   :accessor prefix-char
  103.                   :initform nil)
  104.    (suffix-stream :accessor suffix-stream)))
  105.  
  106. (defmethod stream-tyi ((s 1char-prefix-stream))
  107.   (if (and (prefix-char s) (not (stream-eofp (suffix-stream s))))
  108.     (prog1 (prefix-char s) (setf (prefix-char s) nil))
  109.     (stream-tyi (suffix-stream s))))
  110.  
  111. (defmethod stream-untyi ((s 1char-prefix-stream) char)
  112.   (setf (prefix-char s) char))
  113.  
  114. (defvar *prefix-stream* (make-instance '1char-prefix-stream))
  115.  
  116. ;;reads in the next symbol from the stream into the traps package, prepending an _
  117. (defun read-trap-sym (stream)
  118.   (let ((prefix-stream (or *prefix-stream* (make-instance '1char-prefix-stream)))
  119.         (*prefix-stream* nil))
  120.     (setf (suffix-stream prefix-stream) stream)
  121.     (unread-char #\_ prefix-stream)
  122.     (let ((*package* ccl::*traps-package*))
  123.       (read prefix-stream t nil t))))
  124.  
  125.  
  126. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  127. ;;#~ dispatching macro char
  128.  
  129. ;;This is my chance to map a symbol to something else, like a Not In ROM macro or fn.
  130. ;; It would be nice to auto-load any necessary defns at this point too.
  131. ;; But that's not currently implemented.
  132. (defun NotInROM-lookup (symbol)
  133.   (or (get symbol :NotInROM-macro-sym) (get symbol :NotInROM-fn-sym) symbol))
  134.  
  135.  
  136. (defun NotInROM-dispatch (s macro-char int)
  137.   (declare (ignore macro-char))
  138.   
  139.   (when (and int (not *read-suppress*))
  140.     (error "Reader dispatch macro character #\~ doesn't take an argument."))
  141.  
  142.   (let* ((symbol (NotInROM-lookup (read-trap-sym s))))
  143.     (unless *read-suppress*
  144.       (when (eq symbol 'traps::_)
  145.         (error "illegal form following #~~ : ~s" (read s t nil t)))
  146.  
  147.       ;;if it turns out to be a regular trap symbol we must load it
  148.       (when (trap-prefixp symbol) (ccl::load-trap symbol)))
  149.     
  150.     symbol))
  151.  
  152. (set-dispatch-macro-character #\# #\~ #'NotInROM-dispatch)
  153.  
  154.  
  155. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  156.  
  157. #|
  158.  
  159. ;;This cryptic fn tests if a trap is in the index. If so, it returns
  160. ;;the trap's name, else nil. It uses undocumented ccl fns so it may break
  161. ;;someday.
  162.  
  163. ;; originally I thought I'd need this fn, but I haven't so far
  164. (defun trap-indexed-p (trap-symbol)
  165.   (ccl::find-interface-entry trap-symbol
  166.                              ccl::*traps-index-file* 
  167.                              'ccl::*traps-index-stream*
  168.                              nil nil nil nil nil))
  169.  
  170.  
  171. |#
  172.  
  173. (provide :NotInROM-u)
  174.