diff --git a/contrib/10.macro/macro.scm b/contrib/10.macro/macro.scm index d116a04a..164803eb 100644 --- a/contrib/10.macro/macro.scm +++ b/contrib/10.macro/macro.scm @@ -44,11 +44,11 @@ ((wrap (let ((register (make-register))) (lambda (var) (let ((id (register var))) - (if (undefined? id) + (if id + (cdr id) (let ((id (make-identifier var env))) (register var id) - id) - id))))) + id)))))) (walk (lambda (f form) (cond ((variable? form) @@ -106,11 +106,11 @@ ((rename (let ((register (make-register))) (lambda (var) (let ((id (register var))) - (if (undefined? id) + (if id + (cdr id) (let ((id (make-identifier var mac-env))) (register var id) - id) - id))))) + id)))))) (compare (lambda (x y) (variable=? (make-identifier x use-env) @@ -124,25 +124,25 @@ (letrec ((inject (lambda (var1) (let ((var2 (register1 var1))) - (if (undefined? var2) + (if var2 + (cdr var2) (let ((var2 (make-identifier var1 use-env))) (register1 var1 var2) (register2 var2 var1) - var2) - var2)))) + var2))))) (rename (let ((register (make-register))) (lambda (var) (let ((id (register var))) - (if (undefined? id) + (if id + (cdr id) (let ((id (make-identifier var mac-env))) (register var id) - id) - id))))) + id)))))) (flip (lambda (var2) ; unwrap if injected, wrap if not injected (let ((var1 (register2 var2))) - (if (undefined? var1) - (rename var2) - var1)))) + (if var1 + (cdr var1) + (rename var2))))) (walk (lambda (f form) (cond ((variable? form) diff --git a/contrib/20.r7rs/scheme/base.scm b/contrib/20.r7rs/scheme/base.scm index e2e70a80..fe476435 100644 --- a/contrib/20.r7rs/scheme/base.scm +++ b/contrib/20.r7rs/scheme/base.scm @@ -350,11 +350,12 @@ (letrec ((#,'rename (let ((reg (make-register))) (lambda (x) - (if (undefined? (reg x)) - (let ((id (make-identifier x env))) - (reg x id) - id) - (reg x)))))) + (let ((y (reg x))) + (if y + (cdr y) + (let ((id (make-identifier x env))) + (reg x id) + id))))))) (lambda #,'it #,(compile-rules rules)))))) diff --git a/extlib/benz/boot.c b/extlib/benz/boot.c index 7a681cba..9802f811 100644 --- a/extlib/benz/boot.c +++ b/extlib/benz/boot.c @@ -489,17 +489,17 @@ my $src = <<'EOL'; (letrec ((wrap (lambda (var1) (let ((var2 (register1 var1))) - (if (undefined? var2) + (if var2 + (cdr var2) (let ((var2 (make-identifier var1 env))) (register1 var1 var2) (register2 var2 var1) - var2) - var2)))) + var2))))) (unwrap (lambda (var2) (let ((var1 (register2 var2))) - (if (undefined? var1) - var2 - var1)))) + (if var1 + (cdr var1) + var2)))) (walk (lambda (f form) (cond ((variable? form) @@ -923,85 +923,85 @@ const char pic_boot[][80] = { "ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form", " env)\n (let ((register1 (make-register))\n (register2 (make-register)", "))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ", -"(register1 var1)))\n (if (undefined? var2)\n ", -" (let ((var2 (make-identifier var1 env)))\n (regi", -"ster1 var1 var2)\n (register2 var2 var1)\n ", -" var2)\n var2))))\n (unwrap (lambda ", -"(var2)\n (let ((var1 (register2 var2)))\n ", -" (if (undefined? var1)\n var2\n ", -" var1))))\n (walk (lambda (f form)\n (cond\n ", -" ((variable? form)\n (f form))\n ", -"((pair? form)\n (cons (walk f (car form)) (walk f (cdr form))", -"))\n ((vector? form)\n (list->vector (walk ", -"f (vector->list form))))\n (else\n form))))", -")\n (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap fo", -"rm))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (let ((formal (", -"car (cdr form)))\n (body (cdr (cdr form))))\n (if (pair? formal)\n ", -" `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body", -"))\n `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body", -")))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car", -" (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ,@(ma", -"p (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n ", -" formal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (fo", -"rm env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(d", -"efine-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ", -" (body (cddr form)))\n (let ((old-library (current-library))\n ", -" (new-library (or (find-library name) (make-library name))))\n (let ((env ", -"(library-environment new-library)))\n (current-library new-library)\n ", -" (for-each (lambda (expr) (eval expr env)) body)\n (current-library", -" old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ", -" ((test (lambda (form)\n (or\n (eq? form 'els", -"e)\n (and (symbol? form)\n (memq form (feat", -"ures)))\n (and (pair? form)\n (case (car fo", -"rm)\n ((library) (find-library (cadr form)))\n ", -" ((not) (not (test (cadr form))))\n ((and) (l", -"et loop ((form (cdr form)))\n (or (null? form)\n ", -" (and (test (car form)) (loop (cdr form)))))", -")\n ((or) (let loop ((form (cdr form)))\n ", -" (and (pair? form)\n (or (tes", -"t (car form)) (loop (cdr form))))))\n (else #f)))))))\n ", -" (let loop ((clauses (cdr form)))\n (if (null? clauses)\n #und", -"efined\n (if (test (caar clauses))\n `(,the-begin ,@(cda", -"r clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import\n (", -"lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n ", -" (prefix\n (lambda (prefix symbol)\n (string->symbol\n", -" (string-append\n (symbol->string prefix)\n ", -" (symbol->string symbol))))))\n (letrec\n ((extract\n (l", -"ambda (spec)\n (case (car spec)\n ((only rename prefix", -" except)\n (extract (cadr spec)))\n (else\n ", -" (or (find-library spec) (error \"library not found\" spec))))))\n ", -" (collect\n (lambda (spec)\n (case (car spec)\n ", -" ((only)\n (let ((alist (collect (cadr spec))))\n ", -" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((renam", -"e)\n (let ((alist (collect (cadr spec)))\n (", -"renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ", -" (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ((pre", -"fix)\n (let ((alist (collect (cadr spec))))\n (m", -"ap (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ", -" ((except)\n (let ((alist (collect (cadr spec))))\n ", -" (let loop ((alist alist))\n (if (null? alist)\n ", -" '()\n (if (memq (caar alist) (cddr spe", -"c))\n (loop (cdr alist))\n ", -" (cons (car alist) (loop (cdr alist))))))))\n (else\n ", -" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ", -" (map (lambda (x) (cons x x)) (library-exports lib))))))))\n (", -"letrec\n ((import\n (lambda (spec)\n (let ", -"((lib (extract spec))\n (alist (collect spec)))\n ", -" (for-each\n (lambda (slot)\n (libr", -"ary-import lib (cdr slot) (car slot)))\n alist)))))\n ", -"(for-each import (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (", -"letrec\n ((collect\n (lambda (spec)\n (cond\n ", -" ((symbol? spec)\n `(,spec . ,spec))\n ((and (list? spec)", -" (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1", -") . ,(list-ref spec 2)))\n (else\n (error \"malformed expo", -"rt\")))))\n (export\n (lambda (spec)\n (let ((slot (co", -"llect spec)))\n (library-export (car slot) (cdr slot))))))\n (f", -"or-each export (cdr form)))))\n\n(export define lambda quote set! if begin define-", -"macro\n let let* letrec letrec*\n let-values let*-values define-valu", -"es\n quasiquote unquote unquote-splicing\n and or\n cond case ", -"else =>\n do when unless\n parameterize\n define-syntax\n ", -" syntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n", -" let-syntax letrec-syntax\n syntax-error)\n\n\n", +"(register1 var1)))\n (if var2\n (cdr v", +"ar2)\n (let ((var2 (make-identifier var1 env)))\n ", +" (register1 var1 var2)\n (register2 va", +"r2 var1)\n var2)))))\n (unwrap (lambda (var2)\n", +" (let ((var1 (register2 var2)))\n (if v", +"ar1\n (cdr var1)\n var2))))\n ", +" (walk (lambda (f form)\n (cond\n ((v", +"ariable? form)\n (f form))\n ((pair? form)\n", +" (cons (walk f (car form)) (walk f (cdr form))))\n ", +" ((vector? form)\n (list->vector (walk f (vector->lis", +"t form))))\n (else\n form)))))\n (let", +" ((form (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(d", +"efine-macro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)", +"))\n (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(t", +"he 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `", +"(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(defi", +"ne-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n", +" (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n", +" `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n f", +"ormal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(", +",(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro de", +"fine-library\n (lambda (form _)\n (let ((name (cadr form))\n (body (cd", +"dr form)))\n (let ((old-library (current-library))\n (new-library ", +"(or (find-library name) (make-library name))))\n (let ((env (library-envir", +"onment new-library)))\n (current-library new-library)\n (for-eac", +"h (lambda (expr) (eval expr env)) body)\n (current-library old-library))", +"))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (l", +"ambda (form)\n (or\n (eq? form 'else)\n ", +" (and (symbol? form)\n (memq form (features)))\n ", +" (and (pair? form)\n (case (car form)\n ", +" ((library) (find-library (cadr form)))\n (", +"(not) (not (test (cadr form))))\n ((and) (let loop ((form", +" (cdr form)))\n (or (null? form)\n ", +" (and (test (car form)) (loop (cdr form))))))\n ", +" ((or) (let loop ((form (cdr form)))\n ", +" (and (pair? form)\n (or (test (car form)) ", +"(loop (cdr form))))))\n (else #f)))))))\n (let loop (", +"(clauses (cdr form)))\n (if (null? clauses)\n #undefined\n ", +" (if (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ", +" (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _", +")\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefi", +"x\n (lambda (prefix symbol)\n (string->symbol\n ", +"(string-append\n (symbol->string prefix)\n (symbol->st", +"ring symbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ", +" (case (car spec)\n ((only rename prefix except)\n ", +" (extract (cadr spec)))\n (else\n (or (f", +"ind-library spec) (error \"library not found\" spec))))))\n (collect\n ", +" (lambda (spec)\n (case (car spec)\n ((only)\n ", +" (let ((alist (collect (cadr spec))))\n (map (lam", +"bda (var) (assq var alist)) (cddr spec))))\n ((rename)\n ", +" (let ((alist (collect (cadr spec)))\n (renames (map (", +"lambda (x) `((car x) . (cadr x))) (cddr spec))))\n (map (lambda", +" (s) (or (assq (car s) renames) s)) alist)))\n ((prefix)\n ", +" (let ((alist (collect (cadr spec))))\n (map (lambda (s)", +" (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ((except", +")\n (let ((alist (collect (cadr spec))))\n (let ", +"loop ((alist alist))\n (if (null? alist)\n ", +" '()\n (if (memq (caar alist) (cddr spec))\n ", +" (loop (cdr alist))\n (cons (car al", +"ist) (loop (cdr alist))))))))\n (else\n (let ((lib ", +"(or (find-library spec) (error \"library not found\" spec))))\n (", +"map (lambda (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ", +" ((import\n (lambda (spec)\n (let ((lib (extract", +" spec))\n (alist (collect spec)))\n (for-e", +"ach\n (lambda (slot)\n (library-import lib", +" (cdr slot) (car slot)))\n alist)))))\n (for-each impo", +"rt (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ", +" ((collect\n (lambda (spec)\n (cond\n ((symbol? spe", +"c)\n `(,spec . ,spec))\n ((and (list? spec) (= (length sp", +"ec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref", +" spec 2)))\n (else\n (error \"malformed export\")))))\n ", +" (export\n (lambda (spec)\n (let ((slot (collect spec)))\n", +" (library-export (car slot) (cdr slot))))))\n (for-each export", +" (cdr form)))))\n\n(export define lambda quote set! if begin define-macro\n ", +"let let* letrec letrec*\n let-values let*-values define-values\n qua", +"siquote unquote unquote-splicing\n and or\n cond case else =>\n ", +" do when unless\n parameterize\n define-syntax\n syntax-quote", +" syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n let-sy", +"ntax letrec-syntax\n syntax-error)\n\n\n", "", "" }; diff --git a/extlib/benz/reg.c b/extlib/benz/reg.c index d72aceaf..655f3b08 100644 --- a/extlib/benz/reg.c +++ b/extlib/benz/reg.c @@ -66,9 +66,9 @@ static pic_value reg_get(pic_state *pic, struct pic_reg *reg, void *key) { if (! pic_reg_has(pic, reg, key)) { - return pic_undef_value(); + return pic_false_value(); } - return pic_reg_ref(pic, reg, key); + return pic_cons(pic, pic_obj_value(key), pic_reg_ref(pic, reg, key)); } static pic_value