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 / error.scm < prev    next >
Text File  |  2000-01-09  |  44KB  |  1,245 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: error.scm,v 14.51 2000/01/10 03:48:33 cph Exp $
  4.  
  5. Copyright (c) 1988-2000 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., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Error System
  23. ;;; package: (runtime error-handler)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. ;;;; Condition Types
  28.  
  29. (define-structure (condition-type
  30.            (conc-name %condition-type/)
  31.            (constructor %make-condition-type
  32.                 (name field-indexes number-of-fields reporter))
  33.            (print-procedure
  34.             (standard-unparser-method 'CONDITION-TYPE
  35.               (lambda (type port)
  36.             (write-char #\space port)
  37.             (write-string (%condition-type/name type) port)))))
  38.   (name false read-only true)
  39.   generalizations
  40.   (field-indexes false read-only true)
  41.   (number-of-fields false read-only true)
  42.   (reporter false read-only true)
  43.   (properties (make-1d-table) read-only true))
  44.  
  45. (define (make-condition-type name generalization field-names reporter)
  46.   (if generalization
  47.       (guarantee-condition-type generalization 'MAKE-CONDITION-TYPE))
  48.   (guarantee-list-of-symbols field-names 'MAKE-CONDITION-TYPE)
  49.   (let ((type
  50.      (call-with-values
  51.          (lambda ()
  52.            (compute-field-indexes generalization field-names))
  53.        (lambda (n-fields field-indexes)
  54.          (%make-condition-type
  55.           (cond ((string? name) (string-copy name))
  56.             ((symbol? name) (symbol->string name))
  57.             ((false? name) "(anonymous)")
  58.             (else
  59.              (error:wrong-type-argument name "condition-type name"
  60.                         'MAKE-CONDITION-TYPE)))
  61.           field-indexes
  62.           n-fields
  63.           (cond ((string? reporter)
  64.              (lambda (condition port)
  65.                condition
  66.                (write-string reporter port)))
  67.             ((procedure-of-arity? reporter 2)
  68.              reporter)
  69.             ((false? reporter)
  70.              (if generalization
  71.              (%condition-type/reporter generalization)
  72.              (lambda (condition port)
  73.                (write-string "undocumented condition of type "
  74.                      port)
  75.                (write (%condition/type condition) port))))
  76.             (else
  77.              (error:wrong-type-argument reporter
  78.                         "condition-type reporter"
  79.                         'MAKE-CONDITION-TYPE))))))))
  80.     (set-%condition-type/generalizations!
  81.      type
  82.      (cons type
  83.        (if generalization
  84.            (%condition-type/generalizations generalization)
  85.            '())))
  86.     type))
  87.  
  88. (define (compute-field-indexes generalization field-names)
  89.   (call-with-values
  90.       (lambda ()
  91.     (if generalization
  92.         (values (%condition-type/number-of-fields generalization)
  93.             (%condition-type/field-indexes generalization))
  94.         (values 0 '())))
  95.     (lambda (old-n-fields old-indexes)
  96.       (let loop
  97.       ((field-names field-names)
  98.        (index old-n-fields)
  99.        (indexes (let loop ((old-indexes old-indexes) (indexes '()))
  100.               (if (null? old-indexes)
  101.               indexes
  102.               (loop (cdr old-indexes)
  103.                 (let ((entry (car old-indexes)))
  104.                   (if (memq (car entry) field-names)
  105.                       indexes
  106.                       (cons entry indexes))))))))
  107.     (if (null? field-names)
  108.         (values index (reverse! indexes))
  109.         (loop (cdr field-names)
  110.           (+ index 1)
  111.           (cons (cons (car field-names) index) indexes)))))))
  112.  
  113. (define (%condition-type/field-index type field-name operator)
  114.   (let ((association (assq field-name (%condition-type/field-indexes type))))
  115.     (if (not association)
  116.     (error:bad-range-argument field-name operator))
  117.     (cdr association)))
  118.  
  119. (define (condition-type/field-names type)
  120.   (guarantee-condition-type type 'CONDITION-TYPE/FIELD-NAMES)
  121.   (map car (%condition-type/field-indexes type)))
  122.  
  123. (define (condition-type/generalizations type)
  124.   (guarantee-condition-type type 'CONDITION-TYPE/GENERALIZATIONS)
  125.   (list-copy (cdr (%condition-type/generalizations type))))
  126.  
  127. (define (condition-type/properties type)
  128.   (guarantee-condition-type type 'CONDITION-TYPE/PROPERTIES)
  129.   (%condition-type/properties type))
  130.  
  131. (define (condition-type/put! type key datum)
  132.   (1d-table/put! (condition-type/properties type) key datum))
  133.  
  134. (define (condition-type/get type key)
  135.   (1d-table/get (condition-type/properties type) key false))
  136.  
  137. ;;;; Condition Instances
  138.  
  139. (define-structure (condition
  140.            (conc-name %condition/)
  141.            (constructor %make-condition (type continuation restarts))
  142.            (print-procedure
  143.             (standard-unparser-method 'CONDITION
  144.               (lambda (condition port)
  145.             (write-char #\space port)
  146.             (write-string
  147.              (%condition-type/name (%condition/type condition))
  148.              port)))))
  149.   (type false read-only true)
  150.   (continuation false read-only true)
  151.   (restarts false read-only true)
  152.   (field-values (make-vector (%condition-type/number-of-fields type) false)
  153.         read-only true)
  154.   (properties (make-1d-table) read-only true))
  155.  
  156. (define (make-condition type continuation restarts field-alist)
  157.   (guarantee-condition-type type 'MAKE-CONDITION)
  158.   (guarantee-continuation continuation 'MAKE-CONDITION)
  159.   (guarantee-keyword-association-list field-alist 'MAKE-CONDITION)
  160.   (let ((condition
  161.      (%make-condition type
  162.               continuation
  163.               (%restarts-argument restarts 'MAKE-CONDITION))))
  164.     (let ((field-values (%condition/field-values condition)))
  165.       (do ((alist field-alist (cddr alist)))
  166.       ((null? alist))
  167.     (vector-set! field-values
  168.              (%condition-type/field-index type (car alist)
  169.                           'MAKE-CONDITION)
  170.              (cadr alist))))
  171.     condition))
  172.  
  173. (define (condition-constructor type field-names)
  174.   (guarantee-condition-type type 'CONDITION-CONSTRUCTOR)
  175.   (guarantee-list-of-symbols field-names 'CONDITION-CONSTRUCTOR)
  176.   (let ((indexes
  177.      (map (lambda (field-name)
  178.         (%condition-type/field-index type field-name
  179.                          'CONDITION-CONSTRUCTOR))
  180.           field-names)))
  181.     (letrec
  182.     ((constructor
  183.       (lambda (continuation restarts . field-values)
  184.         (guarantee-continuation continuation constructor)
  185.         (let ((condition
  186.            (%make-condition type
  187.                     continuation
  188.                     (%restarts-argument restarts
  189.                             constructor))))
  190.           (let ((values (%condition/field-values condition)))
  191.         (do ((i indexes (cdr i))
  192.              (v field-values (cdr v)))
  193.             ((or (null? i) (null? v))
  194.              (if (not (and (null? i) (null? v)))
  195.              (error:wrong-number-of-arguments
  196.               constructor
  197.               (+ (length indexes) 1)
  198.               (cons continuation field-values))))
  199.           (vector-set! values (car i) (car v))))
  200.           condition))))
  201.       constructor)))
  202.  
  203. (define-integrable (%restarts-argument restarts operator)
  204.   (cond ((eq? 'BOUND-RESTARTS restarts)
  205.      *bound-restarts*)
  206.     ((condition? restarts)
  207.      (%condition/restarts restarts))
  208.     (else
  209.      (guarantee-restarts restarts operator)
  210.      (list-copy restarts))))
  211.  
  212. (define (condition-predicate type)
  213.   (guarantee-condition-type type 'CONDITION-PREDICATE)
  214.   (lambda (object)
  215.     (and (condition? object)
  216.      (memq type
  217.            (%condition-type/generalizations (%condition/type object))))))
  218.  
  219. (define (condition-accessor type field-name)
  220.   (guarantee-condition-type type 'CONDITION-ACCESSOR)
  221.   (guarantee-symbol field-name 'CONDITION-ACCESSOR)
  222.   (let ((predicate (condition-predicate type))
  223.     (index
  224.      (%condition-type/field-index type
  225.                       field-name
  226.                       'CONDITION-ACCESSOR)))
  227.     (lambda (condition)
  228.       (if (not (predicate condition))
  229.       (error:wrong-type-argument condition
  230.                      (string-append "condition of type "
  231.                             (write-to-string type))
  232.                      'CONDITION-ACCESSOR))
  233.       (vector-ref (%condition/field-values condition) index))))
  234.  
  235. (define (access-condition condition field-name)
  236.   (guarantee-condition condition 'ACCESS-CONDITION)
  237.   ((condition-accessor (%condition/type condition) field-name) condition))
  238.  
  239. (define (condition/type condition)
  240.   (guarantee-condition condition 'CONDITION/TYPE)
  241.   (%condition/type condition))
  242.  
  243. (define (condition/continuation condition)
  244.   (guarantee-condition condition 'CONDITION/CONTINUATION)
  245.   (%condition/continuation condition))
  246.  
  247. (define (condition/restarts condition)
  248.   (guarantee-condition condition 'CONDITION/RESTARTS)
  249.   (list-copy (%condition/restarts condition)))
  250.  
  251. (define (condition/properties condition)
  252.   (guarantee-condition condition 'CONDITION/PROPERTIES)
  253.   (%condition/properties condition))
  254.  
  255. (define (condition/put! condition key datum)
  256.   (1d-table/put! (condition/properties condition) key datum))
  257.  
  258. (define (condition/get condition key)
  259.   (1d-table/get (condition/properties condition) key false))
  260.  
  261. (define (write-condition-report condition port)
  262.   (guarantee-condition condition 'WRITE-CONDITION-REPORT)
  263.   (guarantee-output-port port 'WRITE-CONDITION-REPORT)
  264.   (let ((reporter (%condition-type/reporter (%condition/type condition))))
  265.     (if (%condition/error? condition)
  266.     (ignore-errors (lambda () (reporter condition port)))
  267.     (reporter condition port))))
  268.  
  269. (define (condition/report-string condition)
  270.   (with-string-output-port
  271.     (lambda (port)
  272.       (write-condition-report condition port))))
  273.  
  274. ;;;; Restarts
  275.  
  276. (define *bound-restarts* '())
  277.  
  278. (define-structure (restart
  279.            (conc-name %restart/)
  280.            (constructor %make-restart
  281.                 (name reporter effector interactor))
  282.            (print-procedure
  283.             (standard-unparser-method 'RESTART
  284.               (lambda (restart port)
  285.             (write-char #\space port)
  286.             (let ((name (%restart/name restart)))
  287.               (if name
  288.                   (write name port)
  289.                   (write-string "(anonymous)" port)))))))
  290.   (name false read-only true)
  291.   (reporter false read-only true)
  292.   (effector false read-only true)
  293.   (interactor false)
  294.   (properties (make-1d-table) read-only true))
  295.  
  296. (define (with-restart name reporter effector interactor thunk)
  297.   (if name (guarantee-symbol name 'WITH-RESTART))
  298.   (if (not (or (string? reporter) (procedure-of-arity? reporter 1)))
  299.       (error:wrong-type-argument reporter "reporter" 'WITH-RESTART))
  300.   (if (not (procedure? effector))
  301.       (error:wrong-type-argument effector "effector" 'WITH-RESTART))
  302.   (if (not (or (not interactor) (procedure? interactor)))
  303.       (error:wrong-type-argument interactor "interactor" 'WITH-RESTART))
  304.   (fluid-let ((*bound-restarts*
  305.            (cons (%make-restart name reporter effector interactor)
  306.              *bound-restarts*)))
  307.     (thunk)))
  308.  
  309. (define (with-simple-restart name reporter thunk)
  310.   (call-with-current-continuation
  311.    (lambda (continuation)
  312.      (with-restart name reporter (lambda () (continuation unspecific)) values
  313.        thunk))))
  314.  
  315. (define (restart/name restart)
  316.   (guarantee-restart restart 'RESTART/NAME)
  317.   (%restart/name restart))
  318.  
  319. (define (write-restart-report restart port)
  320.   (guarantee-restart restart 'WRITE-RESTART-REPORT)
  321.   (guarantee-output-port port 'WRITE-RESTART-REPORT)
  322.   (let ((reporter (%restart/reporter restart)))
  323.     (if (string? reporter)
  324.     (write-string reporter port)
  325.     (reporter port))))
  326.  
  327. (define (restart/effector restart)
  328.   (guarantee-restart restart 'RESTART/EFFECTOR)
  329.   (%restart/effector restart))
  330.  
  331. (define (restart/interactor restart)
  332.   (guarantee-restart restart 'RESTART/INTERACTOR)
  333.   (%restart/interactor restart))
  334.  
  335. (define (restart/properties restart)
  336.   (guarantee-restart restart 'RESTART/PROPERTIES)
  337.   (%restart/properties restart))
  338.  
  339. (define (restart/get restart key)
  340.   (if (eq? key 'INTERACTIVE)
  341.       (restart/interactor restart)
  342.       (1d-table/get (restart/properties restart) key false)))
  343.  
  344. (define (restart/put! restart key datum)
  345.   (if (eq? key 'INTERACTIVE)
  346.       (set-%restart/interactor! restart datum)
  347.       (1d-table/put! (restart/properties restart) key datum)))
  348.  
  349. (define (bind-restart name reporter effector receiver)
  350.   (with-restart name reporter effector #f
  351.     (lambda ()
  352.       (receiver (car *bound-restarts*)))))
  353.  
  354. (define (invoke-restart restart . arguments)
  355.   (guarantee-restart restart 'INVOKE-RESTART)
  356.   (hook/invoke-restart (%restart/effector restart) arguments))
  357.  
  358. (define (invoke-restart-interactively restart #!optional condition)
  359.   (guarantee-restart restart 'INVOKE-RESTART-INTERACTIVELY)
  360.   (let ((effector (%restart/effector restart))
  361.     (arguments
  362.      (let ((interactor (%restart/interactor restart)))
  363.        (if interactor
  364.            (call-with-values interactor list)
  365.            '())))
  366.     (condition (if (default-object? condition) #f condition)))
  367.     (let ((thread (and condition (condition/other-thread condition))))
  368.       (if thread
  369.       (begin
  370.         (restart-thread thread 'ASK
  371.           (lambda ()
  372.         (hook/invoke-restart effector arguments)))
  373.         (continue-from-derived-thread-error condition))
  374.       (hook/invoke-restart effector arguments)))))
  375.  
  376. (define (condition/other-thread condition)
  377.   (and (condition/derived-thread? condition)
  378.        (let ((thread (access-condition condition 'THREAD)))
  379.      (and (not (eq? thread (current-thread)))
  380.           thread))))
  381.  
  382. (define (continue-from-derived-thread-error condition)
  383.   (let loop ((restarts (bound-restarts)))
  384.     (if (not (null? restarts))
  385.     (if (and (eq? 'CONTINUE (restart/name (car restarts)))
  386.          (eq? condition
  387.               (restart/get (car restarts) 'ASSOCIATED-CONDITION)))
  388.         (invoke-restart (car restarts))
  389.         (loop (cdr restarts))))))
  390.  
  391. (define hook/invoke-restart)
  392.  
  393. (define (bound-restarts)
  394.   (let loop ((restarts *bound-restarts*))
  395.     (if (null? restarts)
  396.     '()
  397.     (cons (car restarts) (loop (cdr restarts))))))
  398.  
  399. (define (first-bound-restart)
  400.   (let ((restarts *bound-restarts*))
  401.     (if (null? restarts)
  402.     (error:no-such-restart #f))
  403.     (car restarts)))
  404.  
  405. (define (%find-restart name restarts)
  406.   (let loop ((restarts restarts))
  407.     (and (not (null? restarts))
  408.      (if (eq? name (%restart/name (car restarts)))
  409.          (car restarts)
  410.          (loop (cdr restarts))))))
  411.  
  412. (define-macro (restarts-default restarts name)
  413.   ;; This is a macro because DEFAULT-OBJECT? is.
  414.   `(COND ((OR (DEFAULT-OBJECT? ,restarts)
  415.           (EQ? 'BOUND-RESTARTS ,restarts))
  416.       *BOUND-RESTARTS*)
  417.      ((CONDITION? ,restarts)
  418.       (%CONDITION/RESTARTS ,restarts))
  419.      (ELSE
  420.       (GUARANTEE-RESTARTS ,restarts ',name)
  421.       ,restarts)))
  422.  
  423. (define (find-restart name #!optional restarts)
  424.   (guarantee-symbol name 'FIND-RESTART)
  425.   (%find-restart name (restarts-default restarts 'FIND-RESTART)))
  426.  
  427. (define (abort #!optional restarts)
  428.   (let ((restart (%find-restart 'ABORT (restarts-default restarts 'ABORT))))
  429.     (if (not restart)
  430.     (error:no-such-restart 'ABORT))
  431.     ((%restart/effector restart))))
  432.  
  433. (define (continue #!optional restarts)
  434.   (let ((restart
  435.      (%find-restart 'CONTINUE (restarts-default restarts 'CONTINUE))))
  436.     (if restart
  437.     ((%restart/effector restart)))))
  438.  
  439. (define (muffle-warning #!optional restarts)
  440.   (let ((restart
  441.      (%find-restart 'MUFFLE-WARNING
  442.             (restarts-default restarts 'MUFFLE-WARNING))))
  443.     (if (not restart)
  444.     (error:no-such-restart 'MUFFLE-WARNING))
  445.     ((%restart/effector restart))))
  446.  
  447. (define (retry #!optional restarts)
  448.   (let ((restart
  449.      (%find-restart 'RETRY (restarts-default restarts 'RETRY))))
  450.     (if restart
  451.     ((%restart/effector restart)))))
  452.  
  453. (define (store-value datum #!optional restarts)
  454.   (let ((restart
  455.      (%find-restart 'STORE-VALUE
  456.             (restarts-default restarts 'STORE-VALUE))))
  457.     (if restart
  458.     ((%restart/effector restart) datum))))
  459.  
  460. (define (use-value datum #!optional restarts)
  461.   (let ((restart
  462.      (%find-restart 'USE-VALUE
  463.             (restarts-default restarts 'USE-VALUE))))
  464.     (if restart
  465.     ((%restart/effector restart) datum))))
  466.  
  467. ;;;; Condition Signalling and Handling
  468.  
  469. (define static-handler-frames '())
  470. (define dynamic-handler-frames '())
  471. (define break-on-signals-types '())
  472.  
  473. (define (bind-default-condition-handler types handler)
  474.   (guarantee-condition-types types 'BIND-DEFAULT-CONDITION-HANDLER)
  475.   (guarantee-condition-handler handler 'BIND-DEFAULT-CONDITION-HANDLER)
  476.   (set! static-handler-frames
  477.     (cons (cons types handler) static-handler-frames))
  478.   unspecific)
  479.  
  480. (define (bind-condition-handler types handler thunk)
  481.   (guarantee-condition-types types 'BIND-CONDITION-HANDLER)
  482.   (guarantee-condition-handler handler 'BIND-CONDITION-HANDLER)
  483.   (fluid-let ((dynamic-handler-frames
  484.            (cons (cons types handler) dynamic-handler-frames)))
  485.     (thunk)))
  486.  
  487. (define (ignore-errors thunk)
  488.   (call-with-current-continuation
  489.    (lambda (continuation)
  490.      (bind-condition-handler (list condition-type:error) continuation
  491.        thunk))))
  492.  
  493. (define (break-on-signals types)
  494.   (guarantee-condition-types types 'BREAK-ON-SIGNALS)
  495.   (set! break-on-signals-types types)
  496.   unspecific)
  497.  
  498. (define hook/invoke-condition-handler)
  499.  
  500. (define (default/invoke-condition-handler handler condition)
  501.   (handler condition))
  502.  
  503. (define (signal-condition condition)
  504.   (guarantee-condition condition 'SIGNAL-CONDITION)
  505.   (let ((generalizations
  506.      (%condition-type/generalizations (%condition/type condition))))
  507.     (let ((intersect-generalizations?
  508.        (lambda (types)
  509.          (let outer ((type (car types)) (types (cdr types)))
  510.            (let inner ((generalizations generalizations))
  511.          (if (null? generalizations)
  512.              (and (not (null? types))
  513.               (outer (car types) (cdr types)))
  514.              (or (eq? type (car generalizations))
  515.              (inner (cdr generalizations)))))))))
  516.       (if (let ((types break-on-signals-types))
  517.         (and (not (null? types))
  518.          (intersect-generalizations? types)))
  519.       (fluid-let ((break-on-signals-types '()))
  520.         (breakpoint-procedure 'INHERIT
  521.                   "BKPT entered because of BREAK-ON-SIGNALS:"
  522.                   condition)))
  523.       (do ((frames dynamic-handler-frames (cdr frames)))
  524.       ((null? frames))
  525.     (if (let ((types (caar frames)))
  526.           (or (null? types)
  527.           (intersect-generalizations? types)))
  528.         (fluid-let ((dynamic-handler-frames (cdr frames)))
  529.           (hook/invoke-condition-handler (cdar frames) condition))))
  530.       (do ((frames static-handler-frames (cdr frames)))
  531.       ((null? frames))
  532.     (if (let ((types (caar frames)))
  533.           (or (null? types)
  534.           (intersect-generalizations? types)))
  535.         (fluid-let ((static-handler-frames (cdr frames))
  536.             (dynamic-handler-frames '()))
  537.           (hook/invoke-condition-handler (cdar frames) condition))))
  538.       unspecific)))
  539.  
  540. ;;;; Standard Condition Signallers
  541.  
  542. (define (error datum . arguments)
  543.   (signal-simple datum arguments make-simple-error standard-error-handler))
  544.  
  545. (define (warn datum . arguments)
  546.   (with-simple-restart 'MUFFLE-WARNING "Ignore warning."
  547.     (lambda ()
  548.       (signal-simple datum arguments
  549.              make-simple-warning standard-warning-handler))))
  550.  
  551. (define (signal-simple datum arguments make-simple-condition default-handler)
  552.   (if (condition? datum)
  553.       (begin
  554.     (signal-condition datum)
  555.     (default-handler datum))
  556.       (call-with-current-continuation
  557.        (lambda (continuation)
  558.      (let ((condition
  559.         (if (condition-type? datum)
  560.             (make-condition datum
  561.                     continuation
  562.                     'BOUND-RESTARTS
  563.                     arguments)
  564.             (make-simple-condition continuation
  565.                        'BOUND-RESTARTS
  566.                        datum
  567.                        arguments))))
  568.        (begin
  569.          (signal-condition condition)
  570.          (default-handler condition)))))))
  571.  
  572. (define (standard-error-handler condition)
  573.   (let ((hook standard-error-hook))
  574.     (if hook
  575.     (fluid-let ((standard-error-hook false))
  576.       (hook condition))))
  577.   (repl/start (push-repl 'INHERIT 'INHERIT condition '() "error>")))
  578.  
  579. (define (standard-warning-handler condition)
  580.   (let ((hook standard-warning-hook))
  581.     (if hook
  582.     (fluid-let ((standard-warning-hook false))
  583.       (hook condition))
  584.     (let ((port (notification-output-port)))
  585.       (fresh-line port)
  586.       (write-string ";Warning: " port)
  587.       (write-condition-report condition port)
  588.       (newline port)))))
  589.  
  590. (define standard-error-hook false)
  591. (define standard-warning-hook false)
  592.  
  593. (define (condition-signaller type field-names default-handler)
  594.   (guarantee-condition-handler default-handler 'CONDITION-SIGNALLER)
  595.   (let ((make-condition (condition-constructor type field-names)))
  596.     (lambda field-values
  597.       (call-with-current-continuation
  598.        (lambda (continuation)
  599.      (let ((condition
  600.         (apply make-condition
  601.                (cons* continuation
  602.                   'BOUND-RESTARTS
  603.                   field-values))))
  604.        (signal-condition condition)
  605.        (default-handler condition)))))))
  606.  
  607. ;; This is similar to condition-signaller, but error procedures
  608. ;; created with this allow substitution of the INDEXth argument by
  609. ;; using the USE-VALUE restart and allow retrying the operation by
  610. ;; using the RETRY restart.  The RETRY restart will return the
  611. ;; original irritant, while USE-VALUE will return a value prompted for.
  612.  
  613. (define (substitutable-value-condition-signaller
  614.      type field-names default-handler
  615.      index use-value-prompt use-value-message retry-message)
  616.   (guarantee-condition-handler default-handler
  617.                    'SUBSTITUTABLE-VALUE-CONDITION-SIGNALLER)
  618.   (let ((make-condition (condition-constructor type field-names))
  619.     (arity (length field-names)))
  620.     (letrec
  621.     ((constructor
  622.       (lambda field-values
  623.         (if (not (= arity (length field-values)))
  624.         (error:wrong-number-of-arguments constructor
  625.                          arity
  626.                          field-values))
  627.         (call-with-current-continuation
  628.          (lambda (continuation)
  629.            (let ((condition
  630.               (apply make-condition
  631.                  (cons* continuation
  632.                     'BOUND-RESTARTS
  633.                     field-values))))
  634.          (with-restart 'USE-VALUE
  635.              (if (string? use-value-message)
  636.              use-value-message
  637.              (use-value-message condition))
  638.              continuation
  639.              (let ((prompt
  640.                 (if (string? use-value-prompt)
  641.                 use-value-prompt
  642.                 (use-value-prompt condition))))
  643.                (lambda ()
  644.              (values (prompt-for-evaluated-expression prompt))))
  645.            (lambda ()
  646.              (with-restart 'RETRY
  647.              (if (string? retry-message)
  648.                  retry-message
  649.                  (retry-message condition))
  650.              (lambda ()
  651.                (continuation (list-ref field-values index)))
  652.              values
  653.                (lambda ()
  654.              (signal-condition condition)
  655.              (default-handler condition)))))))))))
  656.       constructor)))
  657.  
  658. ;;;; Basic Condition Types
  659.  
  660. (define condition-type:arithmetic-error)
  661. (define condition-type:bad-range-argument)
  662. (define condition-type:cell-error)
  663. (define condition-type:control-error)
  664. (define condition-type:datum-out-of-range)
  665. (define condition-type:derived-file-error)
  666. (define condition-type:derived-port-error)
  667. (define condition-type:derived-thread-error)
  668. (define condition-type:divide-by-zero)
  669. (define condition-type:error)
  670. (define condition-type:file-error)
  671. (define condition-type:file-operation-error)
  672. (define condition-type:floating-point-overflow)
  673. (define condition-type:floating-point-underflow)
  674. (define condition-type:illegal-datum)
  675. (define condition-type:illegal-pathname-component)
  676. (define condition-type:no-such-restart)
  677. (define condition-type:port-error)
  678. (define condition-type:serious-condition)
  679. (define condition-type:simple-condition)
  680. (define condition-type:simple-error)
  681. (define condition-type:simple-warning)
  682. (define condition-type:thread-error)
  683. (define condition-type:unassigned-variable)
  684. (define condition-type:unbound-variable)
  685. (define condition-type:variable-error)
  686. (define condition-type:warning)
  687. (define condition-type:wrong-number-of-arguments)
  688. (define condition-type:wrong-type-argument)
  689. (define condition-type:wrong-type-datum)
  690.  
  691. (define make-simple-error)
  692. (define make-simple-warning)
  693.  
  694. (define error:bad-range-argument)
  695. (define error:datum-out-of-range)
  696. (define error:divide-by-zero)
  697. (define error:file-operation)
  698. (define error:no-such-restart)
  699. (define error:derived-file)
  700. (define error:derived-port)
  701. (define error:derived-thread)
  702. (define error:illegal-pathname-component)
  703. (define error:wrong-number-of-arguments)
  704. (define error:wrong-type-argument)
  705. (define error:wrong-type-datum)
  706.  
  707. (define condition/derived-thread?)
  708.  
  709. (define (condition-type/error? type)
  710.   (guarantee-condition-type type 'CONDITION-TYPE/ERROR?)
  711.   (%condition-type/error? type))
  712.  
  713. (define (condition/error? condition)
  714.   (guarantee-condition condition 'CONDITION/ERROR?)
  715.   (%condition/error? condition))
  716.  
  717. (define-integrable (%condition/error? condition)
  718.   (%condition-type/error? (%condition/type condition)))
  719.  
  720. (define-integrable (%condition-type/error? type)
  721.   (memq condition-type:error (%condition-type/generalizations type)))
  722.  
  723. (define (initialize-package!)
  724.   (set! hook/invoke-condition-handler default/invoke-condition-handler)
  725.   ;; No eta conversion for bootstrapping and efficiency reasons.
  726.   (set! hook/invoke-restart
  727.     (lambda (effector arguments)
  728.       (apply effector arguments)))
  729.   (set! condition-type:serious-condition
  730.     (make-condition-type 'SERIOUS-CONDITION false '() false))
  731.   (set! condition-type:warning
  732.     (make-condition-type 'WARNING false '() false))
  733.  
  734.   (set! condition-type:error
  735.     (make-condition-type 'ERROR condition-type:serious-condition '()
  736.       false))
  737.  
  738.   (let ((reporter/simple-condition
  739.      (lambda (condition port)
  740.        (format-error-message (access-condition condition 'MESSAGE)
  741.                  (access-condition condition 'IRRITANTS)
  742.                  port))))
  743.     (set! condition-type:simple-condition
  744.       (make-condition-type 'SIMPLE-CONDITION false '(MESSAGE IRRITANTS)
  745.         reporter/simple-condition))
  746.     (set! condition-type:simple-error
  747.       (make-condition-type 'SIMPLE-ERROR condition-type:error
  748.           '(MESSAGE IRRITANTS)
  749.         reporter/simple-condition))
  750.     (set! condition-type:simple-warning
  751.       (make-condition-type 'SIMPLE-WARNING condition-type:warning
  752.           '(MESSAGE IRRITANTS)
  753.         reporter/simple-condition)))
  754.  
  755.   (set! condition-type:illegal-datum
  756.     (make-condition-type 'ILLEGAL-DATUM condition-type:error '(DATUM)
  757.       (lambda (condition port)
  758.         (write-string "The object " port)
  759.         (write (access-condition condition 'DATUM) port)
  760.         (write-string " has been found in an inappropriate context."
  761.               port))))
  762.  
  763.   (set! condition-type:datum-out-of-range
  764.     (make-condition-type 'DATUM-OUT-OF-RANGE condition-type:illegal-datum
  765.         '()
  766.       (lambda (condition port)
  767.         (write-string "The object " port)
  768.         (write (access-condition condition 'DATUM) port)
  769.         (write-string " is not in the correct range." port))))
  770.  
  771.   (let ((write-type-description
  772.      (let ((char-set:vowels
  773.         (char-set #\a #\e #\i #\o #\u #\A #\E #\I #\O #\U)))
  774.        (lambda (condition port)
  775.          (let ((type (access-condition condition 'TYPE)))
  776.            (if (string? type)
  777.            (begin
  778.              (if (and (not (string-null? type))
  779.                   (not (or (string-prefix-ci? "a " type)
  780.                        (string-prefix-ci? "an " type))))
  781.              (write-string
  782.               (if (char-set-member? char-set:vowels
  783.                         (string-ref type 0))
  784.                   "an "
  785.                   "a ")
  786.               port))
  787.              (write-string type port))
  788.            (write-string "the correct type" port))))))
  789.     (write-operand-description
  790.      (lambda (condition port)
  791.        (let ((operator (access-condition condition 'OPERATOR))
  792.          (operand (access-condition condition 'OPERAND)))
  793.          (if (or (symbol? operator)
  794.              (procedure? operator))
  795.          (begin
  796.            (write-string ", passed " port)
  797.            (cond ((symbol? operand)
  798.               (write-string "as the argument " port)
  799.               (write operand port))
  800.              ((exact-nonnegative-integer? operand)
  801.               (write-string "as the " port)
  802.               (write-string (ordinal-number-string (+ operand 1))
  803.                     port)
  804.               (write-string " argument" port))
  805.              (else
  806.               (write-string "as an argument" port)))
  807.            (write-string " to " port)
  808.            (write-operator operator port)
  809.            (write-string "," port)))))))
  810.     (set! condition-type:wrong-type-datum
  811.       (make-condition-type 'WRONG-TYPE-DATUM condition-type:illegal-datum
  812.           '(TYPE)
  813.         (lambda (condition port)
  814.           (write-string "The object " port)
  815.           (write (access-condition condition 'DATUM) port)
  816.           (write-string " is not " port)
  817.           (write-type-description condition port)
  818.           (write-string "." port))))
  819.     (set! condition-type:wrong-type-argument
  820.       (make-condition-type 'WRONG-TYPE-ARGUMENT
  821.           condition-type:wrong-type-datum
  822.           '(OPERATOR OPERAND)
  823.         (lambda (condition port)
  824.           (write-string "The object " port)
  825.           (write (access-condition condition 'DATUM) port)
  826.           (write-operand-description condition port)
  827.           (write-string " is not " port)
  828.           (write-type-description condition port)
  829.           (write-string "." port))))
  830.     (set! condition-type:bad-range-argument
  831.       (make-condition-type 'BAD-RANGE-ARGUMENT
  832.           condition-type:datum-out-of-range
  833.           '(OPERATOR OPERAND)
  834.         (lambda (condition port)
  835.           (write-string "The object " port)
  836.           (write (access-condition condition 'DATUM) port)
  837.           (write-operand-description condition port)
  838.           (write-string " is not in the correct range." port)))))
  839.  
  840.   (set! condition-type:wrong-number-of-arguments
  841.     (make-condition-type 'WRONG-NUMBER-OF-ARGUMENTS
  842.         condition-type:wrong-type-datum
  843.         '(OPERANDS)
  844.       (lambda (condition port)
  845.         (let ((pluralize-argument
  846.            (lambda (number)
  847.              (write-string
  848.               (if (= number 1) " argument" " arguments")
  849.               port))))
  850.           (write-string "The procedure " port)
  851.           (write-operator (access-condition condition 'DATUM) port)
  852.           (write-string " has been called with " port)
  853.           (let ((count (length (access-condition condition 'OPERANDS))))
  854.         (write count port)
  855.         (pluralize-argument count))
  856.           (write-string "; it requires " port)
  857.           (let ((arity (access-condition condition 'TYPE)))
  858.         (cond ((not (pair? arity))
  859.                (write-string "exactly " port)
  860.                (write arity port)
  861.                (pluralize-argument arity))
  862.               ((not (cdr arity))
  863.                (write-string "at least " port)
  864.                (write (car arity) port)
  865.                (pluralize-argument (car arity)))
  866.               ((= (car arity) (cdr arity))
  867.                (write-string "exactly " port)
  868.                (write (car arity) port)
  869.                (pluralize-argument (car arity)))
  870.               (else
  871.                (write-string "between " port)
  872.                (write (car arity) port)
  873.                (write-string " and " port)
  874.                (write (cdr arity) port)
  875.                (write-string " arguments" port))))
  876.           (write-char #\. port)))))
  877.  
  878.   (set! condition-type:illegal-pathname-component
  879.     (make-condition-type 'ILLEGAL-PATHNAME-COMPONENT
  880.         condition-type:wrong-type-datum '()
  881.       (lambda (condition port)
  882.         (write-string "The object " port)
  883.         (write (access-condition condition 'DATUM) port)
  884.         (write-string " is not a valid pathname " port)
  885.         (write-string (access-condition condition 'TYPE) port)
  886.         (write-string "." port))))
  887.  
  888.   (set! condition-type:control-error
  889.     (make-condition-type 'CONTROL-ERROR condition-type:error '()
  890.       "Control error."))
  891.  
  892.   (set! condition-type:no-such-restart
  893.     (make-condition-type 'NO-SUCH-RESTART condition-type:control-error
  894.         '(NAME)
  895.       (lambda (condition port)
  896.         (write-string "The restart named " port)
  897.         (write (access-condition condition 'NAME) port)
  898.         (write-string " is not bound." port))))
  899.  
  900.   (let ((anonymous-error
  901.      (lambda (type-name field-name)
  902.        (make-condition-type type-name condition-type:error
  903.            (list field-name)
  904.          (lambda (condition port)
  905.            (write-string "Anonymous error associated with " port)
  906.            (write (access-condition condition field-name) port)
  907.            (write-string "." port))))))
  908.     (set! condition-type:port-error (anonymous-error 'PORT-ERROR 'PORT))
  909.     (set! condition-type:file-error (anonymous-error 'FILE-ERROR 'FILENAME))
  910.     (set! condition-type:cell-error (anonymous-error 'CELL-ERROR 'LOCATION))
  911.     (set! condition-type:thread-error (anonymous-error 'THREAD-ERROR 'THREAD)))
  912.  
  913.   (set! condition-type:derived-port-error
  914.     (make-condition-type 'DERIVED-PORT-ERROR condition-type:port-error
  915.         '(CONDITION)
  916.       (lambda (condition port)
  917.         (write-string "The port " port)
  918.         (write (access-condition condition 'PORT) port)
  919.         (write-string " signalled an error:" port)
  920.         (newline port)
  921.         (write-condition-report (access-condition condition 'CONDITION)
  922.                     port))))
  923.   (set! error:derived-port
  924.     (let ((make-condition
  925.            (condition-constructor condition-type:derived-port-error
  926.                       '(PORT CONDITION))))
  927.       (lambda (port condition)
  928.         (guarantee-condition condition 'ERROR:DERIVED-PORT)
  929.         (error (make-condition (%condition/continuation condition)
  930.                    (%condition/restarts condition)
  931.                    port
  932.                    condition)))))
  933.  
  934.   (set! condition-type:derived-file-error
  935.     (make-condition-type 'DERIVED-FILE-ERROR condition-type:file-error
  936.         '(CONDITION)
  937.       (lambda (condition port)
  938.         (write-string "The file " port)
  939.         (write (access-condition condition 'FILENAME) port)
  940.         (write-string " signalled an error:" port)
  941.         (newline port)
  942.         (write-condition-report (access-condition condition 'CONDITION)
  943.                     port))))
  944.   (set! error:derived-file
  945.     (let ((make-condition
  946.            (condition-constructor condition-type:derived-file-error
  947.                       '(FILENAME CONDITION))))
  948.       (lambda (filename condition)
  949.         (guarantee-condition condition 'ERROR:DERIVED-FILE)
  950.         (error (make-condition (%condition/continuation condition)
  951.                    (%condition/restarts condition)
  952.                    filename
  953.                    condition)))))
  954.  
  955.   (set! condition-type:derived-thread-error
  956.     (make-condition-type 'DERIVED-THREAD-ERROR condition-type:thread-error
  957.         '(CONDITION)
  958.       (lambda (condition port)
  959.         (write-string "The thread " port)
  960.         (write (access-condition condition 'THREAD) port)
  961.         (write-string " signalled " port)
  962.         (let ((condition (access-condition condition 'CONDITION)))
  963.           (write-string (if (condition/error? condition)
  964.                 "an error"
  965.                 "a condition")
  966.                 port)
  967.           (write-string ":" port)
  968.           (newline port)
  969.           (write-condition-report condition port)))))
  970.   (set! error:derived-thread
  971.     (let ((make-condition
  972.            (condition-constructor condition-type:derived-thread-error
  973.                       '(THREAD CONDITION))))
  974.       (lambda (thread condition)
  975.         (guarantee-condition condition 'ERROR:DERIVED-THREAD)
  976.         (let ((condition
  977.            (make-condition (%condition/continuation condition)
  978.                    (%condition/restarts condition)
  979.                    thread
  980.                    condition)))
  981.           (with-simple-restart 'CONTINUE "Continue from error."
  982.         (lambda ()
  983.           (restart/put! (first-bound-restart)
  984.                 'ASSOCIATED-CONDITION
  985.                 condition)
  986.           (error condition)))))))
  987.   (set! condition/derived-thread?
  988.     (condition-predicate condition-type:derived-thread-error))
  989.  
  990.   (set! condition-type:file-operation-error
  991.     (make-condition-type 'FILE-OPERATION-ERROR condition-type:file-error
  992.         '(VERB NOUN REASON OPERATOR OPERANDS)
  993.       (lambda (condition port)
  994.         (let ((noun (access-condition condition 'NOUN)))
  995.           (write-string "Unable to " port)
  996.           (write-string (access-condition condition 'VERB) port)
  997.           (write-string " " port)
  998.           (write-string noun port)
  999.           (write-string " " port)
  1000.           (write (->namestring (access-condition condition 'FILENAME))
  1001.              port)
  1002.           (write-string " because: " port)
  1003.           (let ((reason (access-condition condition 'REASON)))
  1004.         (if reason
  1005.             (write-string (string-capitalize reason) port)
  1006.             (begin
  1007.               (write-string "No such " port)
  1008.               (write-string noun port))))
  1009.           (write-string "." port)))))
  1010.   (set! error:file-operation
  1011.     (let ((get-verb
  1012.            (condition-accessor condition-type:file-operation-error 'VERB))
  1013.           (get-noun
  1014.            (condition-accessor condition-type:file-operation-error 'NOUN)))
  1015.       (substitutable-value-condition-signaller
  1016.        condition-type:file-operation-error
  1017.        '(FILENAME VERB NOUN REASON OPERATOR OPERANDS)
  1018.        standard-error-handler
  1019.        0
  1020.        (lambda (condition)
  1021.          (string-append "New "
  1022.                 (get-noun condition)
  1023.                 " name (an expression to be evaluated)"))
  1024.        (lambda (condition)
  1025.          (string-append "Try to "
  1026.                 (get-verb condition)
  1027.                 " a different "
  1028.                 (get-noun condition)
  1029.                 "."))
  1030.        (lambda (condition)
  1031.          (string-append "Try to "
  1032.                 (get-verb condition)
  1033.                 " the same "
  1034.                 (get-noun condition)
  1035.                 " again.")))))
  1036.  
  1037.   (set! condition-type:variable-error
  1038.     (make-condition-type 'VARIABLE-ERROR condition-type:cell-error
  1039.         '(ENVIRONMENT)
  1040.       (lambda (condition port)
  1041.         (write-string "Anonymous error associated with variable " port)
  1042.         (write (access-condition condition 'LOCATION) port)
  1043.         (write-string "." port))))
  1044.  
  1045.   (set! condition-type:unbound-variable
  1046.     (make-condition-type 'UNBOUND-VARIABLE condition-type:variable-error
  1047.         '()
  1048.       (lambda (condition port)
  1049.         (write-string "Unbound variable: " port)
  1050.         (write (access-condition condition 'LOCATION) port))))
  1051.  
  1052.   (set! condition-type:unassigned-variable
  1053.     (make-condition-type 'UNASSIGNED-VARIABLE condition-type:variable-error
  1054.         '()
  1055.       (lambda (condition port)
  1056.         (write-string "Unassigned variable: " port)
  1057.         (write (access-condition condition 'LOCATION) port))))
  1058.  
  1059.   (let ((arithmetic-error-report
  1060.      (lambda (description)
  1061.        (lambda (condition port)
  1062.          (write-string description port)
  1063.          (let ((operator (access-condition condition 'OPERATOR)))
  1064.            (if operator
  1065.            (begin
  1066.              (write-string " signalled by " port)
  1067.              (write-operator operator port)
  1068.              (write-string "." port))))))))
  1069.     (set! condition-type:arithmetic-error
  1070.       (make-condition-type 'ARITHMETIC-ERROR condition-type:error
  1071.           '(OPERATOR OPERANDS)
  1072.         (arithmetic-error-report "Anonymous arithmetic error")))
  1073.     (set! condition-type:divide-by-zero
  1074.       (make-condition-type 'DIVIDE-BY-ZERO condition-type:arithmetic-error
  1075.           '()
  1076.         (arithmetic-error-report "Division by zero")))
  1077.     (set! condition-type:floating-point-overflow
  1078.       (make-condition-type 'FLOATING-POINT-OVERFLOW
  1079.           condition-type:arithmetic-error
  1080.           '()
  1081.         (arithmetic-error-report "Floating-point overflow")))
  1082.     (set! condition-type:floating-point-underflow
  1083.       (make-condition-type 'FLOATING-POINT-UNDERFLOW
  1084.           condition-type:arithmetic-error
  1085.           '()
  1086.         (arithmetic-error-report "Floating-point underflow"))))
  1087.  
  1088.   (set! make-simple-error
  1089.     (condition-constructor condition-type:simple-error
  1090.                    '(MESSAGE IRRITANTS)))
  1091.   (set! make-simple-warning
  1092.     (condition-constructor condition-type:simple-warning
  1093.                    '(MESSAGE IRRITANTS)))
  1094.  
  1095.   (set! error:wrong-type-datum
  1096.     (condition-signaller condition-type:wrong-type-datum
  1097.                  '(DATUM TYPE)
  1098.                  standard-error-handler))
  1099.   (set! error:datum-out-of-range
  1100.     (condition-signaller condition-type:datum-out-of-range
  1101.                  '(DATUM)
  1102.                  standard-error-handler))
  1103.   (set! error:wrong-type-argument
  1104.     (condition-signaller condition-type:wrong-type-argument
  1105.                  '(DATUM TYPE OPERATOR)
  1106.                  standard-error-handler))
  1107.   (set! error:bad-range-argument
  1108.     (condition-signaller condition-type:bad-range-argument
  1109.                  '(DATUM OPERATOR)
  1110.                  standard-error-handler))
  1111.   (set! error:wrong-number-of-arguments
  1112.     (condition-signaller condition-type:wrong-number-of-arguments
  1113.                  '(DATUM TYPE OPERANDS)
  1114.                  standard-error-handler))
  1115.   (set! error:illegal-pathname-component
  1116.     (condition-signaller condition-type:illegal-pathname-component
  1117.                  '(DATUM TYPE)
  1118.                  standard-error-handler))
  1119.   (set! error:divide-by-zero
  1120.     (condition-signaller condition-type:divide-by-zero
  1121.                  '(OPERATOR OPERANDS)
  1122.                  standard-error-handler))
  1123.   (set! error:no-such-restart
  1124.     (condition-signaller condition-type:no-such-restart
  1125.                  '(NAME)
  1126.                  standard-error-handler))
  1127.  
  1128.   unspecific)
  1129.  
  1130. ;;;; Utilities
  1131.  
  1132. (define (format-error-message message irritants port)
  1133.   (fluid-let ((*unparser-list-depth-limit* 2)
  1134.           (*unparser-list-breadth-limit* 5))
  1135.     (for-each (lambda (irritant)
  1136.         (if (and (pair? irritant)
  1137.              (eq? (car irritant) error-irritant/noise-tag))
  1138.             (display (cdr irritant) port)
  1139.             (begin
  1140.               (write-char #\space port)
  1141.               (write irritant port))))
  1142.           (cons (if (string? message)
  1143.             (error-irritant/noise message)
  1144.             message)
  1145.             irritants))))
  1146.  
  1147. (define-integrable (error-irritant/noise noise)
  1148.   (cons error-irritant/noise-tag noise))
  1149.  
  1150. (define error-irritant/noise-tag
  1151.   '(error-irritant/noise))
  1152.  
  1153. (define (ordinal-number-string n)
  1154.   (if (not (and (exact-nonnegative-integer? n) (< n 100)))
  1155.       (error:wrong-type-argument n "exact integer between 0 and 99"
  1156.                  'ORDINAL-NUMBER-STRING))
  1157.   (let ((ones-names
  1158.      #("zeroth" "first" "second" "third" "fourth" "fifth" "sixth"
  1159.             "seventh" "eighth" "ninth"))
  1160.     (tens-names #("twen" "thir" "for" "fif" "six" "seven" "eigh" "nine")))
  1161.     (cond ((< n 10) (vector-ref ones-names n))
  1162.       ((< n 20)
  1163.        (vector-ref #("tenth" "eleventh" "twelfth" "thirteenth" "fourteenth"
  1164.                  "fifteenth" "sixteenth" "seventeenth"
  1165.                  "eighteenth" "nineteenth")
  1166.                (- n 10)))
  1167.       (else
  1168.        (let ((qr (integer-divide n 10)))
  1169.          (string-append
  1170.           (vector-ref tens-names (- (integer-divide-quotient qr) 2))
  1171.           (let ((ones (integer-divide-remainder qr)))
  1172.         (if (zero? ones)
  1173.             "tieth"
  1174.             (string-append "ty-" (vector-ref ones-names ones))))))))))
  1175.  
  1176. (define (write-operator operator port)
  1177.   (write (if (primitive-procedure? operator)
  1178.          (primitive-procedure-name operator)
  1179.          operator)
  1180.      port))
  1181.  
  1182. (define-integrable (guarantee-list-of-symbols object operator)
  1183.   (if (not (list-of-symbols? object))
  1184.       (error:wrong-type-argument object "list of unique symbols" operator)))
  1185.  
  1186. (define (list-of-symbols? object)
  1187.   (and (list? object)
  1188.        (let loop ((field-names object))
  1189.      (or (null? field-names)
  1190.          (and (symbol? (car field-names))
  1191.           (not (memq (car field-names) (cdr field-names)))
  1192.           (loop (cdr field-names)))))))
  1193.  
  1194. (define-integrable (guarantee-keyword-association-list object operator)
  1195.   (if (not (keyword-association-list? object))
  1196.       (error:wrong-type-argument object "keyword association list" operator)))
  1197.  
  1198. (define (keyword-association-list? object)
  1199.   (and (list? object)
  1200.        (let loop ((l object) (symbols '()))
  1201.      (or (null? l)
  1202.          (and (symbol? (car l))
  1203.           (not (memq (car l) symbols))
  1204.           (not (null? (cdr l)))
  1205.           (loop (cddr l) (cons (car l) symbols)))))))
  1206.  
  1207. (define-integrable (procedure-of-arity? object arity)
  1208.   (and (procedure? object)
  1209.        (procedure-arity-valid? object arity)))
  1210.  
  1211. (define-integrable (guarantee-symbol object operator)
  1212.   (if (not (symbol? object))
  1213.       (error:wrong-type-argument object "symbol" operator)))
  1214.  
  1215. (define-integrable (guarantee-continuation object operator)
  1216.   (if (not (continuation? object))
  1217.       (error:wrong-type-argument object "continuation" operator)))
  1218.  
  1219. (define-integrable (guarantee-output-port object operator)
  1220.   (if (not (output-port? object))
  1221.       (error:wrong-type-argument object "output port" operator)))
  1222.  
  1223. (define-integrable (guarantee-condition-type object operator)
  1224.   (if (not (condition-type? object))
  1225.       (error:wrong-type-argument object "condition type" operator)))
  1226.  
  1227. (define-integrable (guarantee-condition-types object operator)
  1228.   (if (not (and (list? object) (for-all? object condition-type?)))
  1229.       (error:wrong-type-argument object "list of condition types" operator)))
  1230.  
  1231. (define-integrable (guarantee-condition object operator)
  1232.   (if (not (condition? object))
  1233.       (error:wrong-type-argument object "condition" operator)))
  1234.  
  1235. (define-integrable (guarantee-condition-handler object operator)
  1236.   (if (not (procedure-of-arity? object 1))
  1237.       (error:wrong-type-argument object "procedure of one argument" operator)))
  1238.  
  1239. (define-integrable (guarantee-restart object operator)
  1240.   (if (not (restart? object))
  1241.       (error:wrong-type-argument object "restart" operator)))
  1242.  
  1243. (define-integrable (guarantee-restarts object operator)
  1244.   (if (not (and (list? object) (for-all? object restart?)))
  1245.       (error:wrong-type-argument object "list of restarts" operator)))