CasperSecurity
;;; srfi-9.scm --- define-record-type
;; Copyright (C) 2001-2002, 2006, 2008-2014, 2018-2019
;; Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;; This module exports the syntactic form `define-record-type', which
;; is the means for creating record types defined in SRFI-9.
;;
;; The syntax of a record type definition is:
;;
;; <record type definition>
;; -> (define-record-type <type name>
;; (<constructor name> <field tag> ...)
;; <predicate name>
;; <field spec> ...)
;;
;; <field spec> -> (<field tag> <getter name>)
;; -> (<field tag> <getter name> <setter name>)
;;
;; <field tag> -> <identifier>
;; <... name> -> <identifier>
;;
;; Usage example:
;;
;; guile> (use-modules (srfi srfi-9))
;; guile> (define-record-type :foo (make-foo x) foo?
;; (x get-x) (y get-y set-y!))
;; guile> (define f (make-foo 1))
;; guile> f
;; #<:foo x: 1 y: #f>
;; guile> (get-x f)
;; 1
;; guile> (set-y! f 2)
;; 2
;; guile> (get-y f)
;; 2
;; guile> f
;; #<:foo x: 1 y: 2>
;; guile> (foo? f)
;; #t
;; guile> (foo? 1)
;; #f
;;; Code:
(define-module (srfi srfi-9)
#:use-module (srfi srfi-1)
#:use-module (system base ck)
#:export (define-record-type))
(cond-expand-provide (current-module) '(srfi-9))
;; Roll our own instead of using the public `define-inlinable'. This is
;; because the public one has a different `make-procedure-name', so
;; using it would require users to recompile code that uses SRFI-9. See
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
;;
(define-syntax-rule (define-inlinable (name formals ...) body ...)
(define-tagged-inlinable () (name formals ...) body ...))
;; 'define-tagged-inlinable' has an additional feature: it stores a map
;; of keys to values that can be retrieved at expansion time. This is
;; currently used to retrieve the rtd id, field index, and record copier
;; macro for an arbitrary getter.
(define-syntax-rule (%%on-error err) err)
(define %%type #f) ; a private syntax literal
(define-syntax getter-type
(syntax-rules (quote)
((_ s 'getter 'err)
(getter (%%on-error err) %%type s))))
(define %%index #f) ; a private syntax literal
(define-syntax getter-index
(syntax-rules (quote)
((_ s 'getter 'err)
(getter (%%on-error err) %%index s))))
(define %%copier #f) ; a private syntax literal
(define-syntax getter-copier
(syntax-rules (quote)
((_ s 'getter 'err)
(getter (%%on-error err) %%copier s))))
(define-syntax define-tagged-inlinable
(lambda (x)
(define (make-procedure-name name)
(datum->syntax name
(symbol-append '% (syntax->datum name)
'-procedure)))
(syntax-case x ()
((_ ((key value) ...) (name formals ...) body ...)
(identifier? #'name)
(with-syntax ((proc-name (make-procedure-name #'name))
((args ...) (generate-temporaries #'(formals ...))))
#`(begin
(define (proc-name formals ...)
body ...)
(define-syntax name
(lambda (x)
(syntax-case x (%%on-error key ...)
((_ (%%on-error err) key s) #'(ck s 'value)) ...
((_ args ...)
#'((lambda (formals ...)
body ...)
args ...))
((_ a (... ...))
(syntax-violation 'name "Wrong number of arguments" x))
(_
(identifier? x)
#'proc-name))))))))))
(define (default-record-printer s p)
(display "#<" p)
(display (record-type-name (record-type-descriptor s)) p)
(let loop ((fields (record-type-fields (record-type-descriptor s)))
(off 0))
(cond
((not (null? fields))
(display " " p)
(display (car fields) p)
(display ": " p)
(write (struct-ref s off) p)
(loop (cdr fields) (+ 1 off)))))
(display ">" p))
(define-syntax-rule (throw-bad-struct s who)
(let ((s* s))
(throw 'wrong-type-arg who
"Wrong type argument: ~S" (list s*)
(list s*))))
(define (make-copier-id type-name)
(datum->syntax type-name
(symbol-append '%% (syntax->datum type-name)
'-set-fields)))
(define-syntax %%set-fields
(lambda (x)
(syntax-case x ()
((_ type-name (getter-id ...) check? s (getter expr) ...)
(every identifier? #'(getter ...))
(let ((copier-name (syntax->datum (make-copier-id #'type-name)))
(getter+exprs #'((getter expr) ...))
(nfields (length #'(getter-id ...))))
(define (lookup id default-expr)
(let ((results
(filter (lambda (g+e)
(free-identifier=? id (car g+e)))
getter+exprs)))
(case (length results)
((0) default-expr)
((1) (cadar results))
(else (syntax-violation
copier-name "duplicate getter" x id)))))
(for-each (lambda (id)
(or (find (lambda (getter-id)
(free-identifier=? id getter-id))
#'(getter-id ...))
(syntax-violation
copier-name "unknown getter" x id)))
#'(getter ...))
(with-syntax ((unsafe-expr
#`(make-struct/simple
type-name
#,@(map (lambda (getter index)
(lookup getter #`(struct-ref s #,index)))
#'(getter-id ...)
(iota nfields)))))
(if (syntax->datum #'check?)
#`(if (eq? (struct-vtable s) type-name)
unsafe-expr
(throw-bad-struct
s '#,(datum->syntax #'here copier-name)))
#'unsafe-expr)))))))
(define-syntax %define-record-type
(lambda (x)
(define (field-identifiers field-specs)
(map (lambda (field-spec)
(syntax-case field-spec ()
((name getter) #'name)
((name getter setter) #'name)))
field-specs))
(define (getter-identifiers field-specs)
(map (lambda (field-spec)
(syntax-case field-spec ()
((name getter) #'getter)
((name getter setter) #'getter)))
field-specs))
(define (constructor form type-name constructor-spec field-ids)
(syntax-case constructor-spec ()
((ctor field ...)
(every identifier? #'(field ...))
(letrec* ((id-list-contains?
(lambda (id-list id)
(and (not (null? id-list))
(or (free-identifier=? (car id-list) id)
(id-list-contains? (cdr id-list) id)))))
(inits (map (lambda (id)
(and (id-list-contains? #'(field ...) id) id))
field-ids)))
(for-each
(lambda (field)
(unless (id-list-contains? field-ids field)
(syntax-violation
(syntax-case form () ((macro . args) (syntax->datum #'macro)))
"unknown field in constructor spec"
form field)))
#'(field ...))
#`(define-inlinable #,constructor-spec
(make-struct/simple #,type-name #,@inits))))))
(define (getters type-name getter-ids copier-id)
(map (lambda (getter index)
#`(define-tagged-inlinable
((%%type #,type-name)
(%%index #,index)
(%%copier #,copier-id))
(#,getter s)
(if (eq? (struct-vtable s) #,type-name)
(struct-ref s #,index)
(throw-bad-struct s '#,getter))))
getter-ids
(iota (length getter-ids))))
(define (copier type-name getter-ids copier-id)
#`(define-syntax-rule
(#,copier-id check? s (getter expr) (... ...))
(%%set-fields #,type-name #,getter-ids
check? s (getter expr) (... ...))))
(define (setters type-name field-specs)
(filter-map (lambda (field-spec index)
(syntax-case field-spec ()
((name getter) #f)
((name getter setter)
#`(define-inlinable (setter s val)
(if (eq? (struct-vtable s) #,type-name)
(struct-set! s #,index val)
(throw-bad-struct s 'setter))))))
field-specs
(iota (length field-specs))))
(define (functional-setters copier-id field-specs)
(filter-map (lambda (field-spec index)
(syntax-case field-spec ()
((name getter) #f)
((name getter setter)
#`(define-inlinable (setter s val)
(#,copier-id #t s (getter val))))))
field-specs
(iota (length field-specs))))
(define (record-layout immutable? count)
;; Mutability is expressed on the record level; all structs in the
;; future will be mutable.
(string-concatenate (make-list count "pw")))
(syntax-case x ()
((_ immutable? form type-name constructor-spec predicate-name
field-spec ...)
(let ()
(define (syntax-error message subform)
(syntax-violation (syntax-case #'form ()
((macro . args) (syntax->datum #'macro)))
message #'form subform))
(and (boolean? (syntax->datum #'immutable?))
(or (identifier? #'type-name)
(syntax-error "expected type name" #'type-name))
(syntax-case #'constructor-spec ()
((ctor args ...)
(every identifier? #'(ctor args ...))
#t)
(_ (syntax-error "invalid constructor spec"
#'constructor-spec)))
(or (identifier? #'predicate-name)
(syntax-error "expected predicate name" #'predicate-name))
(every (lambda (spec)
(syntax-case spec ()
((field getter) #t)
((field getter setter) #t)
(_ (syntax-error "invalid field spec" spec))))
#'(field-spec ...))))
(let* ((field-ids (field-identifiers #'(field-spec ...)))
(getter-ids (getter-identifiers #'(field-spec ...)))
(field-count (length field-ids))
(immutable? (syntax->datum #'immutable?))
(layout (record-layout immutable? field-count))
(ctor-name (syntax-case #'constructor-spec ()
((ctor args ...) #'ctor)))
(copier-id (make-copier-id #'type-name)))
#`(begin
#,(constructor #'form #'type-name #'constructor-spec field-ids)
(define type-name
(let ((rtd (make-record-type 'type-name
'#,field-ids
default-record-printer)))
;; Allow record-type-constructor to return our
;; constructor.
(struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
rtd))
(define-inlinable (predicate-name obj)
(and (struct? obj)
(eq? (struct-vtable obj) type-name)))
#,@(getters #'type-name getter-ids copier-id)
#,(copier #'type-name getter-ids copier-id)
#,@(if immutable?
(functional-setters copier-id #'(field-spec ...))
(setters #'type-name #'(field-spec ...))))))
((_ immutable? form . rest)
(syntax-violation
(syntax-case #'form ()
((macro . args) (syntax->datum #'macro)))
"invalid record definition syntax"
#'form)))))
(define-syntax-rule (define-record-type name ctor pred fields ...)
(%define-record-type #f (define-record-type name ctor pred fields ...)
name ctor pred fields ...))
;;; srfi-9.scm ends here