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

96
piclib/picrin/record.scm
View File

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