conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

rewrite (picrin record) and (picrin experimental lambda)

This commit is contained in:
Yuichi Nishiwaki 2015-06-15 02:37:36 +09:00
parent 4d9f5bfbcf
commit d741efe294
2 changed files with 66 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
piclib/picrin/experimental/lambda.scm
View File

@ -3,47 +3,36 @@
(picrin base)
(picrin macro))
(define-syntax destructuring-bind
(ir-macro-transformer
(lambda (form inject compare)
(let ((formal (car (cdr form)))
(value (car (cdr (cdr form))))
(body (cdr (cdr (cdr form)))))
(cond
((symbol? formal)
`(let ((,formal ,value))
,@body))
((pair? formal)
`(let ((value# ,value))
(destructuring-bind ,(car formal) (car value#)
(destructuring-bind ,(cdr formal) (cdr value#)
,@body))))
((vector? formal)
;; TODO
(error "fixme"))
(else
`(if (equal? ,value ',formal)
(begin
,@body)
(error "match failure" ,value ',formal))))))))
(define-syntax (destructuring-let formal value . body)
(cond
((variable? formal)
#`(let ((#,formal #,value))
#,@body))
((pair? formal)
#`(let ((value #,value))
(destructuring-let #,(car formal) (car value)
(destructuring-let #,(cdr formal) (cdr value)
#,@body))))
((vector? formal)
;; TODO
(error "fixme"))
(else
#`(if (equal? #,value '#,formal)
(begin
#,@body)
(error "match failure" #,value '#,formal)))))
(define-syntax destructuring-lambda
(ir-macro-transformer
(lambda (form inject compare)
(let ((args (car (cdr form)))
(body (cdr (cdr form))))
`(lambda formal# (destructuring-bind ,args formal# ,@body))))))
(define-syntax (destructuring-lambda formal . body)
#`(lambda args
(destructuring-let #,formal args #,@body)))
(define-syntax destructuring-define
(ir-macro-transformer
(lambda (form inject compare)
(let ((maybe-formal (cadr form)))
(if (symbol? maybe-formal)
`(define ,@(cdr form))
`(destructuring-define ,(car maybe-formal)
(destructuring-lambda ,(cdr maybe-formal)
,@(cddr form))))))))
(define-syntax (destructuring-define formal . body)
(if (variable? formal)
#`(define #,formal #,@body)
#`(destructuring-define #,(car formal)
(destructuring-lambda #,(cdr formal)
#,@body))))
(export (rename destructuring-bind bind)
(export (rename destructuring-let let)
(rename destructuring-lambda lambda)
(rename destructuring-define define)))

96
piclib/picrin/record.scm
View File

@ -2,7 +2,7 @@
(import (picrin base)
(picrin macro))
;; define-record-type
;; record meta type
(define ((boot-make-record-type <meta-type>) name)
(let ((rectype (make-record <meta-type>)))
@ -10,70 +10,50 @@
rectype))
(define <record-type>
(let ((<record-type>
((boot-make-record-type #t) 'record-type)))
(let ((<record-type> ((boot-make-record-type #t) 'record-type)))
(record-set! <record-type> '@@type <record-type>)
<record-type>))
(define make-record-type (boot-make-record-type <record-type>))
(define-syntax define-record-constructor
(ir-macro-transformer
(lambda (form inject compare?)
(let ((rectype (car (cdr form)))
(name (car (cdr (cdr form))))
(fields (cdr (cdr (cdr form)))))
`(define (,name ,@fields)
(let ((record (make-record ,rectype)))
,@(map (lambda (field)
`(record-set! record ',field ,field))
fields)
record))))))
;; define-record-type
(define-syntax define-record-predicate
(ir-macro-transformer
(lambda (form inject compare?)
(let ((rectype (car (cdr form)))
(name (car (cdr (cdr form)))))
`(define (,name obj)
(and (record? obj)
(eq? (record-type obj)
,rectype)))))))
(define-syntax (define-record-constructor type name . fields)
(let ((record #'record))
#`(define (#,name . #,fields)
(let ((#,record (make-record #,type)))
#,@(map (lambda (field) #`(record-set! #,record '#,field #,field)) fields)
#,record))))
(define-syntax define-record-field
(ir-macro-transformer
(lambda (form inject compare?)
(let ((pred (car (cdr form)))
(field-name (car (cdr (cdr form))))
(accessor (car (cdr (cdr (cdr form)))))
(modifier? (cdr (cdr (cdr (cdr form))))))
(if (null? modifier?)
`(define (,accessor record)
(if (,pred record)
(record-ref record ',field-name)
(error (string-append (symbol->string ',accessor) ": wrong record type") record)))
`(begin
(define (,accessor record)
(if (,pred record)
(record-ref record ',field-name)
(error (string-append (symbol->string ',accessor) ": wrong record type") record)))
(define (,(car modifier?) record val)
(if (,pred record)
(record-set! record ',field-name val)
(error (string-append (symbol->string ',(car modifier?)) ": wrong record type") record)))))))))
(define-syntax (define-record-predicate type name)
#`(define (#,name obj)
(and (record? obj)
(eq? (record-type obj) #,type))))
(define-syntax define-record-type
(ir-macro-transformer
(lambda (form inject compare?)
(let ((name (car (cdr form)))
(ctor (car (cdr (cdr form))))
(pred (car (cdr (cdr (cdr form)))))
(fields (cdr (cdr (cdr (cdr form))))))
`(begin
(define ,name (make-record-type ',name))
(define-record-constructor ,name ,@ctor)
(define-record-predicate ,name ,pred)
,@(map (lambda (field) `(define-record-field ,pred ,@field))
fields))))))
(define-syntax (define-record-accessor pred field accessor)
#`(define (#,accessor record)
(if (#,pred record)
(record-ref record '#,field)
(error (string-append (symbol->string '#,accessor) ": wrong record type") record))))
(define-syntax (define-record-modifier pred field modifier)
#`(define (#,modifier record val)
(if (#,pred record)
(record-set! record '#,field val)
(error (string-append (symbol->string '#,modifier) ": wrong record type") record))))
(define-syntax (define-record-field pred field accessor . modifier-opt)
(if (null? modifier-opt)
#`(define-record-accessor #,pred #,field #,accessor)
#`(begin
(define-record-accessor #,pred #,field #,accessor)
(define-record-modifier #,pred #,field #,(car modifier-opt)))))
(define-syntax (define-record-type name ctor pred . fields)
#`(begin
(define #,name (make-record-type '#,name))
(define-record-constructor #,name #,@ctor)
(define-record-predicate #,name #,pred)
#,@(map (lambda (field) #`(define-record-field #,pred #,@field)) fields)))
(export define-record-type))