97 lines
2.6 KiB
Plaintext
97 lines
2.6 KiB
Plaintext
;;;;
|
|
;;;; srfi-9.stk -- SRFI-9 (Records)
|
|
;;;;
|
|
;;;; Copyright © 1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 27-Sep-1999 13:06 (eg)
|
|
;;;; Last file update: 27-Sep-1999 14:21 (eg)
|
|
;;;;
|
|
|
|
(require "stklos")
|
|
(select-module Scheme)
|
|
(import STklos)
|
|
|
|
;;;
|
|
;;; Class <record>
|
|
;;;
|
|
;;; This class is only used for printing records as #[record ...]
|
|
;;;
|
|
|
|
(define-class <record> () ())
|
|
|
|
(define-method write-object ((x <record>) port)
|
|
(format #t "#[record ~A ~A]" (class-name (class-of x)) (address-of x)))
|
|
|
|
|
|
;;;
|
|
;;; Implementation of DEFINE-RECORD-TYPE
|
|
;;;
|
|
|
|
(define-macro (define-record-type type-name constructor predicate . fields)
|
|
|
|
(define (%make-record-fields fields)
|
|
(map (lambda (x)
|
|
(case (length x)
|
|
((2) (list (car x) :getter (cadr x)))
|
|
((3) (list (car x) :getter (cadr x) :setter (caddr x)))
|
|
(else (error "define-record-type: bad field specification ~S" x))))
|
|
fields))
|
|
|
|
(define (%make-record-constructor constructor class)
|
|
(if (not (every symbol? constructor))
|
|
(error "define-record-type: bad constructor ~S" constructor))
|
|
|
|
(let ((name (car constructor))
|
|
(fields (cdr constructor)))
|
|
`(lambda ,fields
|
|
(let ((res (make ,class)))
|
|
,@(map (lambda (x) `(slot-set! res ',x ,x)) fields)
|
|
res))))
|
|
|
|
;;;
|
|
;;; Body of define-record-type starts here
|
|
;;;
|
|
(let ((symb(gensym "x")))
|
|
`(begin
|
|
;; Define a class for the new record
|
|
(define-class ,type-name (<record>)
|
|
,(%make-record-fields fields))
|
|
;; Define the accessor function
|
|
(define ,(car constructor)
|
|
,(%make-record-constructor constructor type-name))
|
|
;; Define the predicate as a pair of methods
|
|
(define-method ,predicate ((,symb ,type-name)) #t)
|
|
(define-method ,predicate (,symb) #f))))
|
|
|
|
(provide "srfi-9")
|
|
|
|
#|
|
|
Example of usage
|
|
|
|
(define-record-type my-pair
|
|
(kons x y)
|
|
my-pair?
|
|
(x kar set-kar!)
|
|
(y kdr))
|
|
|
|
(list
|
|
(my-pair? (kons 1 2)) ; => #t
|
|
(my-pair? (cons 1 2)) ; => #f
|
|
(kar (kons 1 2)) ; => 1
|
|
(kdr (kons 1 2)) ; => 2
|
|
(let ((k (kons 1 2)))
|
|
(set-kar! k 3)
|
|
(kar k))) ; => 3
|
|
|#
|