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 / defstr.scm < prev    next >
Text File  |  2000-01-04  |  30KB  |  872 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: defstr.scm,v 14.33 2000/01/04 05:14:22 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 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. ;;;; Structure Definition Macro
  23. ;;; package: (runtime defstruct)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. #| 
  28.  
  29. This macro works like the Common Lisp `defstruct' with the following
  30. differences:
  31.  
  32. * The default constructor procedure takes positional arguments, in the
  33.   same order as specified in the definition of the structure.  A
  34.   keyword constructor may be specified by giving the option
  35.   KEYWORD-CONSTRUCTOR.
  36.  
  37. * BOA constructors are described using Scheme lambda lists.  Since
  38.   there is nothing corresponding to &aux in Scheme lambda lists, this
  39.   functionality is not implemented.
  40.  
  41. * By default, no COPIER procedure is generated.
  42.  
  43. * The side effect procedure corresponding to the accessor "foo" is
  44.   given the name "set-foo!".
  45.  
  46. * Keywords are just ordinary symbols -- use "foo" instead of ":foo".
  47.  
  48. * The option values FALSE, NIL, TRUE, and T are treated as if the
  49.   appropriate boolean constant had been specified instead.
  50.  
  51. * The PRINT-FUNCTION option is named PRINT-PROCEDURE.  Its argument is
  52.   a procedure of two arguments (the unparser state and the structure
  53.   instance) rather than three as in Common Lisp.
  54.  
  55. * By default, named structures are tagged with a unique object of some
  56.   kind.  In Common Lisp, the structures are tagged with symbols, but
  57.   that depends on the Common Lisp package system to help generate
  58.   unique tags; Scheme has no such way of generating unique symbols.
  59.  
  60. * The NAMED option may optionally take an argument, which is normally
  61.   the name of a variable (any expression may be used, but it will be
  62.   evaluated whenever the tag name is needed).  If used, structure
  63.   instances will be tagged with that variable's value.  The variable
  64.   must be defined when the defstruct is evaluated.
  65.  
  66. * The TYPE option is restricted to the values VECTOR and LIST.
  67.  
  68. * The INCLUDE option is not implemented.
  69.  
  70. |#
  71.  
  72. (define (initialize-define-structure-macro!)
  73.   (syntax-table-define system-global-syntax-table 'DEFINE-STRUCTURE
  74.     transform/define-structure))
  75.  
  76. (define transform/define-structure
  77.   (macro (name-and-options . slot-descriptions)
  78.     (let ((structure
  79.        (with-values
  80.            (lambda ()
  81.          (if (pair? name-and-options)
  82.              (values (car name-and-options) (cdr name-and-options))
  83.              (values name-and-options '())))
  84.          (lambda (name options)
  85.            (parse/options name
  86.                   options
  87.                   (map parse/slot-description
  88.                    slot-descriptions))))))
  89.       (do ((slots (structure/slots structure) (cdr slots))
  90.        (index (if (structure/named? structure)
  91.               (+ (structure/offset structure) 1)
  92.               (structure/offset structure))
  93.           (+ index 1)))
  94.       ((null? slots))
  95.     (set-slot/index! (car slots) index))
  96.       `(BEGIN ,@(type-definitions structure)
  97.           ,@(constructor-definitions structure)
  98.           ,@(accessor-definitions structure)
  99.           ,@(modifier-definitions structure)
  100.           ,@(predicate-definitions structure)
  101.           ,@(copier-definitions structure)))))
  102.  
  103. ;;;; Parse Options
  104.  
  105. ;; These two names are separated to cross-syntaxing from #F=='() to
  106. ;; #F != '()
  107.  
  108. (define names-meaning-false
  109.   '(#F FALSE NIL))
  110.  
  111. (define (make-default-defstruct-unparser-text name)
  112.   `(,(absolute 'STANDARD-UNPARSER-METHOD)
  113.     ',name
  114.     #F))
  115.  
  116. (define (parse/options name options slots)
  117.   (if (not (symbol? name))
  118.       (error "Structure name must be a symbol:" name))
  119.   (if (not (list? options))
  120.       (error "Structure options must be a list:" options))
  121.   (let ((conc-name (symbol-append name '-))
  122.     (default-constructor-disabled? false)
  123.     (boa-constructors '())
  124.     (keyword-constructors '())
  125.     (copier-name false)
  126.     (predicate-name (symbol-append name '?))
  127.     (print-procedure default)
  128.     (type 'RECORD)
  129.     (type-name name)
  130.     (tag-expression name)
  131.     (safe-accessors? #f)
  132.     (offset 0)
  133.     (options-seen '()))
  134.     (for-each
  135.      (lambda (option)
  136.        (if (not (or (symbol? option)
  137.             (and (pair? option)
  138.              (symbol? (car option))
  139.              (list? (cdr option)))))
  140.        (error "Ill-formed structure option:" option))
  141.        (with-values
  142.        (lambda ()
  143.          (if (pair? option)
  144.          (values (car option) (cdr option))
  145.          (values option '())))
  146.      (lambda (keyword arguments)
  147.        (set! options-seen (cons (cons keyword option) options-seen))
  148.        (let ((n-arguments (length arguments))
  149.          (check-duplicate
  150.           (lambda ()
  151.             (let ((previous (assq keyword (cdr options-seen))))
  152.               (if previous
  153.               (error "Duplicate structure option:"
  154.                  previous option)))))
  155.          (symbol-option
  156.           (lambda (argument)
  157.             (cond ((memq argument names-meaning-false) false)
  158.               ((symbol? argument) argument)
  159.               (else (error "Illegal structure option:" option))))))
  160.          (let ((check-argument
  161.             (lambda ()
  162.               (if (not (= n-arguments 1))
  163.               (error
  164.                (if (= n-arguments 0)
  165.                    "Structure option requires an argument:"
  166.                    "Structure option accepts at most 1 argument:")
  167.                option))))
  168.            (check-arguments
  169.             (lambda (max)
  170.               (if (> n-arguments max)
  171.               (error (string-append
  172.                   "Structure option accepts at most "
  173.                   (number->string max)
  174.                   " arguments:")
  175.                  option)))))
  176.            (case keyword
  177.          ((CONC-NAME)
  178.           (check-duplicate)
  179.           (check-argument)
  180.           (set! conc-name (symbol-option (car arguments))))
  181.          ((CONSTRUCTOR)
  182.           (check-arguments 2)
  183.           (if (null? arguments)
  184.               (set! boa-constructors
  185.                 (cons (list option (symbol-append 'MAKE- name))
  186.                   boa-constructors))
  187.               (let ((name (car arguments)))
  188.             (if (memq name names-meaning-false)
  189.                 (set! default-constructor-disabled? true)
  190.                 (set! boa-constructors
  191.                   (cons (cons option arguments)
  192.                     boa-constructors))))))
  193.          ((KEYWORD-CONSTRUCTOR)
  194.           (check-arguments 1)
  195.           (set! keyword-constructors
  196.             (cons (list option
  197.                     (if (null? arguments)
  198.                     (symbol-append 'MAKE- name)
  199.                     (car arguments)))
  200.                   keyword-constructors)))
  201.          ((COPIER)
  202.           (check-duplicate)
  203.           (check-arguments 1)
  204.           (set! copier-name
  205.             (if (null? arguments)
  206.                 (symbol-append 'COPY- name)
  207.                 (symbol-option (car arguments)))))
  208.          ((PREDICATE)
  209.           (check-duplicate)
  210.           (check-arguments 1)
  211.           (set! predicate-name
  212.             (if (null? arguments)
  213.                 (symbol-append name '?)
  214.                 (symbol-option (car arguments)))))
  215.          ((PRINT-PROCEDURE)
  216.           (check-duplicate)
  217.           (check-argument)
  218.           (set! print-procedure
  219.             (and (not (memq (car arguments) names-meaning-false))
  220.                  (car arguments))))
  221.          ((TYPE)
  222.           (check-duplicate)
  223.           (check-argument)
  224.           (if (not (memq (car arguments) '(VECTOR LIST)))
  225.               (error "Illegal structure option:" option))
  226.           (set! type (car arguments)))
  227.          ((TYPE-DESCRIPTOR)
  228.           (check-duplicate)
  229.           (check-argument)
  230.           (set! type-name (car arguments))
  231.           (set! tag-expression type-name))
  232.          ((NAMED)
  233.           (check-duplicate)
  234.           (check-arguments 1)
  235.           (if (null? arguments)
  236.               (begin
  237.             (set! type-name name)
  238.             (set! tag-expression type-name))
  239.               (begin
  240.             (set! type-name false)
  241.             (set! tag-expression (car arguments)))))
  242.          ((SAFE-ACCESSORS)
  243.           (check-duplicate)
  244.           (check-arguments 1)
  245.           (set! safe-accessors?
  246.             (if (null? arguments) #t (car arguments))))
  247.          ((INITIAL-OFFSET)
  248.           (check-duplicate)
  249.           (check-argument)
  250.           (if (not (exact-nonnegative-integer? (car arguments)))
  251.               (error "Illegal structure option:" option))
  252.           (set! offset (car arguments)))
  253.          (else
  254.           (error "Unknown structure option:" option))))))))
  255.      options)
  256.     (let loop ((constructors (append boa-constructors keyword-constructors)))
  257.       (if (not (null? constructors))
  258.       (begin
  259.         (let ((name (cadar constructors)))
  260.           (for-each (lambda (constructor)
  261.               (if (eq? name (cadr constructor))
  262.                   (error "Conflicting constructor definitions:"
  263.                      (caar constructors)
  264.                      (car constructor))))
  265.             (cdr constructors)))
  266.         (loop (cdr constructors)))))
  267.     (let ((type-seen? (assq 'TYPE options-seen))
  268.       (type-descriptor-seen? (assq 'TYPE-DESCRIPTOR options-seen))
  269.       (named-seen? (assq 'NAMED options-seen)))
  270.       (if (and type-descriptor-seen? named-seen?)
  271.       (error "Conflicting options:" type-descriptor-seen? named-seen?))
  272.       (let ((named? (or (not type-seen?) type-descriptor-seen? named-seen?)))
  273.     (if (not type-seen?)
  274.         (let ((check-option
  275.            (lambda (seen?)
  276.              (if seen?
  277.              (error "Structure option illegal without TYPE option:"
  278.                 (cdr seen?))))))
  279.           (check-option (and (not type-name) named-seen?))
  280.           (check-option (assq 'INITIAL-OFFSET options-seen))))
  281.     (if (not named?)
  282.         (let ((check
  283.            (lambda (option-seen)
  284.              (if option-seen
  285.              (error
  286.               "Structure option illegal for unnamed structure:"
  287.               (cdr option-seen))))))
  288.           (if predicate-name
  289.           (check (assq 'PREDICATE options-seen)))
  290.           (if (and (not (eq? print-procedure default)) print-procedure)
  291.           (check (assq 'PRINT-PROCEDURE options-seen)))))
  292.     (make-structure name
  293.             conc-name
  294.             (map cdr keyword-constructors)
  295.             (cond ((or (not (null? boa-constructors))
  296.                    (not (null? keyword-constructors)))
  297.                    (map cdr boa-constructors))
  298.                   ((not default-constructor-disabled?)
  299.                    (list (list (symbol-append 'MAKE- name))))
  300.                   (else
  301.                    '()))
  302.             copier-name
  303.             (and named? predicate-name)
  304.             (and named?
  305.                  (cond ((not (eq? print-procedure default))
  306.                     print-procedure)
  307.                    ((eq? type 'RECORD)
  308.                     false)
  309.                    (else
  310.                     (make-default-defstruct-unparser-text
  311.                      name))))
  312.             type
  313.             named?
  314.             (and named? type-name)
  315.             (and named? tag-expression)
  316.             safe-accessors?
  317.             offset
  318.             slots)))))
  319.  
  320. (define default
  321.   (list 'DEFAULT))
  322.  
  323. ;;;; Parse Slot-Descriptions
  324.  
  325. (define (parse/slot-description slot-description)
  326.   (with-values
  327.       (lambda ()
  328.     (if (pair? slot-description)
  329.         (if (pair? (cdr slot-description))
  330.         (values (car slot-description)
  331.             (cadr slot-description)
  332.             (cddr slot-description))
  333.         (values (car slot-description) false '()))
  334.         (values slot-description false '())))
  335.     (lambda (name default options)
  336.       (if (not (list? options))
  337.       (error "Structure slot options must be a list:" options))
  338.       (let ((type true)
  339.         (read-only? false)
  340.         (options-seen '()))
  341.     (do ((options options (cddr options)))
  342.         ((null? options))
  343.       (if (null? (cdr options))
  344.           (error "Missing slot option argument:" (car options)))
  345.       (let ((previous (assq (car options) options-seen))
  346.         (option (list (car options) (cadr options))))
  347.         (if previous
  348.         (error "Duplicate slot option:" previous option))
  349.         (set! options-seen (cons option options-seen))
  350.         (case (car options)
  351.           ((TYPE)
  352.            (set! type
  353.              (let ((argument (cadr options)))
  354.                (cond ((memq argument '(#T TRUE T)) true)
  355.                  ((symbol? argument) argument)
  356.                  (else (error "Illegal slot option:" option))))))
  357.           ((READ-ONLY)
  358.            (set! read-only?
  359.              (let ((argument (cadr options)))
  360.                (cond ((memq argument names-meaning-false) false)
  361.                  ((memq argument '(#T TRUE T)) true)
  362.                  (else (error "Illegal slot option:" option))))))
  363.           (else
  364.            (error "Unrecognized structure slot option:" option)))))
  365.     (make-slot name default type read-only?)))))
  366.  
  367. ;;;; Descriptive Structure
  368.  
  369. (define structure-rtd)
  370. (define make-structure)
  371. (define structure?)
  372. (define structure/name)
  373. (define structure/conc-name)
  374. (define structure/keyword-constructors)
  375. (define structure/boa-constructors)
  376. (define structure/copier-name)
  377. (define structure/predicate-name)
  378. (define structure/print-procedure)
  379. (define structure/type)
  380. (define structure/named?)
  381. (define structure/type-name)
  382. (define structure/tag-expression)
  383. (define structure/safe-accessors?)
  384. (define structure/offset)
  385. (define structure/slots)
  386.  
  387. (define slot-rtd)
  388. (define make-slot)
  389. (define slot/name)
  390. (define slot/default)
  391. (define slot/type)
  392. (define slot/read-only?)
  393. (define slot/index)
  394. (define set-slot/index!)
  395. (define slot-assoc)
  396.  
  397. (define (initialize-structure-types!)
  398.   (set! structure-rtd
  399.     (make-record-type
  400.      "structure"
  401.      '(NAME CONC-NAME KEYWORD-CONSTRUCTORS BOA-CONSTRUCTORS COPIER-NAME
  402.         PREDICATE-NAME PRINT-PROCEDURE TYPE NAMED? TYPE-NAME
  403.         TAG-EXPRESSION SAFE-ACCESSORS? OFFSET SLOTS)))
  404.   (set! make-structure (record-constructor structure-rtd))
  405.   (set! structure? (record-predicate structure-rtd))
  406.   (set! structure/name (record-accessor structure-rtd 'NAME))
  407.   (set! structure/conc-name (record-accessor structure-rtd 'CONC-NAME))
  408.   (set! structure/keyword-constructors
  409.     (record-accessor structure-rtd 'KEYWORD-CONSTRUCTORS))
  410.   (set! structure/boa-constructors
  411.     (record-accessor structure-rtd 'BOA-CONSTRUCTORS))
  412.   (set! structure/copier-name (record-accessor structure-rtd 'COPIER-NAME))
  413.   (set! structure/predicate-name
  414.     (record-accessor structure-rtd 'PREDICATE-NAME))
  415.   (set! structure/print-procedure
  416.     (record-accessor structure-rtd 'PRINT-PROCEDURE))
  417.   (set! structure/type (record-accessor structure-rtd 'TYPE))
  418.   (set! structure/named? (record-accessor structure-rtd 'NAMED?))
  419.   (set! structure/type-name (record-accessor structure-rtd 'TYPE-NAME))
  420.   (set! structure/tag-expression
  421.     (record-accessor structure-rtd 'TAG-EXPRESSION))
  422.   (set! structure/safe-accessors?
  423.     (record-accessor structure-rtd 'SAFE-ACCESSORS?))
  424.   (set! structure/offset (record-accessor structure-rtd 'OFFSET))
  425.   (set! structure/slots (record-accessor structure-rtd 'SLOTS))
  426.   (set! slot-rtd
  427.     (make-record-type "slot" '(NAME DEFAULT TYPE READ-ONLY? INDEX)))
  428.   (set! make-slot
  429.     (record-constructor slot-rtd '(NAME DEFAULT TYPE READ-ONLY?)))
  430.   (set! slot/name (record-accessor slot-rtd 'NAME))
  431.   (set! slot/default (record-accessor slot-rtd 'DEFAULT))
  432.   (set! slot/type (record-accessor slot-rtd 'TYPE))
  433.   (set! slot/read-only? (record-accessor slot-rtd 'READ-ONLY?))
  434.   (set! slot/index (record-accessor slot-rtd 'INDEX))
  435.   (set! set-slot/index! (record-modifier slot-rtd 'INDEX))
  436.   (set! slot-assoc (association-procedure eq? slot/name))
  437.   (initialize-structure-type-type!))
  438.  
  439. ;;;; Code Generation
  440.  
  441. (define (absolute name)
  442.   `(ACCESS ,name #F))
  443.  
  444. (define (accessor-definitions structure)
  445.   (map (lambda (slot)
  446.      (let* ((name (slot/name slot))
  447.         (accessor-name
  448.          (if (structure/conc-name structure)
  449.              (symbol-append (structure/conc-name structure) name)
  450.              name)))
  451.        (if (structure/safe-accessors? structure)
  452.            `(DEFINE ,accessor-name
  453.           (,(absolute
  454.              (case (structure/type structure)
  455.                ((RECORD) 'RECORD-ACCESSOR)
  456.                ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-ACCESSOR)
  457.                ((LIST) 'DEFINE-STRUCTURE/LIST-ACCESSOR)))
  458.            ,(or (structure/tag-expression structure)
  459.             (slot/index slot))
  460.            ',name))
  461.            `(DEFINE-INTEGRABLE (,accessor-name STRUCTURE)
  462.           (,(absolute
  463.              (case (structure/type structure)
  464.                ((RECORD) '%RECORD-REF)
  465.                ((VECTOR) 'VECTOR-REF)
  466.                ((LIST) 'LIST-REF)))
  467.            STRUCTURE
  468.            ,(slot/index slot))))))
  469.        (structure/slots structure)))
  470.  
  471. (define (modifier-definitions structure)
  472.   (append-map!
  473.    (lambda (slot)
  474.      (if (slot/read-only? slot)
  475.      '()
  476.      (list
  477.       (let* ((name (slot/name slot))
  478.          (modifier-name
  479.           (if (structure/conc-name structure)
  480.               (symbol-append 'SET-
  481.                      (structure/conc-name structure)
  482.                      name
  483.                      '!)
  484.               (symbol-append 'SET- name '!))))
  485.         (if (structure/safe-accessors? structure)
  486.         `(DEFINE ,modifier-name
  487.            (,(absolute
  488.               (case (structure/type structure)
  489.             ((RECORD) 'RECORD-MODIFIER)
  490.             ((VECTOR) 'DEFINE-STRUCTURE/VECTOR-MODIFIER)
  491.             ((LIST) 'DEFINE-STRUCTURE/LIST-MODIFIER)))
  492.             ,(or (structure/tag-expression structure)
  493.              (slot/index slot))
  494.             ',name))
  495.         `(DEFINE-INTEGRABLE (,modifier-name STRUCTURE VALUE)
  496.            ,(case (structure/type structure)
  497.               ((RECORD)
  498.                `(,(absolute '%RECORD-SET!) STRUCTURE
  499.                            ,(slot/index slot)
  500.                            VALUE))
  501.               ((VECTOR)
  502.                `(,(absolute 'VECTOR-SET!) STRUCTURE
  503.                           ,(slot/index slot)
  504.                           VALUE))
  505.               ((LIST)
  506.                `(,(absolute 'SET-CAR!)
  507.              (,(absolute 'LIST-TAIL) STRUCTURE
  508.                          ,(slot/index slot))
  509.              VALUE)))))))))
  510.    (structure/slots structure)))
  511.  
  512. (define (constructor-definitions structure)
  513.   `(,@(map (lambda (boa-constructor)
  514.          (if (null? (cdr boa-constructor))
  515.          (constructor-definition/default structure
  516.                          (car boa-constructor))
  517.          (constructor-definition/boa structure
  518.                          (car boa-constructor)
  519.                          (cadr boa-constructor))))
  520.        (structure/boa-constructors structure))
  521.     ,@(map (lambda (keyword-constructor)
  522.          (constructor-definition/keyword structure
  523.                          (car keyword-constructor)))
  524.        (structure/keyword-constructors structure))))
  525.  
  526. (define (constructor-definition/default structure name)
  527.   (let ((slot-names
  528.      (map (lambda (slot)
  529.         (string->uninterned-symbol (symbol->string (slot/name slot))))
  530.           (structure/slots structure))))
  531.     (make-constructor structure name slot-names
  532.       (lambda (tag-expression)
  533.     `(,(absolute
  534.         (case (structure/type structure)
  535.           ((RECORD) '%RECORD)
  536.           ((VECTOR) 'VECTOR)
  537.           ((LIST) 'LIST)))
  538.       ,@(constructor-prefix-slots structure tag-expression)
  539.       ,@slot-names)))))
  540.  
  541. (define (constructor-definition/keyword structure name)
  542.   (let ((keyword-list (string->uninterned-symbol "keyword-list")))
  543.     (make-constructor structure name keyword-list
  544.       (lambda (tag-expression)
  545.     (let ((list-cons
  546.            `(,@(constructor-prefix-slots structure tag-expression)
  547.          (,(absolute 'DEFINE-STRUCTURE/KEYWORD-PARSER)
  548.           ,keyword-list
  549.           (,(absolute 'LIST)
  550.            ,@(map (lambda (slot)
  551.                 `(,(absolute 'CONS) ',(slot/name slot)
  552.                         ,(slot/default slot)))
  553.               (structure/slots structure)))))))
  554.       (case (structure/type structure)
  555.         ((RECORD)
  556.          `(,(absolute 'APPLY) ,(absolute '%RECORD) ,@list-cons))
  557.         ((VECTOR)
  558.          `(,(absolute 'APPLY) ,(absolute 'VECTOR) ,@list-cons))
  559.         ((LIST)
  560.          `(,(absolute 'CONS*) ,@list-cons))))))))
  561.  
  562. (define (define-structure/keyword-parser argument-list default-alist)
  563.   (if (null? argument-list)
  564.       (map cdr default-alist)
  565.       (let ((alist
  566.          (map (lambda (entry) (cons (car entry) (cdr entry)))
  567.           default-alist)))
  568.     (let loop ((arguments argument-list))
  569.       (if (not (null? arguments))
  570.           (begin
  571.         (if (null? (cdr arguments))
  572.             (error "Keyword list does not have even length:"
  573.                argument-list))
  574.         (set-cdr! (or (assq (car arguments) alist)
  575.                   (error "Unknown keyword:" (car arguments)))
  576.               (cadr arguments))
  577.         (loop (cddr arguments)))))
  578.     (map cdr alist))))
  579.  
  580. (define (constructor-definition/boa structure name lambda-list)
  581.   (make-constructor structure name lambda-list
  582.     (lambda (tag-expression)
  583.       `(,(absolute
  584.       (case (structure/type structure)
  585.         ((RECORD) '%RECORD)
  586.         ((VECTOR) 'VECTOR)
  587.         ((LIST) 'LIST)))
  588.     ,@(constructor-prefix-slots structure tag-expression)
  589.     ,@(parse-lambda-list lambda-list
  590.         (lambda (required optional rest)
  591.           (let ((name->slot
  592.              (lambda (name)
  593.                (or (slot-assoc name (structure/slots structure))
  594.                (error "Not a defined structure slot:" name)))))
  595.         (let ((required (map name->slot required))
  596.               (optional (map name->slot optional))
  597.               (rest (and rest (name->slot rest))))
  598.           (map (lambda (slot)
  599.              (cond ((or (memq slot required)
  600.                     (eq? slot rest))
  601.                 (slot/name slot))
  602.                    ((memq slot optional)
  603.                 `(IF (DEFAULT-OBJECT? ,(slot/name slot))
  604.                      ,(slot/default slot)
  605.                      ,(slot/name slot)))
  606.                    (else
  607.                 (slot/default slot))))
  608.                (structure/slots structure))))))))))
  609.  
  610. (define (make-constructor structure name arguments generate-body)
  611.   (let ((tag-expression (structure/tag-expression structure)))
  612.     (if (eq? (structure/type structure) 'RECORD)
  613.     (let ((tag (generate-uninterned-symbol 'TAG-)))
  614.       `(DEFINE ,name
  615.          (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
  616.            (NAMED-LAMBDA (,name ,@arguments)
  617.          ,(generate-body tag)))))
  618.     `(DEFINE (,name ,@arguments)
  619.        ,(generate-body tag-expression)))))
  620.  
  621. (define (constructor-prefix-slots structure tag-expression)
  622.   (let ((offsets (make-list (structure/offset structure) false)))
  623.     (if (structure/named? structure)
  624.     (cons tag-expression offsets)
  625.     offsets)))
  626.  
  627. (define (copier-definitions structure)
  628.   (let ((copier-name (structure/copier-name structure)))
  629.     (if copier-name
  630.     `((DEFINE ,copier-name
  631.         ,(absolute
  632.           (case (structure/type structure)
  633.         ((RECORD) 'RECORD-COPY)
  634.         ((VECTOR) 'VECTOR-COPY)
  635.         ((LIST) 'LIST-COPY)))))
  636.     '())))
  637.  
  638. (define (predicate-definitions structure)
  639.   (let ((predicate-name (structure/predicate-name structure)))
  640.     (if predicate-name
  641.     (let ((tag-expression (structure/tag-expression structure))
  642.           (variable (string->uninterned-symbol "object")))
  643.       (case (structure/type structure)
  644.         ((RECORD)
  645.          (let ((tag (generate-uninterned-symbol 'TAG-)))
  646.            `((DEFINE ,predicate-name
  647.            (LET ((,tag (RECORD-TYPE-DISPATCH-TAG ,tag-expression)))
  648.              (NAMED-LAMBDA (,predicate-name ,variable)
  649.                (AND (,(absolute '%RECORD?) ,variable)
  650.                 (,(absolute 'EQ?)
  651.                  (,(absolute '%RECORD-REF) ,variable 0)
  652.                  ,tag))))))))
  653.         ((VECTOR)
  654.          `((DEFINE (,predicate-name ,variable)
  655.          (AND (,(absolute 'VECTOR?) ,variable)
  656.               (,(absolute 'NOT)
  657.                (,(absolute 'ZERO?)
  658.             (,(absolute 'VECTOR-LENGTH) ,variable)))
  659.               (,(absolute 'EQ?) (,(absolute 'VECTOR-REF) ,variable 0)
  660.                     ,tag-expression)))))
  661.         ((LIST)
  662.          `((DEFINE (,predicate-name ,variable)
  663.          (AND (,(absolute 'PAIR?) ,variable)
  664.               (,(absolute 'EQ?) (,(absolute 'CAR) ,variable)
  665.                     ,tag-expression)))))))
  666.     '())))
  667.  
  668. (define (type-definitions structure)
  669.   (if (structure/named? structure)
  670.       (let ((type (structure/type structure))
  671.         (type-name (structure/type-name structure))
  672.         (name (symbol->string (structure/name structure)))
  673.         (field-names (map slot/name (structure/slots structure))))
  674.     (if (eq? type 'RECORD)
  675.         `((DEFINE ,type-name
  676.         (,(absolute 'MAKE-RECORD-TYPE)
  677.          ',name ',field-names
  678.          ,@(let ((print-procedure
  679.               (structure/print-procedure structure)))
  680.              (if (not print-procedure)
  681.              `()
  682.              `(,print-procedure))))))
  683.         (let ((type-expression
  684.            `(,(absolute 'MAKE-DEFINE-STRUCTURE-TYPE)
  685.              ',type
  686.              ',name
  687.              ',field-names
  688.              ',(map slot/index (structure/slots structure))
  689.              ,(structure/print-procedure structure))))
  690.           (if type-name
  691.           `((DEFINE ,type-name ,type-expression))
  692.           `((DEFINE ,(string->uninterned-symbol name)
  693.               (NAMED-STRUCTURE/SET-TAG-DESCRIPTION!
  694.                ,(structure/tag-expression structure)
  695.                ,type-expression)))))))
  696.       '()))
  697.  
  698. ;;;; Exported type structure
  699.  
  700. (define structure-type-rtd)
  701. (define make-define-structure-type)
  702. (define structure-type?)
  703. (define structure-type/type)
  704. (define structure-type/name)
  705. (define structure-type/field-names)
  706. (define structure-type/field-indexes)
  707. (define structure-type/unparser-method)
  708. (define set-structure-type/unparser-method!)
  709.  
  710. (define (initialize-structure-type-type!)
  711.   (set! structure-type-rtd
  712.     (make-record-type "structure-type"
  713.               '(TYPE NAME FIELD-NAMES FIELD-INDEXES
  714.                  UNPARSER-METHOD)))
  715.   (set! make-define-structure-type
  716.     (record-constructor structure-type-rtd))
  717.   (set! structure-type?
  718.     (record-predicate structure-type-rtd))
  719.   (set! structure-type/type
  720.     (record-accessor structure-type-rtd 'TYPE))
  721.   (set! structure-type/name
  722.     (record-accessor structure-type-rtd 'NAME))
  723.   (set! structure-type/field-names
  724.     (record-accessor structure-type-rtd 'FIELD-NAMES))
  725.   (set! structure-type/field-indexes
  726.     (record-accessor structure-type-rtd 'FIELD-INDEXES))
  727.   (set! structure-type/unparser-method
  728.     (record-accessor structure-type-rtd 'UNPARSER-METHOD))
  729.   (set! set-structure-type/unparser-method!
  730.     (record-modifier structure-type-rtd 'UNPARSER-METHOD))
  731.   unspecific)
  732.  
  733. (define (structure-tag/unparser-method tag type)
  734.   (let ((structure-type (tag->structure-type tag type)))
  735.     (and structure-type
  736.      (structure-type/unparser-method structure-type))))
  737.  
  738. (define (named-structure? object)
  739.   (cond ((record? object)
  740.      true)
  741.     ((vector? object)
  742.      (and (not (zero? (vector-length object)))
  743.           (tag->structure-type (vector-ref object 0) 'VECTOR)))
  744.     ((pair? object)
  745.      (tag->structure-type (car object) 'LIST))
  746.     (else
  747.      false)))
  748.  
  749. (define (named-structure/description structure)
  750.   (cond ((record? structure)
  751.      (record-description structure))
  752.     ((named-structure? structure)
  753.      =>
  754.      (lambda (type)
  755.        (let ((accessor (if (pair? structure) list-ref vector-ref)))
  756.          (map (lambda (field-name index)
  757.             `(,field-name ,(accessor structure index)))
  758.           (structure-type/field-names type)
  759.           (structure-type/field-indexes type)))))
  760.     (else
  761.      (error:wrong-type-argument structure "named structure"
  762.                     'NAMED-STRUCTURE/DESCRIPTION))))
  763.  
  764. (define (tag->structure-type tag type)
  765.   (if (structure-type? tag)
  766.       (and (eq? (structure-type/type tag) type)
  767.        tag)
  768.       (let ((structure-type (named-structure/get-tag-description tag)))
  769.     (and (structure-type? structure-type)
  770.          (eq? (structure-type/type structure-type) type)
  771.          structure-type))))
  772.  
  773. ;;;; Support for safe accessors
  774.  
  775. (define (define-structure/vector-accessor tag field-name)
  776.   (call-with-values
  777.       (lambda () (accessor-parameters tag field-name 'VECTOR 'ACCESSOR))
  778.     (lambda (tag index type-name accessor-name)
  779.       (if tag
  780.       (lambda (structure)
  781.         (check-vector structure tag index type-name accessor-name)
  782.         (vector-ref structure index))
  783.       (lambda (structure)
  784.         (check-vector-untagged structure index type-name accessor-name)
  785.         (vector-ref structure index))))))
  786.  
  787. (define (define-structure/vector-modifier tag field-name)
  788.   (call-with-values
  789.       (lambda () (accessor-parameters tag field-name 'VECTOR 'MODIFIER))
  790.     (lambda (tag index type-name accessor-name)
  791.       (if tag
  792.       (lambda (structure value)
  793.         (check-vector structure tag index type-name accessor-name)
  794.         (vector-set! structure index value))
  795.       (lambda (structure value)
  796.         (check-vector-untagged structure index type-name accessor-name)
  797.         (vector-set! structure index value))))))
  798.  
  799. (define (define-structure/list-accessor tag field-name)
  800.   (call-with-values
  801.       (lambda () (accessor-parameters tag field-name 'LIST 'ACCESSOR))
  802.     (lambda (tag index type-name accessor-name)
  803.       (if tag
  804.       (lambda (structure)
  805.         (check-list structure tag index type-name accessor-name)
  806.         (list-ref structure index))
  807.       (lambda (structure)
  808.         (check-list-untagged structure index type-name accessor-name)
  809.         (list-ref structure index))))))
  810.  
  811. (define (define-structure/list-modifier tag field-name)
  812.   (call-with-values
  813.       (lambda () (accessor-parameters tag field-name 'LIST 'MODIFIER))
  814.     (lambda (tag index type-name accessor-name)
  815.       (if tag
  816.       (lambda (structure value)
  817.         (check-list structure tag index type-name accessor-name)
  818.         (set-car! (list-tail structure index) value))
  819.       (lambda (structure value)
  820.         (check-list-untagged structure index type-name accessor-name)
  821.         (set-car! (list-tail structure index) value))))))
  822.  
  823. (define-integrable (check-vector structure tag index type accessor-name)
  824.   (if (not (and (vector? structure)
  825.         (fix:> (vector-length structure) index)
  826.         (eq? tag (vector-ref structure 0))))
  827.       (error:wrong-type-argument structure type accessor-name)))
  828.  
  829. (define-integrable (check-vector-untagged structure index type accessor-name)
  830.   (if (not (and (vector? structure)
  831.         (fix:> (vector-length structure) index)))
  832.       (error:wrong-type-argument structure type accessor-name)))
  833.  
  834. (define-integrable (check-list structure tag index type accessor-name)
  835.   (if (not (and (list-to-index? structure index)
  836.         (eq? tag (car structure))))
  837.       (error:wrong-type-argument structure type accessor-name)))
  838.  
  839. (define-integrable (check-list-untagged structure index type accessor-name)
  840.   (if (not (list-to-index? structure index))
  841.       (error:wrong-type-argument structure type accessor-name)))
  842.  
  843. (define (list-to-index? object index)
  844.   (and (pair? object)
  845.        (or (fix:= 0 index)
  846.        (list-to-index? (cdr object) (fix:- index 1)))))
  847.  
  848. (define (accessor-parameters tag field-name structure-type accessor-type)
  849.   (if (exact-nonnegative-integer? tag)
  850.       (values #f
  851.           tag
  852.           (string-append (symbol->string structure-type)
  853.                  " of length >= "
  854.                  (number->string (+ tag 1)))
  855.           `(,accessor-type ,tag ',field-name))
  856.       (let ((type (tag->structure-type tag structure-type)))
  857.     (if (not type)
  858.         (error:wrong-type-argument tag "structure tag" accessor-type))
  859.     (values tag
  860.         (structure-type/field-index type field-name)
  861.         (structure-type/name type)
  862.         `(,accessor-type ,type ',field-name)))))
  863.  
  864. (define (structure-type/field-index type name)
  865.   (let loop
  866.       ((names (structure-type/field-names type))
  867.        (indexes (structure-type/field-indexes type)))
  868.     (if (pair? names)
  869.     (if (eq? name (car names))
  870.         (car indexes)
  871.         (loop (cdr names) (cdr indexes)))
  872.     (error:bad-range-argument name 'STRUCTURE-TYPE/FIELD-INDEX))))