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 / recslot.scm < prev    next >
Text File  |  1999-01-02  |  7KB  |  198 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: recslot.scm,v 1.4 1999/01/02 06:11:34 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1995-1999 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but 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. ;;;; Record Slot Access
  22.  
  23. (declare (usual-integrations))
  24.  
  25. (define (%record-accessor-generator name)
  26.   (lambda (generic tags)
  27.     generic
  28.     (let ((index (%record-slot-index (%record (car tags)) name)))
  29.       (and index
  30.        (%record-accessor index)))))
  31.  
  32. (define (%record-modifier-generator name)
  33.   (lambda (generic tags)
  34.     generic
  35.     (let ((index (%record-slot-index (%record (car tags)) name)))
  36.       (and index
  37.        (%record-modifier index)))))
  38.  
  39. (define (%record-initpred-generator name)
  40.   (lambda (generic tags)
  41.     generic
  42.     (let ((index (%record-slot-index (%record (car tags)) name)))
  43.       (and index
  44.        (%record-initpred index)))))
  45.  
  46. (define-macro (generate-index-cases index limit expand-case)
  47.   `(CASE ,index
  48.      ,@(let loop ((i 1))
  49.      (if (= i limit)
  50.          `((ELSE (,expand-case ,index)))
  51.          `(((,i) (,expand-case ,i)) ,@(loop (+ i 1)))))))
  52.  
  53. (define (%record-accessor index)
  54.   (generate-index-cases index 16
  55.     (lambda (index)
  56.       (declare (integrate index)
  57.            (ignore-reference-traps (set record-slot-uninitialized)))
  58.       (lambda (record)
  59.     (if (eq? record-slot-uninitialized (%record-ref record index))
  60.         (error:uninitialized-slot record index)
  61.         (%record-ref record index))))))
  62.  
  63. (define (%record-modifier index)
  64.   (generate-index-cases index 16
  65.     (lambda (index)
  66.       (declare (integrate index))
  67.       (lambda (record value) (%record-set! record index value)))))
  68.  
  69. (define (%record-initpred index)
  70.   (generate-index-cases index 16
  71.     (lambda (index)
  72.       (declare (integrate index)
  73.            (ignore-reference-traps (set record-slot-uninitialized)))
  74.       (lambda (record)
  75.     (not (eq? record-slot-uninitialized (%record-ref record index)))))))
  76.  
  77. (define (%record-slot-name record index)
  78.   (if (not (and (exact-integer? index) (positive? index)))
  79.       (error:wrong-type-argument index "record index" '%RECORD-SLOT-NAME))
  80.   (let ((names
  81.      (call-with-current-continuation
  82.       (lambda (k)
  83.         (bind-condition-handler (list condition-type:no-applicable-methods)
  84.         (lambda (condition) condition (k 'UNKNOWN))
  85.           (lambda ()
  86.         (%record-slot-names record))))))
  87.     (index (- index 1)))
  88.     (and (list? names)
  89.      (< index (length names))
  90.      (list-ref names index))))
  91.  
  92. (define %record-slot-index)
  93. (define %record-slot-names)
  94.  
  95. (define (initialize-record-slot-access!)
  96.   (set! %record-slot-index (make-generic-procedure 2 '%RECORD-SLOT-INDEX))
  97.   (add-generic-procedure-generator %record-slot-index
  98.     (lambda (generic tags)
  99.       generic
  100.       (and (record-type? (dispatch-tag-contents (car tags)))
  101.        (lambda (record name)
  102.          (record-type-field-index (record-type-descriptor record)
  103.                       name
  104.                       #f)))))
  105.   (set! %record-slot-names (make-generic-procedure 1 '%RECORD-SLOT-NAMES))
  106.   (add-generic-procedure-generator %record-slot-names
  107.     (lambda (generic tags)
  108.       generic
  109.       (and (record-type? (dispatch-tag-contents (car tags)))
  110.        (lambda (record)
  111.          (record-type-field-names (record-type-descriptor record)))))))
  112.  
  113. (define (store-value-restart location k thunk)
  114.   (let ((location (write-to-string location)))
  115.     (with-restart 'STORE-VALUE
  116.     (string-append "Initialize slot " location " to a given value.")
  117.     k
  118.     (string->interactor (string-append "Set " location " to"))
  119.       thunk)))
  120.  
  121. (define (use-value-restart noun-phrase k thunk)
  122.   (with-restart 'USE-VALUE
  123.       (string-append "Specify a " noun-phrase ".")
  124.       k
  125.       (string->interactor (string-capitalize noun-phrase))
  126.     thunk))
  127.  
  128. (define ((string->interactor string))
  129.   (values (prompt-for-evaluated-expression string)))
  130.  
  131. (define condition-type:slot-error)
  132. (define condition-type:uninitialized-slot)
  133. (define condition-type:no-such-slot)
  134. (define error:uninitialized-slot)
  135. (define error:no-such-slot)
  136.  
  137. (define (initialize-conditions!)
  138.   (set! condition-type:slot-error
  139.     (make-condition-type 'SLOT-ERROR condition-type:cell-error
  140.         '()
  141.       (lambda (condition port)
  142.         (write-string "Anonymous error for slot " port)
  143.         (write (access-condition condition 'LOCATION) port)
  144.         (write-string "." port))))
  145.   (set! condition-type:uninitialized-slot
  146.     (make-condition-type 'UNINITIALIZED-SLOT condition-type:slot-error
  147.         '(RECORD)
  148.       (lambda (condition port)
  149.         (write-string "Attempt to reference slot " port)
  150.         (write (access-condition condition 'LOCATION) port)
  151.         (write-string " in record " port)
  152.         (write (access-condition condition 'RECORD) port)
  153.         (write-string " failed because the slot is not initialized."
  154.               port))))
  155.   (set! condition-type:no-such-slot
  156.     (make-condition-type 'NO-SUCH-SLOT condition-type:slot-error
  157.         '(RECORD-TYPE)
  158.       (lambda (condition port)
  159.         (write-string "No slot named " port)
  160.         (write (access-condition condition 'LOCATION) port)
  161.         (write-string " in records of type " port)
  162.         (write (access-condition condition 'RECORD-TYPE) port)
  163.         (write-string "." port))))
  164.   (set! error:uninitialized-slot
  165.     (let ((signal
  166.            (condition-signaller condition-type:uninitialized-slot
  167.                     '(RECORD LOCATION)
  168.                     standard-error-handler)))
  169.       (lambda (record index)
  170.         (let* ((location (or (%record-slot-name record index) index))
  171.            (ls (write-to-string location)))
  172.           (call-with-current-continuation
  173.            (lambda (k)
  174.          (store-value-restart ls
  175.                       (lambda (value)
  176.                     (%record-set! record index value)
  177.                     (k value))
  178.            (lambda ()
  179.              (use-value-restart
  180.               (string-append
  181.                "value to use instead of the contents of slot "
  182.                ls)
  183.               k
  184.               (lambda () (signal record location)))))))))))
  185.   (set! error:no-such-slot
  186.     (let ((signal
  187.            (condition-signaller condition-type:no-such-slot
  188.                     '(RECORD-TYPE LOCATION)
  189.                     standard-error-handler)))
  190.       (lambda (record-type name)
  191.         (call-with-current-continuation
  192.          (lambda (k)
  193.            (use-value-restart
  194.         (string-append "slot name to use instead of "
  195.                    (write-to-string name))
  196.         k
  197.         (lambda () (signal record-type name))))))))
  198.   unspecific)