home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / uerror.scm < prev    next >
Text File  |  2001-03-21  |  41KB  |  1,072 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: uerror.scm,v 14.47 2001/03/21 19:15:22 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Microcode Errors
  24. ;;; package: (runtime microcode-errors)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define condition-type:anomalous-microcode-error)
  29. (define condition-type:compiled-code-error)
  30. (define condition-type:fasdump-environment)
  31. (define condition-type:fasl-file-bad-data)
  32. (define condition-type:fasl-file-compiled-mismatch)
  33. (define condition-type:fasl-file-too-big)
  34. (define condition-type:fasload-band)
  35. (define condition-type:fasload-error)
  36. (define condition-type:hardware-trap)
  37. (define condition-type:impurify-object-too-large)
  38. (define condition-type:inapplicable-object)
  39. (define condition-type:out-of-file-handles)
  40. (define condition-type:primitive-io-error)
  41. (define condition-type:primitive-procedure-error)
  42. (define condition-type:system-call-error)
  43. (define condition-type:unimplemented-primitive)
  44. (define condition-type:unimplemented-primitive-for-os)
  45. (define condition-type:unlinkable-variable)
  46. (define condition-type:user-microcode-reset)
  47. (define condition-type:wrong-arity-primitives)
  48.  
  49. (define error-handler-vector)
  50. (define default-error-handler)
  51.  
  52. (define (define-error-handler error-name handler)
  53.   (vector-set! error-handler-vector
  54.            (or (microcode-error/name->code error-name)
  55.            (error "Unknown microcode error name:" error-name))
  56.            (lambda (error-code interrupt-enables)
  57.          (set-interrupt-enables! interrupt-enables)
  58.          (call-with-current-continuation
  59.           (lambda (continuation)
  60.             (handler continuation)
  61.             (default-error-handler continuation error-code))))))
  62.  
  63. (define (define-low-level-handler error-name handler)
  64.   (vector-set! error-handler-vector
  65.            (microcode-error/name->code error-name)
  66.            (lambda (error-code interrupt-enables)
  67.          (set-interrupt-enables! interrupt-enables)
  68.          (call-with-current-continuation
  69.           (lambda (continuation)
  70.             (handler continuation error-code)
  71.             (default-error-handler continuation error-code))))))
  72.  
  73. (define (condition-signaller type field-names)
  74.   (let ((make-condition (condition-constructor type field-names)))
  75.     (lambda (continuation . field-values)
  76.       (error (apply make-condition
  77.             (cons* continuation
  78.                'BOUND-RESTARTS
  79.                field-values))))))
  80.  
  81. ;;;; Restart Bindings
  82.  
  83. (define (unbound-variable/store-value continuation environment name thunk)
  84.   (with-restart 'STORE-VALUE
  85.       (lambda (port)
  86.     (write-string "Define " port)
  87.     (write name port)
  88.     (write-string " to a given value." port))
  89.       (lambda (value)
  90.     (local-assignment environment name value)
  91.     (continuation unspecific))
  92.       (let ((prompt (string-append "Define " (write-to-string name) " as")))
  93.     (lambda ()
  94.       (values (prompt-for-evaluated-expression prompt environment))))
  95.     thunk))
  96.  
  97. (define (unassigned-variable/store-value continuation environment name thunk)
  98.   (with-restart 'STORE-VALUE
  99.       (lambda (port)
  100.     (write-string "Set " port)
  101.     (write name port)
  102.     (write-string " to a given value." port))
  103.       (lambda (value)
  104.     (environment-assign! environment name value)
  105.     (continuation unspecific))
  106.       (let ((prompt (string-append "Set " (write-to-string name) " to")))
  107.     (lambda ()
  108.       (values (prompt-for-evaluated-expression prompt environment))))
  109.     thunk))
  110.  
  111. (define (variable/use-value continuation environment name thunk)
  112.   (let ((continuation (continuation/next-continuation continuation)))
  113.     (if (continuation-restartable? continuation)
  114.     (with-restart 'USE-VALUE
  115.         (lambda (port)
  116.           (write-string "Specify a value to use instead of " port)
  117.           (write name port)
  118.           (write-string "." port))
  119.         continuation
  120.         (let ((prompt
  121.            (string-append "Value to use instead of "
  122.                   (write-to-string name))))
  123.           (lambda ()
  124.         (values
  125.          (prompt-for-evaluated-expression prompt environment))))
  126.       thunk)
  127.     (thunk))))
  128.  
  129. (define (inapplicable-object/use-value continuation operands thunk)
  130.   (let ((continuation (continuation/next-continuation continuation)))
  131.     (if (continuation-restartable? continuation)
  132.     (with-restart 'USE-VALUE "Specify a procedure to use in its place."
  133.         (lambda (operator)
  134.           (within-continuation continuation
  135.         (lambda ()
  136.           (apply operator operands))))
  137.         (lambda ()
  138.           (values (prompt-for-evaluated-expression "New procedure")))
  139.       thunk)
  140.     (thunk))))
  141.  
  142. (define (illegal-arg-signaller type)
  143.   (let ((signal (condition-signaller type '(DATUM OPERATOR OPERAND))))
  144.     (lambda (continuation operator operands index)
  145.       (illegal-argument/use-value continuation operator operands index
  146.     (lambda ()
  147.       (signal continuation (list-ref operands index) operator index))))))
  148.  
  149. (define (illegal-argument/use-value continuation operator operands index thunk)
  150.   (let ((continuation
  151.      (continuation/next-continuation/no-compiled-code continuation)))
  152.     (if (continuation-restartable? continuation)
  153.     (with-restart 'USE-VALUE "Specify an argument to use in its place."
  154.         (lambda (operand)
  155.           (within-continuation continuation
  156.         (lambda ()
  157.           (apply operator
  158.              (substitute-element operands index operand)))))
  159.         (lambda ()
  160.           (values (prompt-for-evaluated-expression "New argument")))
  161.       thunk)
  162.     (thunk))))
  163.  
  164. (define (file-operation-signaller)
  165.   (let ((signal
  166.      (condition-signaller condition-type:file-operation-error
  167.                   '(FILENAME VERB NOUN REASON OPERATOR OPERANDS))))
  168.     (lambda (continuation operator operands index verb noun reason)
  169.       (file-operation/use-value continuation operator operands index verb noun
  170.     (lambda ()
  171.       (file-operation/retry continuation operator operands verb noun
  172.         (lambda ()
  173.           (signal continuation (list-ref operands index)
  174.               verb noun reason operator operands))))))))
  175.  
  176. (define (file-operation/use-value continuation operator operands index
  177.                   verb noun thunk)
  178.   (let ((continuation (continuation/next-continuation continuation)))
  179.     (if (continuation-restartable? continuation)
  180.     (with-restart 'USE-VALUE
  181.         (string-append "Try to " verb " a different " noun ".")
  182.         (lambda (operand)
  183.           (within-continuation continuation
  184.         (lambda ()
  185.           (apply operator
  186.              (substitute-element operands index operand)))))
  187.         (let ((prompt
  188.            (string-append "New "
  189.                   noun
  190.                   " name (an expression to be evaluated)")))
  191.           (lambda ()
  192.         (values (prompt-for-evaluated-expression prompt))))
  193.       thunk)
  194.     (thunk))))
  195.  
  196. (define (file-operation/retry continuation operator operands verb noun thunk)
  197.   (let ((continuation (continuation/next-continuation continuation)))
  198.     (if (continuation-restartable? continuation)
  199.     (with-restart 'RETRY
  200.         (string-append "Try to " verb " the same " noun " again.")
  201.         (lambda ()
  202.           (within-continuation continuation
  203.         (lambda ()
  204.           (apply operator operands))))
  205.         values
  206.       thunk)
  207.     (thunk))))
  208.  
  209. (define (substitute-element list index element)
  210.   (let loop ((list list) (i 0))
  211.     (if (= i index)
  212.     (cons element (cdr list))
  213.     (cons (car list) (loop (cdr list) (+ i 1))))))
  214.  
  215. ;;;; Continuation Parsing
  216.  
  217. (define (continuation/next-continuation continuation)
  218.   (let ((first-subproblem (continuation/first-subproblem continuation)))
  219.     (and first-subproblem
  220.      (let ((next-subproblem (stack-frame/next first-subproblem)))
  221.        (and next-subproblem
  222.         (stack-frame->continuation next-subproblem))))))
  223.  
  224. ;; With the 8.0 compiler, we do not want to restart a primitive that
  225. ;; signalled a bad argument type or range.  This allows the compiler
  226. ;; to generate better code. We return #F if the continuation is an
  227. ;; apply frame of a primitive called from compiled code:
  228.  
  229. (define (continuation/next-continuation/no-compiled-code continuation)
  230.   (let ((first-subproblem (continuation/first-subproblem continuation)))
  231.     (and first-subproblem
  232.      (let ((next-subproblem (stack-frame/next first-subproblem)))
  233.        (and next-subproblem
  234.         (if (and (apply-frame? first-subproblem)
  235.              (primitive-procedure?
  236.               (apply-frame/operator first-subproblem))
  237.              (let ((further-subproblem
  238.                 (stack-frame/next next-subproblem)))
  239.                (stack-frame/compiled-code? further-subproblem)))
  240.             #F
  241.             (stack-frame->continuation next-subproblem)))))))
  242.  
  243. (define (continuation-restartable? continuation)
  244.   continuation)
  245.  
  246. (define-integrable (frame/type frame)
  247.   (microcode-return/code->name (stack-frame/return-code frame)))
  248.  
  249. (define (apply-frame? frame)
  250.   (let ((code (stack-frame/return-code frame)))
  251.     (and code
  252.      (or (= return-code:internal-apply code)
  253.          (= return-code:internal-apply-val code)))))
  254.  
  255. (define-integrable (apply-frame/operator frame)
  256.   (stack-frame/ref frame 3))
  257.  
  258. (define-integrable (apply-frame/operand frame index)
  259.   (stack-frame/ref frame (+ 4 index)))
  260.  
  261. (define (apply-frame/operands frame)
  262.   (let ((elements (stack-frame/elements frame)))
  263.     (subvector->list elements 4 (vector-length elements))))
  264.  
  265. (define-integrable (eval-frame/expression frame)
  266.   (stack-frame/ref frame 1))
  267.  
  268. (define-integrable (eval-frame/environment frame)
  269.   (stack-frame/ref frame 2))
  270.  
  271. (define (pop-return-frame/value continuation)
  272.   (let loop ((frame (continuation->stack-frame continuation)))
  273.     (if (or (not frame) (stack-frame/subproblem? frame))
  274.     (error "Can't find POP-RETURN-ERROR frame."))
  275.     (if (let ((code (stack-frame/return-code frame)))
  276.       (and code
  277.            (= return-code:pop-return-error code)))
  278.     (stack-frame/ref frame 1)
  279.     (loop (stack-frame/next frame)))))
  280.  
  281. (define-integrable (reference-trap-frame/name frame)
  282.   (stack-frame/ref frame 2))
  283.  
  284. (define-integrable (reference-trap-frame/environment frame)
  285.   (stack-frame/ref frame 3))
  286.  
  287. (define-integrable (compiled-code-error-frame? frame)
  288.   (let ((code (stack-frame/return-code frame)))
  289.     (and code
  290.      (= return-code:compiler-error-restart code))))
  291.  
  292. (define-integrable (compiled-code-error-frame/irritant frame)
  293.   (stack-frame/ref frame 2))
  294.  
  295. (define return-code:internal-apply)
  296. (define return-code:internal-apply-val)
  297. (define return-code:pop-return-error)
  298. (define return-code:compiler-error-restart)
  299.  
  300. ;;;; Utilities
  301.  
  302. (define (error-type->string error-type)
  303.   (or (and (string? error-type)
  304.        error-type)
  305.       (let ((code
  306.          (if (symbol? error-type)
  307.          (microcode-system-call-error/name->code error-type)
  308.          (and (exact-nonnegative-integer? error-type) error-type))))
  309.     (and code
  310.          ((ucode-primitive system-call-error-message 1) code)))
  311.       (if (symbol? error-type)
  312.       (string-replace (symbol-name error-type) #\- #\space)
  313.       (string-append "error " (write-to-string error-type)))))
  314.  
  315. (define (normalize-trap-code-name name)
  316.   (let loop ((prefixes '("floating-point " "integer ")))
  317.     (if (not (null? prefixes))
  318.     (if (string-prefix-ci? (car prefixes) name)
  319.         (set! name (string-tail name (string-length (car prefixes))))
  320.         (loop (cdr prefixes)))))
  321.   (let loop ((suffixes '(" trap" " fault")))
  322.     (if (not (null? suffixes))
  323.     (if (string-suffix-ci? (car suffixes) name)
  324.         (set! name
  325.           (string-head name
  326.                    (- (string-length name)
  327.                   (string-length (car suffixes)))))
  328.         (loop (cdr suffixes)))))
  329.   (cond ((string-ci=? "underflow" name) 'UNDERFLOW)
  330.     ((string-ci=? "overflow" name) 'OVERFLOW)
  331.     ((or (string-ci=? "divide by 0" name)
  332.          (string-ci=? "divide by zero" name))
  333.      'DIVIDE-BY-ZERO)
  334.     (else false)))
  335.  
  336. (define (file-primitive-description primitive)
  337.   (cond ((eq? primitive (ucode-primitive file-exists? 1))
  338.      (values "determine existence of" "file"))
  339.     ((or (eq? primitive (ucode-primitive file-directory? 1))
  340.          (eq? primitive (ucode-primitive file-soft-link? 1)))
  341.      (values "determine type of" "file"))
  342.     ((or (eq? primitive (ucode-primitive file-open-append-channel 1))
  343.          (eq? primitive (ucode-primitive file-open-input-channel 1))
  344.          (eq? primitive (ucode-primitive file-open-io-channel 1))
  345.          (eq? primitive (ucode-primitive file-open-output-channel 1))
  346.          (eq? primitive (ucode-primitive new-file-open-append-channel 2))
  347.          (eq? primitive (ucode-primitive new-file-open-input-channel 2))
  348.          (eq? primitive (ucode-primitive new-file-open-io-channel 2))
  349.          (eq? primitive (ucode-primitive new-file-open-output-channel 2)))
  350.      (values "open" "file"))
  351.     ((eq? primitive (ucode-primitive new-directory-open 1))
  352.      (values "open" "directory"))
  353.     ((or (eq? primitive (ucode-primitive file-modes 1))
  354.          (eq? primitive (ucode-primitive file-access 2)))
  355.      (values "read permissions of" "file"))
  356.     ((eq? primitive (ucode-primitive set-file-modes! 2))
  357.      (values "set permissions of" "file"))
  358.     ((or (eq? primitive (ucode-primitive file-mod-time 1))
  359.          (eq? primitive (ucode-primitive file-mod-time-indirect 1)))
  360.      (values "read modification time of" "file"))
  361.     ((or (eq? primitive (ucode-primitive file-attributes 1))
  362.          (eq? primitive (ucode-primitive file-attributes-indirect 1)))
  363.      (values "read attributes of" "file"))
  364.     ((eq? primitive (ucode-primitive directory-make 1))
  365.      (values "create" "directory"))
  366.     ((eq? primitive (ucode-primitive directory-delete 1))
  367.      (values "delete" "directory"))
  368.     ((eq? primitive (ucode-primitive file-copy 2))
  369.      (values "copy" "file"))
  370.     ((or (eq? primitive (ucode-primitive file-link-hard 2))
  371.          (eq? primitive (ucode-primitive file-link-soft 2))
  372.          (eq? primitive (ucode-primitive link-file 3)))
  373.      (values "link" "file"))
  374.     ((or (eq? primitive (ucode-primitive file-remove 1))
  375.          (eq? primitive (ucode-primitive file-remove-link 1)))
  376.      (values "delete" "file"))
  377.     ((eq? primitive (ucode-primitive file-rename 2))
  378.      (values "rename" "file"))
  379.     ((eq? primitive (ucode-primitive file-touch 1))
  380.      (values "touch" "file"))
  381.     (else
  382.      (values false false))))
  383.  
  384. (define (initialize-package!)
  385.  
  386. (set! return-code:internal-apply
  387.   (microcode-return/name->code 'INTERNAL-APPLY))
  388.  
  389. (set! return-code:internal-apply-val
  390.   (microcode-return/name->code 'INTERNAL-APPLY-VAL))
  391.  
  392. (set! return-code:pop-return-error
  393.   (microcode-return/name->code 'POP-RETURN-ERROR))
  394.  
  395. (set! return-code:compiler-error-restart
  396.   (microcode-return/name->code 'COMPILER-ERROR-RESTART))
  397.  
  398. (set! error-handler-vector
  399.   (make-vector (microcode-error/code-limit)
  400.            (lambda (error-code interrupt-enables)
  401.          (set-interrupt-enables! interrupt-enables)
  402.          (call-with-current-continuation
  403.           (lambda (continuation)
  404.             (default-error-handler continuation error-code))))))
  405.  
  406. (set! condition-type:anomalous-microcode-error
  407.   (make-condition-type 'ANOMALOUS-MICROCODE-ERROR condition-type:error
  408.       '(ERROR-CODE EXTRA)
  409.     (lambda (condition port)
  410.       (write-string "Anomalous microcode error " port)
  411.       (write (access-condition condition 'ERROR-CODE) port)
  412.       (write-string " -- get a wizard." port))))
  413.  
  414. (set! default-error-handler
  415.   (let ((signal
  416.      (condition-signaller condition-type:anomalous-microcode-error
  417.                   '(ERROR-CODE EXTRA))))
  418.     (lambda (continuation error-code)
  419.       (let ((doit
  420.          (lambda (error-code extra)
  421.            (signal continuation
  422.                (or (and (exact-nonnegative-integer? error-code)
  423.                 (microcode-error/code->name error-code))
  424.                error-code)
  425.                extra))))
  426.     (if (vector? error-code)
  427.         (doit (vector-ref error-code 0)
  428.           (subvector->list error-code 1 (vector-length error-code)))
  429.         (doit error-code '()))))))
  430.  
  431. (define-low-level-handler 'ERROR-WITH-ARGUMENT
  432.   (lambda (continuation argument)
  433.     ((if (and (vector? argument)
  434.           (fix:>= (vector-length argument) 1)
  435.           (eqv? (vector-ref argument 0)
  436.             (microcode-error/name->code 'SYSTEM-CALL)))
  437.      system-call-error-handler
  438.      default-error-handler)
  439.      continuation
  440.      argument)))
  441.  
  442. (let ((fixed-objects (get-fixed-objects-vector)))
  443.   (vector-set! fixed-objects
  444.            (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR)
  445.            error-handler-vector)
  446.   (vector-set! fixed-objects
  447.            (fixed-objects-vector-slot 'ERROR-PROCEDURE)
  448.            (lambda (datum arguments environment)
  449.          environment
  450.          (apply error (cons* datum arguments))))
  451.   (vector-set! fixed-objects
  452.            (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE)
  453.            error)
  454.   ((ucode-primitive set-fixed-objects-vector!) fixed-objects))
  455.  
  456. ;;;; Variable Errors
  457.  
  458. (define-error-handler 'UNBOUND-VARIABLE
  459.   (let ((signal
  460.      (condition-signaller condition-type:unbound-variable
  461.                   '(ENVIRONMENT LOCATION))))
  462.     (lambda (continuation)
  463.       (let ((signal-reference
  464.          (lambda (environment name)
  465.            (unbound-variable/store-value continuation environment name
  466.          (lambda ()
  467.            (variable/use-value continuation environment name
  468.              (lambda ()
  469.                (signal continuation environment name)))))))
  470.         (signal-other
  471.          (lambda (environment name)
  472.            (unbound-variable/store-value continuation environment name
  473.          (lambda ()
  474.            (signal continuation environment name)))))
  475.         (frame (continuation/first-subproblem continuation)))
  476.     (case (frame/type frame)
  477.       ((EVAL-ERROR)
  478.        (let ((expression (eval-frame/expression frame)))
  479.          (if (variable? expression)
  480.          (signal-reference (eval-frame/environment frame)
  481.                    (variable-name expression)))))
  482.       ((ASSIGNMENT-CONTINUE)
  483.        (signal-other (eval-frame/environment frame)
  484.              (assignment-name (eval-frame/expression frame))))
  485.       ((ACCESS-CONTINUE)
  486.        (signal-reference (pop-return-frame/value continuation)
  487.                  (access-name (eval-frame/expression frame))))
  488.       ((INTERNAL-APPLY INTERNAL-APPLY-VAL)
  489.        (let ((operator (apply-frame/operator frame)))
  490.          (cond ((eq? (ucode-primitive lexical-reference) operator)
  491.             (signal-reference (apply-frame/operand frame 0)
  492.                       (apply-frame/operand frame 1)))
  493.            ((eq? (ucode-primitive lexical-assignment) operator)
  494.             (signal-other (apply-frame/operand frame 0)
  495.                   (apply-frame/operand frame 1)))
  496.            ((eq? (ucode-primitive add-fluid-binding! 3) operator)
  497.             (signal-other (apply-frame/operand frame 0)
  498.                   (let ((name (apply-frame/operand frame 1)))
  499.                     (if (variable? name)
  500.                     (variable-name name)
  501.                     name))))
  502.            ((eq? (ucode-primitive environment-link-name) operator)
  503.             (signal-other (apply-frame/operand frame 0)
  504.                   (apply-frame/operand frame 2)))
  505.            ((eq? (ucode-primitive lexical-unassigned?) operator)
  506.             (signal-other (apply-frame/operand frame 0)
  507.                   (apply-frame/operand frame 1))))))
  508.       ((COMPILER-REFERENCE-TRAP-RESTART
  509.         COMPILER-SAFE-REFERENCE-TRAP-RESTART)
  510.        (signal-reference (reference-trap-frame/environment frame)
  511.                  (reference-trap-frame/name frame)))
  512.       ((COMPILER-ASSIGNMENT-TRAP-RESTART
  513.         COMPILER-UNASSIGNED?-TRAP-RESTART
  514.         COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)
  515.        (signal-other (reference-trap-frame/environment frame)
  516.              (reference-trap-frame/name frame))))))))
  517.  
  518. (define-error-handler 'UNASSIGNED-VARIABLE
  519.   (let ((signal
  520.      (condition-signaller condition-type:unassigned-variable
  521.                   '(ENVIRONMENT LOCATION))))
  522.     (lambda (continuation)
  523.       (let ((signal
  524.          (lambda (environment name)
  525.            (unassigned-variable/store-value continuation environment name
  526.          (lambda ()
  527.            (variable/use-value continuation environment name
  528.              (lambda ()
  529.                (signal continuation environment name)))))))
  530.         (frame (continuation/first-subproblem continuation)))
  531.     (case (frame/type frame)
  532.       ((EVAL-ERROR)
  533.        (let ((expression (eval-frame/expression frame)))
  534.          (if (variable? expression)
  535.          (signal (eval-frame/environment frame)
  536.              (variable-name expression)))))
  537.       ((ACCESS-CONTINUE)
  538.        (signal (pop-return-frame/value continuation)
  539.            (access-name (eval-frame/expression frame))))
  540.       ((INTERNAL-APPLY INTERNAL-APPLY-VAL)
  541.        (if (eq? (ucode-primitive lexical-reference)
  542.             (apply-frame/operator frame))
  543.            (signal (apply-frame/operand frame 0)
  544.                (apply-frame/operand frame 1))))
  545.       ((COMPILER-REFERENCE-TRAP-RESTART
  546.         COMPILER-OPERATOR-LOOKUP-TRAP-RESTART)
  547.        (signal (reference-trap-frame/environment frame)
  548.            (reference-trap-frame/name frame))))))))
  549.  
  550. (set! condition-type:unlinkable-variable
  551.   (make-condition-type 'UNLINKABLE-VARIABLE condition-type:variable-error '()
  552.     (lambda (condition port)
  553.       (write-string "The variable " port)
  554.       (write (access-condition condition 'LOCATION) port)
  555.       (write-string " is already bound; it cannot be linked to." port))))
  556.  
  557. (define-error-handler 'BAD-ASSIGNMENT
  558.   (let ((signal
  559.      (condition-signaller condition-type:unlinkable-variable
  560.                   '(ENVIRONMENT LOCATION))))
  561.     (lambda (continuation)
  562.       (let ((frame (continuation/first-subproblem continuation)))
  563.     (if (and (apply-frame? frame)
  564.          (eq? (ucode-primitive environment-link-name)
  565.               (apply-frame/operator frame)))
  566.         (signal continuation
  567.             (apply-frame/operand frame 0)
  568.             (apply-frame/operand frame 2)))))))
  569.  
  570. ;;;; Argument Errors
  571.  
  572. (define signal-bad-range-argument
  573.   (illegal-arg-signaller condition-type:bad-range-argument))
  574.  
  575. (define signal-wrong-type-argument
  576.   (illegal-arg-signaller condition-type:wrong-type-argument))
  577.  
  578. (define (define-arg-error error-code n signal)
  579.   (define-error-handler error-code
  580.     (lambda (continuation)
  581.       (let ((frame (continuation/first-subproblem continuation)))
  582.     (if (apply-frame? frame)
  583.         (signal continuation
  584.             (apply-frame/operator frame)
  585.             (apply-frame/operands frame)
  586.             n))))))
  587.  
  588. (define-arg-error 'BAD-RANGE-ARGUMENT-0 0 signal-bad-range-argument)
  589. (define-arg-error 'BAD-RANGE-ARGUMENT-1 1 signal-bad-range-argument)
  590. (define-arg-error 'BAD-RANGE-ARGUMENT-2 2 signal-bad-range-argument)
  591. (define-arg-error 'BAD-RANGE-ARGUMENT-3 3 signal-bad-range-argument)
  592. (define-arg-error 'BAD-RANGE-ARGUMENT-4 4 signal-bad-range-argument)
  593. (define-arg-error 'BAD-RANGE-ARGUMENT-5 5 signal-bad-range-argument)
  594. (define-arg-error 'BAD-RANGE-ARGUMENT-6 6 signal-bad-range-argument)
  595. (define-arg-error 'BAD-RANGE-ARGUMENT-7 7 signal-bad-range-argument)
  596. (define-arg-error 'BAD-RANGE-ARGUMENT-8 8 signal-bad-range-argument)
  597. (define-arg-error 'BAD-RANGE-ARGUMENT-9 9 signal-bad-range-argument)
  598.  
  599. (define-arg-error 'WRONG-TYPE-ARGUMENT-0 0 signal-wrong-type-argument)
  600. (define-arg-error 'WRONG-TYPE-ARGUMENT-1 1 signal-wrong-type-argument)
  601. (define-arg-error 'WRONG-TYPE-ARGUMENT-2 2 signal-wrong-type-argument)
  602. (define-arg-error 'WRONG-TYPE-ARGUMENT-3 3 signal-wrong-type-argument)
  603. (define-arg-error 'WRONG-TYPE-ARGUMENT-4 4 signal-wrong-type-argument)
  604. (define-arg-error 'WRONG-TYPE-ARGUMENT-5 5 signal-wrong-type-argument)
  605. (define-arg-error 'WRONG-TYPE-ARGUMENT-6 6 signal-wrong-type-argument)
  606. (define-arg-error 'WRONG-TYPE-ARGUMENT-7 7 signal-wrong-type-argument)
  607. (define-arg-error 'WRONG-TYPE-ARGUMENT-8 8 signal-wrong-type-argument)
  608. (define-arg-error 'WRONG-TYPE-ARGUMENT-9 9 signal-wrong-type-argument)
  609.  
  610. ;;;; Primitive Errors
  611.  
  612. (define (define-primitive-error error-name type)
  613.   (define-error-handler error-name
  614.     (let ((signal (condition-signaller type '(OPERATOR OPERANDS))))
  615.       (lambda (continuation)
  616.     (let ((frame (continuation/first-subproblem continuation)))
  617.       (if (apply-frame? frame)
  618.           (let ((operator (apply-frame/operator frame)))
  619.         (if (primitive-procedure? operator)
  620.             (signal continuation
  621.                 operator
  622.                 (apply-frame/operands frame))))))))))
  623.  
  624. (set! condition-type:primitive-procedure-error
  625.   (make-condition-type 'PRIMITIVE-PROCEDURE-ERROR condition-type:error
  626.       '(OPERATOR OPERANDS)
  627.     (lambda (condition port)
  628.       (write-string "The primitive " port)
  629.       (write-operator (access-condition condition 'OPERATOR) port)
  630.       (write-string " signalled an anonymous error." port))))
  631.  
  632. (define-primitive-error 'EXTERNAL-RETURN
  633.   condition-type:primitive-procedure-error)
  634.  
  635. (set! condition-type:unimplemented-primitive
  636.   (make-condition-type 'UNIMPLEMENTED-PRIMITIVE
  637.       condition-type:primitive-procedure-error
  638.       '()
  639.     (lambda (condition port)
  640.       (write-string "The primitive " port)
  641.       (write-operator (access-condition condition 'OPERATOR) port)
  642.       (write-string " is not implemented in this version of Scheme." port))))
  643.  
  644. (define-primitive-error 'UNIMPLEMENTED-PRIMITIVE
  645.   condition-type:unimplemented-primitive)
  646.  
  647. (set! condition-type:unimplemented-primitive-for-os
  648.   (make-condition-type 'UNIMPLEMENTED-PRIMITIVE-FOR-OS
  649.       condition-type:unimplemented-primitive
  650.       '()
  651.     (lambda (condition port)
  652.       (write-string "The primitive " port)
  653.       (write-operator (access-condition condition 'OPERATOR) port)
  654.       (write-string " is not implemented for this operating system." port))))
  655.  
  656. (define-primitive-error 'UNDEFINED-PRIMITIVE-OPERATION
  657.   condition-type:unimplemented-primitive-for-os)
  658.  
  659. (set! condition-type:compiled-code-error
  660.   (make-condition-type 'COMPILED-CODE-ERROR
  661.       condition-type:primitive-procedure-error
  662.       '()
  663.     (lambda (condition port)
  664.       (write-string "The open-coded primitive " port)
  665.       (write-operator (access-condition condition 'OPERATOR) port)
  666.       (write-string " was called with an inappropriate argument." port))))
  667.  
  668. (define-error-handler 'COMPILED-CODE-ERROR
  669.   (let ((signal
  670.      (condition-signaller condition-type:compiled-code-error
  671.                   '(OPERATOR OPERANDS))))
  672.     (lambda (continuation)
  673.       (let ((frame (continuation/first-subproblem continuation)))
  674.     (if (compiled-code-error-frame? frame)
  675.         (let ((irritant (compiled-code-error-frame/irritant frame)))
  676.           (if (primitive-procedure? irritant)
  677.           (signal continuation irritant 'UNKNOWN))))))))
  678.  
  679. (set! condition-type:primitive-io-error
  680.   ;; Primitives that signal this error should be changed to signal a
  681.   ;; system-call error instead, since that is more descriptive.
  682.   (make-condition-type 'PRIMITIVE-IO-ERROR
  683.       condition-type:primitive-procedure-error
  684.       '()
  685.     (lambda (condition port)
  686.       (write-string "The primitive " port)
  687.       (write-operator (access-condition condition 'OPERATOR) port)
  688.       (write-string " signalled an anonymous I/O error." port))))
  689.  
  690. (define-error-handler 'IO-ERROR
  691.   (let ((signal
  692.      (condition-signaller condition-type:primitive-io-error
  693.                   '(OPERATOR OPERANDS))))
  694.     (lambda (continuation)
  695.       (let ((frame (continuation/first-subproblem continuation)))
  696.     (if (apply-frame? frame)
  697.         (signal continuation
  698.             (apply-frame/operator frame)
  699.             (apply-frame/operands frame)))))))
  700.  
  701. (set! condition-type:out-of-file-handles
  702.   (make-condition-type 'OUT-OF-FILE-HANDLES
  703.       condition-type:primitive-procedure-error
  704.       '()
  705.     (lambda (condition port)
  706.       (write-string "The primitive " port)
  707.       (write-operator (access-condition condition 'OPERATOR) port)
  708.       (write-string " could not allocate a channel or subprocess." port))))
  709.  
  710. (define-error-handler 'OUT-OF-FILE-HANDLES
  711.   (let ((signal
  712.      (condition-signaller condition-type:out-of-file-handles
  713.                   '(OPERATOR OPERANDS)))
  714.     (signal-file-operation (file-operation-signaller)))
  715.     (lambda (continuation)
  716.       (let ((frame (continuation/first-subproblem continuation)))
  717.     (if (apply-frame? frame)
  718.         (let ((operator (apply-frame/operator frame))
  719.           (operands (apply-frame/operands frame)))
  720.           (if (or (eq? (ucode-primitive file-open-input-channel) operator)
  721.               (eq? (ucode-primitive file-open-output-channel) operator)
  722.               (eq? (ucode-primitive file-open-io-channel) operator)
  723.               (eq? (ucode-primitive file-open-append-channel) operator)
  724.               (eq? (ucode-primitive new-file-open-input-channel)
  725.                operator)
  726.               (eq? (ucode-primitive new-file-open-output-channel)
  727.                operator)
  728.               (eq? (ucode-primitive new-file-open-io-channel)
  729.                operator)
  730.               (eq? (ucode-primitive new-file-open-append-channel)
  731.                operator))
  732.           (signal-file-operation continuation operator operands 0
  733.                      "open" "file" "channel table full")
  734.           (signal continuation operator operands))))))))
  735.  
  736. (set! condition-type:system-call-error
  737.   (make-condition-type 'SYSTEM-CALL-ERROR
  738.       condition-type:primitive-procedure-error
  739.       '(SYSTEM-CALL ERROR-TYPE)
  740.     (lambda (condition port)
  741.       (write-string "The primitive " port)
  742.       (write-operator (access-condition condition 'OPERATOR) port)
  743.       (write-string ", while executing " port)
  744.       (let ((system-call (access-condition condition 'SYSTEM-CALL)))
  745.     (if (symbol? system-call)
  746.         (begin
  747.           (write-string "the " port)
  748.           (write system-call port)
  749.           (write-string " system call" port))
  750.         (begin
  751.           (write-string "system call " port)
  752.           (write system-call port))))
  753.       (write-string ", received " port)
  754.       (let ((error-type (access-condition condition 'ERROR-TYPE)))
  755.     (if (or (symbol? error-type) (string? error-type))
  756.         (write-string "the error: " port))
  757.     (write-string (error-type->string error-type) port))
  758.       (write-string "." port))))
  759.  
  760. (define system-call-error-handler
  761.   (let ((make-condition
  762.      (condition-constructor condition-type:system-call-error
  763.                 '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE)))
  764.     (signal-file-operation (file-operation-signaller)))
  765.     (lambda (continuation error-code)
  766.       (let ((frame (continuation/first-subproblem continuation)))
  767.     (if (and (apply-frame? frame)
  768.          (vector? error-code)
  769.          (= 3 (vector-length error-code)))
  770.         (let ((operator (apply-frame/operator frame))
  771.           (operands (apply-frame/operands frame))
  772.           (system-call
  773.            (if (string? (vector-ref error-code 1))
  774.                (string->symbol (vector-ref error-code 1))
  775.                (let ((system-call (vector-ref error-code 2)))
  776.              (or (microcode-system-call/code->name system-call)
  777.                  system-call))))
  778.           (error-type
  779.            (let ((error-type
  780.               (if (string? (vector-ref error-code 1))
  781.                   (vector-ref error-code 2)
  782.                   (vector-ref error-code 1))))
  783.              (if (string? error-type)
  784.              error-type
  785.              (or (microcode-system-call-error/code->name
  786.                   error-type)
  787.                  error-type)))))
  788.           (let ((make-condition
  789.              (lambda ()
  790.                (make-condition continuation 'BOUND-RESTARTS
  791.                        operator operands
  792.                        system-call error-type))))
  793.         (cond ((port-error-test operator operands)
  794.                => (lambda (port)
  795.                 (error:derived-port port (make-condition))))
  796.               ((and (primitive-procedure? operator)
  797.                 (not (null? operands))
  798.                 (string? (car operands)))
  799.                (with-values
  800.                (lambda ()
  801.                  (file-primitive-description operator))
  802.              (lambda (verb noun)
  803.                (if verb
  804.                    (signal-file-operation
  805.                 continuation operator operands 0 verb noun
  806.                 (error-type->string error-type))
  807.                    (error (make-condition))))))
  808.               (else
  809.                (error (make-condition)))))))))))
  810.  
  811. (define-low-level-handler 'SYSTEM-CALL system-call-error-handler)
  812.  
  813. ;;;; FASLOAD Errors
  814.  
  815. (define (define-fasload-error error-code type)
  816.   (define-error-handler error-code
  817.     (let ((signal (condition-signaller type '(FILENAME OPERATOR OPERANDS))))
  818.       (lambda (continuation)
  819.     (let ((frame (continuation/first-subproblem continuation)))
  820.       (if (apply-frame? frame)
  821.           (let ((operator (apply-frame/operator frame)))
  822.         (if (or (eq? (ucode-primitive load-band) operator)
  823.             (eq? (ucode-primitive binary-fasload) operator))
  824.             (signal continuation
  825.                 (apply-frame/operand frame 0)
  826.                 operator
  827.                 (apply-frame/operands frame))))))))))
  828.  
  829. (set! condition-type:fasload-error
  830.   (make-condition-type 'FASLOAD-ERROR condition-type:file-error
  831.       '(OPERATOR OPERANDS)
  832.     false))
  833.  
  834. (set! condition-type:fasl-file-bad-data
  835.   (make-condition-type 'FASL-FILE-BAD-DATA condition-type:fasload-error '()
  836.     (lambda (condition port)
  837.       (write-string "Attempt to read binary file " port)
  838.       (write (access-condition condition 'FILENAME) port)
  839.       (write-string " failed: either it's not binary or the wrong version."
  840.             port))))
  841.  
  842. (define-fasload-error 'FASL-FILE-BAD-DATA
  843.   condition-type:fasl-file-bad-data)
  844.  
  845. (set! condition-type:fasl-file-compiled-mismatch
  846.   (make-condition-type 'FASL-FILE-COMPILED-MISMATCH
  847.       condition-type:fasl-file-bad-data
  848.       '()
  849.     false))
  850.  
  851. (define-fasload-error 'FASLOAD-COMPILED-MISMATCH
  852.   condition-type:fasl-file-compiled-mismatch)
  853.  
  854. (set! condition-type:fasl-file-too-big
  855.   (make-condition-type 'FASL-FILE-TOO-BIG condition-type:fasload-error '()
  856.     (lambda (condition port)
  857.       (write-string "Attempt to read binary file " port)
  858.       (write (access-condition condition 'FILENAME) port)
  859.       (write-string " failed: it's too large to fit in the heap." port))))
  860.  
  861. (define-fasload-error 'FASL-FILE-TOO-BIG
  862.   condition-type:fasl-file-too-big)
  863.  
  864. (set! condition-type:wrong-arity-primitives
  865.   (make-condition-type 'WRONG-ARITY-PRIMITIVES condition-type:fasload-error '()
  866.     (lambda (condition port)
  867.       (write-string "Attempt to read binary file " port)
  868.       (write (access-condition condition 'FILENAME) port)
  869.       (write-string " failed: it contains primitives with incorrect arity."
  870.             port))))
  871.  
  872. (define-fasload-error 'WRONG-ARITY-PRIMITIVES
  873.   condition-type:wrong-arity-primitives)
  874.  
  875. (set! condition-type:fasload-band
  876.   (make-condition-type 'FASLOAD-BAND condition-type:fasl-file-bad-data '()
  877.     false))
  878.  
  879. (define-error-handler 'FASLOAD-BAND
  880.   (let ((signal
  881.      (condition-signaller condition-type:fasload-band
  882.                   '(FILENAME OPERATOR OPERANDS))))
  883.     (lambda (continuation)
  884.       (let ((frame (continuation/first-subproblem continuation)))
  885.     (if (apply-frame? frame)
  886.         (let ((operator (apply-frame/operator frame)))
  887.           (if (eq? (ucode-primitive binary-fasload) operator)
  888.           (signal continuation
  889.               (apply-frame/operand frame 0)
  890.               operator
  891.               (apply-frame/operands frame)))))))))
  892.  
  893. ;;;; Miscellaneous Errors
  894.  
  895. (set! condition-type:inapplicable-object
  896.   (make-condition-type 'INAPPLICABLE-OBJECT condition-type:illegal-datum
  897.       '(OPERANDS)
  898.     (lambda (condition port)
  899.       (write-string "The object " port)
  900.       (write (access-condition condition 'DATUM) port)
  901.       (write-string " is not applicable." port))))
  902.  
  903. (define-error-handler 'UNDEFINED-PROCEDURE
  904.   (let ((signal
  905.      (condition-signaller condition-type:inapplicable-object
  906.                   '(DATUM OPERANDS))))
  907.     (lambda (continuation)
  908.       (let ((frame (continuation/first-subproblem continuation)))
  909.     (if (apply-frame? frame)
  910.         (let ((operator (apply-frame/operator frame))
  911.           (operands (apply-frame/operands frame)))
  912.           (inapplicable-object/use-value continuation operands
  913.         (lambda ()
  914.           (signal continuation operator operands)))))))))
  915.  
  916. (define-error-handler 'WRONG-NUMBER-OF-ARGUMENTS
  917.   (let ((signal
  918.      (condition-signaller condition-type:wrong-number-of-arguments
  919.                   '(DATUM TYPE OPERANDS))))
  920.     (lambda (continuation)
  921.       (let ((frame (continuation/first-subproblem continuation)))
  922.     (if (apply-frame? frame)
  923.         (let ((operator (apply-frame/operator frame)))
  924.           (signal continuation
  925.               operator
  926.               (procedure-arity operator)
  927.               (apply-frame/operands frame))))))))
  928.  
  929. (define-error-handler 'FLOATING-OVERFLOW
  930.   (let ((signal
  931.      (condition-signaller condition-type:floating-point-overflow
  932.                   '(OPERATOR OPERANDS))))
  933.     (lambda (continuation)
  934.       (let ((frame (continuation/first-subproblem continuation)))
  935.     (if (apply-frame? frame)
  936.         (signal continuation
  937.             (apply-frame/operator frame)
  938.             (apply-frame/operands frame)))))))
  939.  
  940. (define-error-handler 'WRITE-INTO-PURE-SPACE
  941.   (lambda (continuation)
  942.     (let ((frame (continuation/first-subproblem continuation)))
  943.       (if (apply-frame? frame)
  944.       (let ((object (apply-frame/operand frame 0)))
  945.         (let ((port (notification-output-port)))
  946.           (fresh-line port)
  947.           (write-string ";Automagically impurifying an object..." port))
  948.         (impurify object)
  949.         (continuation object))))))
  950.  
  951. (set! condition-type:impurify-object-too-large
  952.   (make-condition-type 'IMPURIFY-OBJECT-TOO-LARGE
  953.       condition-type:bad-range-argument
  954.       '()
  955.     (lambda (condition port)
  956.       (write-string "Object is too large to be impurified: " port)
  957.       (write (access-condition condition 'DATUM) port))))
  958.  
  959. (define-error-handler 'IMPURIFY-OBJECT-TOO-LARGE
  960.   (let ((signal
  961.      (condition-signaller condition-type:impurify-object-too-large
  962.                   '(DATUM OPERATOR OPERAND))))
  963.     (lambda (continuation)
  964.       (let ((frame (continuation/first-subproblem continuation)))
  965.     (if (apply-frame? frame)
  966.         (let ((operator (apply-frame/operator frame)))
  967.           (if (eq? (ucode-primitive primitive-impurify) operator)
  968.           (signal continuation
  969.               (apply-frame/operand frame 0)
  970.               operator
  971.               0))))))))
  972.  
  973. (set! condition-type:fasdump-environment
  974.   (make-condition-type 'FASDUMP-ENVIRONMENT condition-type:bad-range-argument
  975.       '()
  976.     (lambda (condition port)
  977.       (write-string
  978.        "Object cannot be dumped because it contains an environment: "
  979.        port)
  980.       (write (access-condition condition 'DATUM) port))))
  981.  
  982. (define-error-handler 'FASDUMP-ENVIRONMENT
  983.   (let ((signal
  984.      (condition-signaller condition-type:fasdump-environment
  985.                   '(DATUM OPERATOR OPERAND))))
  986.     (lambda (continuation)
  987.       (let ((frame (continuation/first-subproblem continuation)))
  988.     (if (apply-frame? frame)
  989.         (let ((operator (apply-frame/operator frame)))
  990.           (if (eq? (ucode-primitive primitive-fasdump) operator)
  991.           (signal continuation
  992.               (apply-frame/operand frame 0)
  993.               operator
  994.               0))))))))
  995.  
  996. ;;;; Asynchronous Microcode Errors
  997.  
  998. (set! condition-type:hardware-trap
  999.   (make-condition-type 'HARDWARE-TRAP condition-type:error '(NAME CODE)
  1000.     (lambda (condition port)
  1001.       (write-string "Hardware trap " port)
  1002.       (display (access-condition condition 'NAME) port)
  1003.       (let ((code (access-condition condition 'CODE)))
  1004.     (if code
  1005.         (begin
  1006.           (write-string ": " port)
  1007.           (write code port)))))))
  1008.  
  1009. (set! condition-type:user-microcode-reset
  1010.   (make-condition-type 'USER-MICROCODE-RESET condition-type:serious-condition
  1011.       '()
  1012.     "User microcode reset"))
  1013.  
  1014. (set! hook/hardware-trap
  1015.       (let ((signal-user-microcode-reset
  1016.          (condition-signaller condition-type:user-microcode-reset '()))
  1017.         (signal-divide-by-zero
  1018.          (condition-signaller condition-type:divide-by-zero
  1019.                   '(OPERATOR OPERANDS)))
  1020.         (signal-floating-point-overflow
  1021.          (condition-signaller condition-type:floating-point-overflow
  1022.                   '(OPERATOR OPERANDS)))
  1023.         (signal-floating-point-underflow
  1024.          (condition-signaller condition-type:floating-point-underflow
  1025.                   '(OPERATOR OPERANDS)))
  1026.         (signal-arithmetic-error
  1027.          (condition-signaller condition-type:arithmetic-error
  1028.                   '(OPERATOR OPERANDS)))
  1029.         (signal-hardware-trap
  1030.          (condition-signaller condition-type:hardware-trap '(NAME CODE))))
  1031.     (lambda (name)
  1032.       (call-with-current-continuation
  1033.        (lambda (k)
  1034.          (if (not name)
  1035.          (signal-user-microcode-reset k)
  1036.          (case microcode-id/operating-system
  1037.            ((OS/2)
  1038.             (cond ((string=? "XCPT_FLOAT_UNDERFLOW" name)
  1039.                (signal-floating-point-underflow k #f '()))
  1040.               ((or (string=? "XCPT_FLOAT_OVERFLOW" name)
  1041.                    (string=? "XCPT_INTEGER_OVERFLOW" name))
  1042.                (signal-floating-point-overflow k #f '()))
  1043.               ((or (string=? "XCPT_FLOAT_DIVIDE_BY_ZERO" name)
  1044.                    (string=? "XCPT_INTEGER_DIVIDE_BY_ZERO" name))
  1045.                (signal-divide-by-zero k #f '()))
  1046.               ((or (string=? "XCPT_FLOAT_DENORMAL_OPERAND" name)
  1047.                    (string=? "XCPT_FLOAT_INEXACT_RESULT" name)
  1048.                    (string=? "XCPT_FLOAT_INVALID_OPERATION" name)
  1049.                    (string=? "XCPT_FLOAT_STACK_CHECK" name)
  1050.                    (string=? "XCPT_B1NPX_ERRATA_02" name))
  1051.                (signal-arithmetic-error k #f '()))
  1052.               (else
  1053.                (signal-hardware-trap k name #f))))
  1054.            (else
  1055.             (let ((code
  1056.                (let ((frame (continuation/first-subproblem k)))
  1057.                  (and (hardware-trap-frame? frame)
  1058.                   (hardware-trap-frame/code frame)))))
  1059.               (if (string=? "SIGFPE" name)
  1060.               ((case (and (string? code)
  1061.                       (normalize-trap-code-name code))
  1062.                  ((UNDERFLOW) signal-floating-point-underflow)
  1063.                  ((OVERFLOW) signal-floating-point-overflow)
  1064.                  ((DIVIDE-BY-ZERO) signal-divide-by-zero)
  1065.                  (else signal-arithmetic-error))
  1066.                k false '())
  1067.               (signal-hardware-trap k
  1068.                         name
  1069.                         code)))))))))))
  1070.  
  1071. ;;; end INITIALIZE-PACKAGE!.
  1072. )