add oop submodule
This commit is contained in:
28
d-/oop.scm
Normal file
28
d-/oop.scm
Normal file
@@ -0,0 +1,28 @@
|
||||
(define-module (d- oop)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-9 gnu)
|
||||
#:export (define-record))
|
||||
|
||||
|
||||
;; Super quick record definition
|
||||
(define-syntax define-record
|
||||
(lambda (ctx)
|
||||
(define (syntax-append id . syns)
|
||||
(datum->syntax id (apply symbol-append (map syntax->datum syns))))
|
||||
(syntax-case ctx ()
|
||||
[(_ name field ...)
|
||||
(with-syntax ([rec-name (syntax-append #'name #'< #'name #'>)]
|
||||
[ctor (syntax-append #'name #'make- #'name)]
|
||||
[pred (syntax-append #'name #'name #'?)]
|
||||
[(proc ...) (map (lambda (f) (syntax-append f #'name #'- f))
|
||||
#'(field ...))]
|
||||
[(getter ...) (map (lambda (f) (syntax-append f #'name #'- f #'-ref))
|
||||
#'(field ...))]
|
||||
[(setter ...) (map (lambda (f) (syntax-append f #'name #'- f #'-set!))
|
||||
#'(field ...))])
|
||||
#'(begin
|
||||
(define-record-type rec-name
|
||||
(ctor field ...)
|
||||
pred
|
||||
(field getter setter) ...)
|
||||
(define proc (make-procedure-with-setter getter setter)) ...))])))
|
||||
Reference in New Issue
Block a user