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