mes: Reimplement records.
* module/srfi/srfi-9.mes (define-record-type): New macro. * AUTHORS: Update. * module/mes/record-0.mes: Remove. * module/mes/record.mes: Remove. * module/srfi/srfi-9-psyntax.mes: Remove. * module/srfi/srfi-9.scm: Remove. * make.scm: Remove them.
This commit is contained in:
Jan Nieuwenhuizen
parent
eb0505300c
commit
0f042b6ea6
5
AUTHORS
5
AUTHORS
|
|
@ -2,11 +2,6 @@ Jan Nieuwenhuizen <janneke@gnu.org>
|
|||
Main author
|
||||
All files except the files listed below
|
||||
|
||||
Based on Scheme48's scheme/alt
|
||||
module/mes/record.mes
|
||||
module/mes/syntax.scm
|
||||
module/srfi/srfi-9.scm
|
||||
|
||||
Based on Guile ECMAScript
|
||||
module/language/c/lexer.mes
|
||||
|
||||
|
|
|
|||
4
make.scm
4
make.scm
|
|
@ -565,8 +565,6 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
|
|||
"module/mes/quasisyntax.mes"
|
||||
"module/mes/quasisyntax.scm"
|
||||
"module/mes/read-0.mes"
|
||||
"module/mes/record-0.mes"
|
||||
"module/mes/record.mes"
|
||||
"module/mes/repl.mes"
|
||||
"module/mes/scm.mes"
|
||||
"module/mes/syntax.mes"
|
||||
|
|
@ -594,9 +592,7 @@ exec ${GUILE-guile} --no-auto-compile -L . -L guile -C . -C guile -s "$0" ${1+"$
|
|||
"module/srfi/srfi-26.mes"
|
||||
"module/srfi/srfi-26.scm"
|
||||
"module/srfi/srfi-43.mes"
|
||||
"module/srfi/srfi-9-psyntax.mes"
|
||||
"module/srfi/srfi-9.mes"
|
||||
"module/srfi/srfi-9.scm"
|
||||
"module/sxml/xpath.mes"
|
||||
"module/sxml/xpath.scm"))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,38 +0,0 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of Mes.
|
||||
;;;
|
||||
;;; Mes is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; Mes is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; record-0.mes mes-specific definitions needed for record.mes
|
||||
|
||||
;;; Code:
|
||||
|
||||
(define (unspecific) (if #f #f))
|
||||
(define make-record make-vector)
|
||||
(define record-set! vector-set!)
|
||||
(define record? vector?)
|
||||
(define (record-type x) (vector-ref x 0))
|
||||
(define record-ref vector-ref)
|
||||
(define (call-error message . rest)
|
||||
(display "call-error:" (current-error-port))
|
||||
(display message (current-error-port))
|
||||
(display ":" (current-error-port))
|
||||
(display rest (current-error-port))
|
||||
(newline (current-error-port)))
|
||||
|
|
@ -1,258 +0,0 @@
|
|||
;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of Mes.
|
||||
;;;
|
||||
;;; Mes is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; Mes is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; record.mes is loaded after record-0.mes. It provides a
|
||||
;;; nonstandard record type that SRFI-9 can be trivially implemented
|
||||
;;; on. Adapted from scheme48-1.1/scheme/rts/record.scm
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
;;; scheme48-1.1/COPYING
|
||||
|
||||
;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
|
||||
;; All rights reserved.
|
||||
|
||||
;; Redistribution and use in source and binary forms, with or without
|
||||
;; modification, are permitted provided that the following conditions
|
||||
;; are met:
|
||||
;; 1. Redistributions of source code must retain the above copyright
|
||||
;; notice, this list of conditions and the following disclaimer.
|
||||
;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;; notice, this list of conditions and the following disclaimer in the
|
||||
;; documentation and/or other materials provided with the distribution.
|
||||
;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;; derived from this software without specific prior written permission.
|
||||
|
||||
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
;;;; Records
|
||||
|
||||
; Every record in the image is assumed to be made either by MAKE-RECORD-TYPE
|
||||
; or by a procedure returned by record-constructor. A record-type is a
|
||||
; record that describes a type of record. At the end of the file we create
|
||||
; a record type that describes record types.
|
||||
|
||||
; We number the record types for debugging purposes.
|
||||
|
||||
(define *record-type-uid* -1)
|
||||
|
||||
; This is the record type that describes record types. It is set a the end
|
||||
; of the file. Its first slot points to itself.
|
||||
|
||||
(define *record-type* #f)
|
||||
|
||||
; Make a record type from a name, used for printing and debugging, and
|
||||
; a list of field names.
|
||||
;
|
||||
; The VM references both the record type and the resumer, so their offsets
|
||||
; should not be changed.
|
||||
|
||||
(define (make-record-type name field-names)
|
||||
(set! *record-type-uid* (+ *record-type-uid* 1))
|
||||
(let ((r (make-record 7 (unspecific))))
|
||||
(record-set! r 0 *record-type*)
|
||||
(record-set! r 1 default-record-resumer)
|
||||
(record-set! r 2 *record-type-uid*)
|
||||
(record-set! r 3 name)
|
||||
(record-set! r 4 field-names)
|
||||
(record-set! r 5 (length field-names))
|
||||
(record-set! r 6 (make-default-record-discloser name))
|
||||
r))
|
||||
|
||||
(define (record-type? obj)
|
||||
(and (record? obj)
|
||||
(eq? (record-type obj) *record-type*)))
|
||||
|
||||
; The various fields in a record type.
|
||||
|
||||
(define (record-type-resumer rt) (record-ref rt 1))
|
||||
(define (set-record-type-resumer! rt r) (record-set! rt 1 r))
|
||||
(define (record-type-uid rt) (record-ref rt 2))
|
||||
(define (record-type-name rt) (record-ref rt 3))
|
||||
(define (record-type-field-names rt) (record-ref rt 4))
|
||||
(define (record-type-number-of-fields rt) (record-ref rt 5))
|
||||
(define (record-type-discloser rt) (record-ref rt 6))
|
||||
(define (set-record-type-discloser! rt d) (record-set! rt 6 d))
|
||||
|
||||
; This is a hack; it is read by the script that makes c/scheme48.h.
|
||||
|
||||
(define record-type-fields
|
||||
'(resumer uid name field-names number-of-fields discloser))
|
||||
|
||||
;----------------
|
||||
; Given a record type and the name of a field, return the field's index.
|
||||
|
||||
(define (record-field-index rt name)
|
||||
(let loop ((names (record-type-field-names rt))
|
||||
(i 1))
|
||||
(cond ((null? names)
|
||||
(error "unknown field"
|
||||
(record-type-name rt)
|
||||
name))
|
||||
((eq? name (car names))
|
||||
i)
|
||||
(else
|
||||
(loop (cdr names) (+ i 1))))))
|
||||
|
||||
; Return procedure for contstruction records of type RT. NAMES is a list of
|
||||
; field names which the constructor will take as arguments. Other fields are
|
||||
; uninitialized.
|
||||
|
||||
(define (record-constructor rt names)
|
||||
(let ((indexes (map (lambda (name)
|
||||
(record-field-index rt name))
|
||||
names))
|
||||
(size (+ 1 (record-type-number-of-fields rt))))
|
||||
(lambda args
|
||||
(let ((r (make-record size (unspecific))))
|
||||
(record-set! r 0 rt)
|
||||
(let loop ((is indexes) (as args))
|
||||
(if (null? as)
|
||||
(if (null? is)
|
||||
r
|
||||
(error "too few arguments to record constructor"
|
||||
rt names args))
|
||||
(if (null? is)
|
||||
(error "too many arguments to record constructor"
|
||||
rt names args)
|
||||
(begin (record-set! r (car is) (car as))
|
||||
(loop (cdr is) (cdr as))))))))))
|
||||
|
||||
; Making accessors, modifiers, and predicates for record types.
|
||||
|
||||
(define (record-accessor rt name)
|
||||
(let ((index (record-field-index rt name))
|
||||
(error-cruft `(record-accessor ,rt ',name)))
|
||||
(lambda (r)
|
||||
(if (eq? (record-type r) rt)
|
||||
(record-ref r index)
|
||||
(call-error "invalid record access" error-cruft r)))))
|
||||
|
||||
(define (record-modifier rt name)
|
||||
(let ((index (record-field-index rt name))
|
||||
(error-cruft `(record-modifier ,rt ',name)))
|
||||
(lambda (r x)
|
||||
(if (eq? (record-type r) rt)
|
||||
(record-set! r index x)
|
||||
(call-error "invalid record modification" error-cruft r x)))))
|
||||
|
||||
(define (record-predicate rt)
|
||||
(lambda (x)
|
||||
(and (record? x)
|
||||
(eq? (record-type x) rt))))
|
||||
|
||||
;----------------
|
||||
; A discloser is a procedure that takes a record of a particular type and
|
||||
; returns a list whose head is a string or symbol and whose tail is other
|
||||
; stuff.
|
||||
;
|
||||
; Set the discloser for record type RT.
|
||||
|
||||
(define (define-record-discloser rt proc)
|
||||
(if (and (record-type? rt)
|
||||
(procedure? proc))
|
||||
(set-record-type-discloser! rt proc)
|
||||
(call-error "invalid argument" define-record-discloser rt proc)))
|
||||
|
||||
; By default we just return the name of the record type.
|
||||
|
||||
(define (make-default-record-discloser record-type-name)
|
||||
(lambda (r)
|
||||
(list record-type-name)))
|
||||
|
||||
; DISCLOSE-RECORD calls the record's discloser procedure to obtain a list.
|
||||
|
||||
(define (disclose-record r)
|
||||
(if (record? r)
|
||||
(let ((rt (record-type r)))
|
||||
(if (record-type? rt)
|
||||
((record-type-discloser rt) r)
|
||||
#f))
|
||||
#f))
|
||||
|
||||
;----------------
|
||||
; A resumer is a procedure that the VM calls on all records of a given
|
||||
; type on startup.
|
||||
;
|
||||
; A resumer may be:
|
||||
; #t -> do nothing on startup.
|
||||
; #f -> records of this type do not survive a dump/resume; in images they
|
||||
; are replaced by their first slot (so we make sure they have one)
|
||||
; a one-argument procedure -> pass the record to this procedure
|
||||
;
|
||||
; Resumers are primarily intended for use by external code which keeps
|
||||
; fields in records which do not survive a dump under their own power.
|
||||
; For example, a record may contain a reference to a OS-dependent value.
|
||||
;
|
||||
; Resumers are called by the VM on startup.
|
||||
|
||||
(define (define-record-resumer rt resumer)
|
||||
(if (and (record-type? rt)
|
||||
(or (eq? #t resumer)
|
||||
(and (eq? #f resumer)
|
||||
(< 0 (record-type-number-of-fields rt)))
|
||||
(procedure? resumer)))
|
||||
(set-record-type-resumer! rt resumer)
|
||||
(call-error "invalid argument" define-record-resumer rt resumer)))
|
||||
|
||||
; By default we leave records alone.
|
||||
|
||||
(define default-record-resumer
|
||||
#t)
|
||||
|
||||
(define (initialize-records! resumer-records)
|
||||
(if (vector? resumer-records)
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length resumer-records)))
|
||||
(resume-record (vector-ref resumer-records i)))))
|
||||
|
||||
(define (resume-record record)
|
||||
((record-type-resumer (record-type record))
|
||||
record))
|
||||
|
||||
;----------------
|
||||
; Initializing *RECORD-TYPE* and making a type.
|
||||
|
||||
(set! *record-type*
|
||||
(make-record-type 'record-type record-type-fields))
|
||||
|
||||
(record-set! *record-type* 0 *record-type*)
|
||||
|
||||
(define :record-type *record-type*)
|
||||
|
||||
(define-record-discloser :record-type
|
||||
(lambda (rt)
|
||||
(list 'record-type
|
||||
(record-type-uid rt)
|
||||
(record-type-name rt))))
|
||||
|
|
@ -1,29 +0,0 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of Mes.
|
||||
;;;
|
||||
;;; Mes is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; Mes is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; srfi-9.mes - records.
|
||||
|
||||
(mes-use-module (mes scm))
|
||||
(mes-use-module (mes psyntax))
|
||||
(mes-use-module (mes record-0))
|
||||
(mes-use-module (mes record))
|
||||
(include-from-path "srfi/srfi-9.scm")
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of Mes.
|
||||
;;;
|
||||
|
|
@ -22,8 +22,116 @@
|
|||
|
||||
;;; srfi-9.mes - records.
|
||||
|
||||
(mes-use-module (mes scm))
|
||||
(mes-use-module (mes syntax))
|
||||
(mes-use-module (mes record-0))
|
||||
(mes-use-module (mes record))
|
||||
(include-from-path "srfi/srfi-9.scm")
|
||||
(define (lst-index lst o)
|
||||
(let loop ((lst lst) (i 0))
|
||||
(and (pair? lst)
|
||||
(if (equal? o (car lst)) i
|
||||
(loop (cdr lst) (1+ i))))))
|
||||
|
||||
(define (make-record-type type fields)
|
||||
(list->vector (list '*record-type* type fields (length fields))))
|
||||
|
||||
(define (record-type o)
|
||||
(vector-ref o 0))
|
||||
|
||||
(define (record-type? o)
|
||||
(eq? (record-type o) '*record-type*))
|
||||
|
||||
(define (record-constructor type params)
|
||||
(let ((fields (record-fields type)))
|
||||
(lambda (. o)
|
||||
(if (not (= (length o) (length params))) (error "wrong number of arguments for record-constructor")
|
||||
(let ((rest (make-list (- (length fields) (length params)))))
|
||||
(list->vector (cons type (append o rest))))))))
|
||||
|
||||
(define (record-fields o)
|
||||
(vector-ref o 2))
|
||||
|
||||
(define (record-field-index type field)
|
||||
(1+ (or (lst-index (record-fields type) field)
|
||||
(error "no such field" type field))))
|
||||
|
||||
(define (record-getter type field)
|
||||
(let ((i (record-field-index type field)))
|
||||
(lambda (o)
|
||||
(if (not (eq? (record-type o) type)) (error "record getter: record expected" type o)
|
||||
(vector-ref o i)))))
|
||||
|
||||
(define (record-setter type field)
|
||||
(let ((i (record-field-index type field)))
|
||||
(lambda (o v)
|
||||
(if (not (eq? (record-type o) type)) (error "record setter: record expected" type o)
|
||||
(vector-set! o i v)))))
|
||||
|
||||
(define (record-predicate type)
|
||||
(lambda (o)
|
||||
(and (vector? o)
|
||||
(eq? (record-type o) type))))
|
||||
|
||||
(define-macro (define-record-accessors type . fields)
|
||||
`(begin
|
||||
,@(map (lambda (field)
|
||||
`(define-record-accessor ,type ,field))
|
||||
fields)))
|
||||
|
||||
(define-macro (define-record-accessor type field)
|
||||
`(begin
|
||||
(define ,(cadr field) ,(record-getter type (car field)))
|
||||
(if ,(pair? (cddr field))
|
||||
(define ,(if (pair? (cddr field)) (caddr field)) ,(record-setter type (car field))))))
|
||||
|
||||
(define-macro (define-record-type type constructor+params predicate . fields)
|
||||
(let ((record (make-record-type type (map car fields))))
|
||||
`(begin
|
||||
(define ,type ,record)
|
||||
(define ,(car constructor+params) ,(record-constructor record (cdr constructor+params)))
|
||||
(define ,predicate ,(record-predicate record))
|
||||
(define-record-accessors ,record ,@fields))))
|
||||
|
||||
;; (define-record-type cpi
|
||||
;; (make-cpi-1)
|
||||
;; cpi?
|
||||
;; (debug cpi-debug set-cpi-debug!) ; debug #t #f
|
||||
;; (defines cpi-defs set-cpi-defs!) ; #defines
|
||||
;; (incdirs cpi-incs set-cpi-incs!) ; #includes
|
||||
;; (inc-tynd cpi-itynd set-cpi-itynd!) ; a-l of incfile => typenames
|
||||
;; (inc-defd cpi-idefd set-cpi-idefd!) ; a-l of incfile => defines
|
||||
;; (ptl cpi-ptl set-cpi-ptl!) ; parent typename list
|
||||
;; (ctl cpi-ctl set-cpi-ctl!) ; current typename list
|
||||
;; (blev cpi-blev set-cpi-blev!) ; curr brace/block level
|
||||
;; )
|
||||
|
||||
;; (display cpi)
|
||||
;; (newline)
|
||||
;; (display make-cpi-1)
|
||||
;; (newline)
|
||||
;; (define cpi (make-cpi-1))
|
||||
;; (set-cpi-debug! cpi #t)
|
||||
;; (set-cpi-blev! cpi #t)
|
||||
|
||||
|
||||
;; (define-record-type <employee> (make-employee name age salary) employee? (name employe-name) (age employee-age set-employee-age!) (salary employee-salary))
|
||||
|
||||
;; (display <employee>)
|
||||
;; (newline)
|
||||
;; (display make-employee)
|
||||
;; (newline)
|
||||
;; (display "employee-age ")
|
||||
;; (display employee-age)
|
||||
;; (newline)
|
||||
|
||||
;; (display "set-employee-age! ")
|
||||
;; (display set-employee-age!)
|
||||
;; (newline)
|
||||
|
||||
;; (define janneke (make-employee "janneke" 49 42))
|
||||
;; (display janneke)
|
||||
;; (newline)
|
||||
|
||||
;; (display (employee-age janneke))
|
||||
;; (newline)
|
||||
|
||||
;; (display (set-employee-age! janneke 33))
|
||||
;; (newline)
|
||||
;; (display (employee-age janneke))
|
||||
;; (newline)
|
||||
|
|
|
|||
|
|
@ -1,100 +0,0 @@
|
|||
;;; -*-scheme-*-
|
||||
|
||||
;;; Mes --- Maxwell Equations of Software
|
||||
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
|
||||
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of Mes.
|
||||
;;;
|
||||
;;; Mes is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; Mes is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with Mes. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;;; srfi-9.mes - records. Assumes record-0.mes and record.mes are
|
||||
;;; available. Modified from
|
||||
;;; scheme48-1.1/scheme/alt/jar-defrecord.scm to implement SRFI-9.
|
||||
|
||||
;;; Code:
|
||||
|
||||
;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
|
||||
|
||||
;;; scheme48-1.1/COPYING
|
||||
|
||||
;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
|
||||
;; All rights reserved.
|
||||
|
||||
;; Redistribution and use in source and binary forms, with or without
|
||||
;; modification, are permitted provided that the following conditions
|
||||
;; are met:
|
||||
;; 1. Redistributions of source code must retain the above copyright
|
||||
;; notice, this list of conditions and the following disclaimer.
|
||||
;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;; notice, this list of conditions and the following disclaimer in the
|
||||
;; documentation and/or other materials provided with the distribution.
|
||||
;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;; derived from this software without specific prior written permission.
|
||||
|
||||
;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
; This is JAR's define-record-type, which doesn't resemble Richard's.
|
||||
|
||||
; There's no implicit name concatenation, so it can be defined
|
||||
; entirely using syntax-rules. Example:
|
||||
; (define-record-type foo :foo
|
||||
; (make-foo x y)
|
||||
; foo? - predicate name is optional
|
||||
; (x foo-x)
|
||||
; (y foo-y)
|
||||
; (z foo-z set-foo-z!))
|
||||
|
||||
(define-syntax define-record-type
|
||||
(syntax-rules ()
|
||||
((define-record-type type
|
||||
(constructor arg ...)
|
||||
(field . field-stuff)
|
||||
...)
|
||||
(begin (define type (make-record-type 'type '(field ...)))
|
||||
(define constructor (record-constructor type '(arg ...)))
|
||||
(define-accessors type (field . field-stuff) ...)))
|
||||
((define-record-type type
|
||||
(constructor arg ...)
|
||||
pred
|
||||
more ...)
|
||||
(begin (define-record-type type
|
||||
(constructor arg ...)
|
||||
more ...)
|
||||
(define pred (record-predicate type))))))
|
||||
|
||||
;; Straightforward version
|
||||
(define-syntax define-accessors
|
||||
(syntax-rules ()
|
||||
((define-accessors type field-spec ...)
|
||||
(begin (define-accessor type . field-spec) ...))))
|
||||
|
||||
(define-syntax define-accessor
|
||||
(syntax-rules ()
|
||||
((define-accessor type field accessor)
|
||||
(define accessor (record-accessor type 'field)))
|
||||
((define-accessor type field accessor modifier)
|
||||
(begin (define accessor (record-accessor type 'field))
|
||||
(define modifier (record-modifier type 'field))))))
|
||||
Loading…
Reference in New Issue