home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / DISCLOSE.SCM < prev    next >
Text File  |  1992-06-17  |  3KB  |  88 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ; Disclosers, etc.
  4.  
  5.  
  6. ; Make prettier error messages for exceptions
  7.  
  8. (define-method disclose-condition-methods (make-class 'exception 0)
  9.   (lambda (c)
  10.     (if (exception? c)
  11.     (let ((opcode (exception-opcode c))
  12.           (args   (exception-arguments c)))
  13.       (cond ((or (= opcode op/global)
  14.              (= opcode op/set-global!))
  15.          (let ((loc (car args)))
  16.            (list 'error
  17.              (if (location-defined? loc)
  18.                  "unassigned variable"
  19.                  "undefined variable")
  20.              (or (location-name loc) loc))))
  21.         ((or (= opcode op/check-nargs=)
  22.              (= opcode op/check-nargs>=))
  23.          (let ((proc (car args))
  24.                (as (cadr args)))
  25.            (list 'error
  26.              "wrong number of arguments"
  27.              (error-form (or (and (closure? proc)
  28.                           (template-name
  29.                             (closure-template proc)))
  30.                      proc)
  31.                      as))))
  32.         ((= opcode op/call)
  33.          (list 'error
  34.                "attempt to call a non-procedure"
  35.                (map value->expression (cons (car args) (cadr args)))))
  36.         (else
  37.          (list 'error
  38.                "exception"
  39.                (let ((name (enumerand->name opcode op)))
  40.              (if (>= opcode op/eq?)
  41.                  (error-form name args)
  42.                  (cons name args)))))))
  43.     (fail))))
  44.  
  45. ; Print methods (were in rtsistruct.scm)
  46.  
  47. (define-method disclose-methods (make-class 'closure 0)
  48.   (lambda (obj)
  49.     (if (closure? obj)
  50.     (let ((id (template-id (closure-template obj)))
  51.           (name (template-name (closure-template obj))))
  52.       (if name
  53.           (list 'procedure id name)
  54.           (list 'procedure id)))
  55.     (fail))))
  56.  
  57. (define-method disclose-methods (make-class 'location 0)
  58.   (lambda (obj)
  59.     (if (location? obj)
  60.     (cons 'location
  61.           (cons (location-id obj)
  62.             (let ((name (location-name obj)))
  63.               (if (and name (not (eq? name (location-id obj))))
  64.               (list name)
  65.               '()))))
  66.         (fail))))
  67.  
  68. (define-method disclose-methods (make-class 'continuation 0)
  69.   (lambda (obj)
  70.     (if (continuation? obj)
  71.         (list 'continuation
  72.           (list 'pc (continuation-pc obj))
  73.           (let ((tem (continuation-template obj)))
  74.         (or (template-name tem) (template-id tem))))
  75.         (fail))))
  76.  
  77. (define-method disclose-methods (make-class 'code-vector 0)
  78.   (lambda (obj)
  79.     (if (code-vector? obj)
  80.     (list 'code-vector (code-vector-length obj))
  81. ;        (cons 'code-vector
  82. ;              (let ((z (code-vector-length obj)))
  83. ;                (do ((i (- z 1) (- i 1))
  84. ;                     (l '() (cons (code-vector-ref obj i) l)))
  85. ;                    ((< i 0) l))))
  86.     (fail))))
  87.  
  88.