diff --git a/cyclone.scm b/cyclone.scm index c255b29b..114162eb 100644 --- a/cyclone.scm +++ b/cyclone.scm @@ -15,6 +15,7 @@ (chicken (require-extension extras) ;; pretty-print (require-extension chicken-syntax) ;; when + (require-extension srfi-1) ;; every (load (string-append (cyc:get-lib-dir) "parser.so")) (load (string-append (cyc:get-lib-dir) "libraries.so")) (load (string-append (cyc:get-lib-dir) "trans.so")) diff --git a/scheme/base.sld b/scheme/base.sld index 0b295692..c2bf7b52 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -50,6 +50,7 @@ vector->list vector->string string->vector + make-parameter error raise raise-continuable @@ -264,6 +265,20 @@ fill))) (list->string (apply make-list (cons k fill*))))) + (define (make-parameter init . o) + (let* ((converter + (if (pair? o) (car o) (lambda (x) x))) + (value (converter init))) + (lambda args + (cond + ((null? args) + value) + ((eq? (car args) ') + (set! value (cadr args))) + ((eq? (car args) ') + converter) + (else + (error "bad parameter syntax")))))) (define (error msg . args) (raise (cons msg args))) (define (raise obj) diff --git a/trans.scm b/trans.scm index a5996fd1..bb6fc8af 100644 --- a/trans.scm +++ b/trans.scm @@ -31,6 +31,21 @@ (rename 'tmp) (cons (rename 'or) (cddr expr)))))))) (cons 'let (lambda (exp rename compare) (let=>lambda exp))) + (cons 'let* + (lambda (expr rename compare) + (if (null? (cdr expr)) (error "empty let*" expr)) + (if (null? (cddr expr)) (error "no let* body" expr)) + (if (null? (cadr expr)) + `(,(rename 'let) () ,@(cddr expr)) + (if (if (list? (cadr expr)) + (every + (lambda (x) + (if (pair? x) (if (pair? (cdr x)) (null? (cddr x)) #f) #f)) + (cadr expr)) + #f) + `(,(rename 'let) (,(caar (cdr expr))) + (,(rename 'let*) ,(cdar (cdr expr)) ,@(cddr expr))) + (error "bad let* syntax"))))) (cons 'begin (lambda (exp rename compare) (begin=>let exp))) (cons 'letrec (lambda (exp rename compare) (letrec=>lets+sets exp))) (cons 'cond