snow-record.stk 3.34 KB
Newer Older
Erick Gallesio's avatar
.  
Erick Gallesio committed
1 2 3
;;;;
;;;; snow-record.stk	-- Snow record support
;;;; 
Erick Gallesio's avatar
Erick Gallesio committed
4
;;;; Copyright  2006-2007 Erick Gallesio - I3S-CNRS/ESSI <[email protected]>
Erick Gallesio's avatar
.  
Erick Gallesio committed
5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
;;;; 
;;;; 
;;;; This program 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 2 of the License, or
;;;; (at your option) any later version.
;;;; 
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 
;;;; USA.
;;;; 
;;;;           Author: Erick Gallesio [[email protected]]
;;;;    Creation date: 21-Dec-2006 12:00 (eg)
Erick Gallesio's avatar
Erick Gallesio committed
24
;;;; Last file update: 17-Jan-2007 10:59 (eg)
Erick Gallesio's avatar
.  
Erick Gallesio committed
25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113
;;;;


(define (%define-record->struct name parent slots exported?)
  (let ((pred    (string->symbol (format "~a?" name)))
	(constr  (string->symbol (format "make-~a" name)))
	(arg     (gensym))
	(val     (gensym)))
    `(begin
       ;; Build the structure
       (define ,name (make-struct-type ',name ,parent ',(map car slots)))

       ;; Build the constructor
       (define (,constr . ,arg)
	 (apply make-struct ,name ,arg))

       ;; Build the predicate
       (define (,pred ,arg)
	 (and (struct? ,arg) (struct-is-a? ,arg ,name)))

       ;; Build the slot readers
       ,@(map (lambda (x)
		`(define ,(cadr x)
		   (lambda (,arg)
		     (%fast-struct-ref ,arg ,name ',(cadr x) ,(cadddr x)))))
	      slots)
       ;; Build the slot setters
       ,@(map (lambda (x)
		`(define ,(caddr x)
		   (lambda (,arg ,val)
		     (%fast-struct-set! ,arg ,name ',(caddr x) ,(cadddr x) ,val))))
	      slots)
       ,(if exported?
	    `(export ,name ,constr ,pred
		     ,@(map cadr slots)
		     ,@(map caddr slots))
	    '(void))

       ;; Build the toplevel result
       (values (void) ',name))))


(define (%define-record* name body exported?)
  (let Loop ((body body)
	     (parent #f)
	     (fields '())
	     (offset 0))
    (cond
      ((null? body)
       (%define-record->struct name parent (reverse! fields) exported?))

      ((not (pair? body))
       (error "bad record ~S" body))

      ((keyword? (car body))
       (cond
	 ((null? (cdr body))
	     (error "value expected after keyword ~S" (car body)))
	 ((eq? (car body) parent:)
	     (Loop (cddr body) (cadr body) fields offset))
	 (else ;; ignore this keyword for STklos
	     (Loop (cddr body) parent fields offset))))

      (else
         (match-case (car body)
	   ((? symbol?)
	      (let ((fld (car body)))
		(Loop (cdr body)
		      parent
		      (cons (list fld
				  (string->symbol (format "~a-~a" name fld))
				  (string->symbol (format "~a-~a-set!" name fld))
				  offset)
			    fields)
		      (+ offset 1))))
	   (((? symbol?) (? symbol?) (? symbol?))
	      (let ((fld    (caar body))
		    (getter (cadar body))
		    (setter (cadar body)))
		(Loop (cdr body)
		      parent
		      (cons (list fld getter setter offset) fields)
		      (+ offset 1))))
	   (else
	      (error "bad record field ~S" (car body))))))))

(define-macro (define-record* name . body)
  (%define-record* name body #f))