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

register now returns #f or a pair

This commit is contained in:
Yuichi Nishiwaki 2015-07-18 15:28:53 +09:00
parent 238f5999bc
commit 3739387160
4 changed files with 108 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
contrib/10.macro/macro.scm
View File

@ -44,11 +44,11 @@
((wrap (let ((register (make-register))) ((wrap (let ((register (make-register)))
(lambda (var) (lambda (var)
(let ((id (register var))) (let ((id (register var)))
(if (undefined? id) (if id
(cdr id)
(let ((id (make-identifier var env))) (let ((id (make-identifier var env)))
(register var id) (register var id)
id) id))))))
id)))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((variable? form)
@ -106,11 +106,11 @@
((rename (let ((register (make-register))) ((rename (let ((register (make-register)))
(lambda (var) (lambda (var)
(let ((id (register var))) (let ((id (register var)))
(if (undefined? id) (if id
(cdr id)
(let ((id (make-identifier var mac-env))) (let ((id (make-identifier var mac-env)))
(register var id) (register var id)
id) id))))))
id)))))
(compare (lambda (x y) (compare (lambda (x y)
(variable=? (variable=?
(make-identifier x use-env) (make-identifier x use-env)
@ -124,25 +124,25 @@
(letrec (letrec
((inject (lambda (var1) ((inject (lambda (var1)
(let ((var2 (register1 var1))) (let ((var2 (register1 var1)))
(if (undefined? var2) (if var2
(cdr var2)
(let ((var2 (make-identifier var1 use-env))) (let ((var2 (make-identifier var1 use-env)))
(register1 var1 var2) (register1 var1 var2)
(register2 var2 var1) (register2 var2 var1)
var2) var2)))))
var2))))
(rename (let ((register (make-register))) (rename (let ((register (make-register)))
(lambda (var) (lambda (var)
(let ((id (register var))) (let ((id (register var)))
(if (undefined? id) (if id
(cdr id)
(let ((id (make-identifier var mac-env))) (let ((id (make-identifier var mac-env)))
(register var id) (register var id)
id) id))))))
id)))))
(flip (lambda (var2) ; unwrap if injected, wrap if not injected (flip (lambda (var2) ; unwrap if injected, wrap if not injected
(let ((var1 (register2 var2))) (let ((var1 (register2 var2)))
(if (undefined? var1) (if var1
(rename var2) (cdr var1)
var1)))) (rename var2)))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((variable? form)

7
contrib/20.r7rs/scheme/base.scm
View File

@ -350,11 +350,12 @@
(letrec (letrec
((#,'rename (let ((reg (make-register))) ((#,'rename (let ((reg (make-register)))
(lambda (x) (lambda (x)
(if (undefined? (reg x)) (let ((y (reg x)))
(if y
(cdr y)
(let ((id (make-identifier x env))) (let ((id (make-identifier x env)))
(reg x id) (reg x id)
id) id)))))))
(reg x))))))
(lambda #,'it (lambda #,'it
#,(compile-rules rules)))))) #,(compile-rules rules))))))

170
extlib/benz/boot.c
View File

@ -489,17 +489,17 @@ my $src = <<'EOL';
(letrec (letrec
((wrap (lambda (var1) ((wrap (lambda (var1)
(let ((var2 (register1 var1))) (let ((var2 (register1 var1)))
(if (undefined? var2) (if var2
(cdr var2)
(let ((var2 (make-identifier var1 env))) (let ((var2 (make-identifier var1 env)))
(register1 var1 var2) (register1 var1 var2)
(register2 var2 var1) (register2 var2 var1)
var2) var2)))))
var2))))
(unwrap (lambda (var2) (unwrap (lambda (var2)
(let ((var1 (register2 var2))) (let ((var1 (register2 var2)))
(if (undefined? var1) (if var1
var2 (cdr var1)
var1)))) var2))))
(walk (lambda (f form) (walk (lambda (f form)
(cond (cond
((variable? form) ((variable? form)
@ -923,85 +923,85 @@ const char pic_boot[][80] = {
"ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form", "ap cdr renames)\n ,body))))))\n\n(define (transformer f)\n (lambda (form",
" env)\n (let ((register1 (make-register))\n (register2 (make-register)", " env)\n (let ((register1 (make-register))\n (register2 (make-register)",
"))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ", "))\n (letrec\n ((wrap (lambda (var1)\n (let ((var2 ",
"(register1 var1)))\n (if (undefined? var2)\n ", "(register1 var1)))\n (if var2\n (cdr v",
" (let ((var2 (make-identifier var1 env)))\n (regi", "ar2)\n (let ((var2 (make-identifier var1 env)))\n ",
"ster1 var1 var2)\n (register2 var2 var1)\n ", " (register1 var1 var2)\n (register2 va",
" var2)\n var2))))\n (unwrap (lambda ", "r2 var1)\n var2)))))\n (unwrap (lambda (var2)\n",
"(var2)\n (let ((var1 (register2 var2)))\n ", " (let ((var1 (register2 var2)))\n (if v",
" (if (undefined? var1)\n var2\n ", "ar1\n (cdr var1)\n var2))))\n ",
" var1))))\n (walk (lambda (f form)\n (cond\n ", " (walk (lambda (f form)\n (cond\n ((v",
" ((variable? form)\n (f form))\n ", "ariable? form)\n (f form))\n ((pair? form)\n",
"((pair? form)\n (cons (walk f (car form)) (walk f (cdr form))", " (cons (walk f (car form)) (walk f (cdr form))))\n ",
"))\n ((vector? form)\n (list->vector (walk ", " ((vector? form)\n (list->vector (walk f (vector->lis",
"f (vector->list form))))\n (else\n form))))", "t form))))\n (else\n form)))))\n (let",
")\n (let ((form (cdr form)))\n (walk unwrap (apply f (walk wrap fo", " ((form (cdr form)))\n (walk unwrap (apply f (walk wrap form))))))))\n\n(d",
"rm))))))))\n\n(define-macro define-syntax\n (lambda (form env)\n (let ((formal (", "efine-macro define-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)",
"car (cdr form)))\n (body (cdr (cdr form))))\n (if (pair? formal)\n ", "))\n (body (cdr (cdr form))))\n (if (pair? formal)\n `(,(t",
" `(,(the 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body", "he 'define-syntax) ,(car formal) (,the-lambda ,(cdr formal) ,@body))\n `",
"))\n `(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body", "(,the-define-macro ,formal (,(the 'transformer) (,the-begin ,@body)))))))\n\n(defi",
")))))))\n\n(define-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car", "ne-macro letrec-syntax\n (lambda (form env)\n (let ((formal (car (cdr form)))\n",
" (cdr form)))\n (body (cdr (cdr form))))\n `(let ()\n ,@(ma", " (body (cdr (cdr form))))\n `(let ()\n ,@(map (lambda (x)\n",
"p (lambda (x)\n `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n ", " `(,(the 'define-syntax) ,(car x) ,(cadr x)))\n f",
" formal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (fo", "ormal)\n ,@body))))\n\n(define-macro let-syntax\n (lambda (form env)\n `(",
"rm env)\n `(,(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(d", ",(the 'letrec-syntax) ,@(cdr form))))\n\n\n;;; library primitives\n\n(define-macro de",
"efine-macro define-library\n (lambda (form _)\n (let ((name (cadr form))\n ", "fine-library\n (lambda (form _)\n (let ((name (cadr form))\n (body (cd",
" (body (cddr form)))\n (let ((old-library (current-library))\n ", "dr form)))\n (let ((old-library (current-library))\n (new-library ",
" (new-library (or (find-library name) (make-library name))))\n (let ((env ", "(or (find-library name) (make-library name))))\n (let ((env (library-envir",
"(library-environment new-library)))\n (current-library new-library)\n ", "onment new-library)))\n (current-library new-library)\n (for-eac",
" (for-each (lambda (expr) (eval expr env)) body)\n (current-library", "h (lambda (expr) (eval expr env)) body)\n (current-library old-library))",
" old-library))))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ", "))))\n\n(define-macro cond-expand\n (lambda (form _)\n (letrec\n ((test (l",
" ((test (lambda (form)\n (or\n (eq? form 'els", "ambda (form)\n (or\n (eq? form 'else)\n ",
"e)\n (and (symbol? form)\n (memq form (feat", " (and (symbol? form)\n (memq form (features)))\n ",
"ures)))\n (and (pair? form)\n (case (car fo", " (and (pair? form)\n (case (car form)\n ",
"rm)\n ((library) (find-library (cadr form)))\n ", " ((library) (find-library (cadr form)))\n (",
" ((not) (not (test (cadr form))))\n ((and) (l", "(not) (not (test (cadr form))))\n ((and) (let loop ((form",
"et loop ((form (cdr form)))\n (or (null? form)\n ", " (cdr form)))\n (or (null? form)\n ",
" (and (test (car form)) (loop (cdr form)))))", " (and (test (car form)) (loop (cdr form))))))\n ",
")\n ((or) (let loop ((form (cdr form)))\n ", " ((or) (let loop ((form (cdr form)))\n ",
" (and (pair? form)\n (or (tes", " (and (pair? form)\n (or (test (car form)) ",
"t (car form)) (loop (cdr form))))))\n (else #f)))))))\n ", "(loop (cdr form))))))\n (else #f)))))))\n (let loop (",
" (let loop ((clauses (cdr form)))\n (if (null? clauses)\n #und", "(clauses (cdr form)))\n (if (null? clauses)\n #undefined\n ",
"efined\n (if (test (caar clauses))\n `(,the-begin ,@(cda", " (if (test (caar clauses))\n `(,the-begin ,@(cdar clauses))\n ",
"r clauses))\n (loop (cdr clauses))))))))\n\n(define-macro import\n (", " (loop (cdr clauses))))))))\n\n(define-macro import\n (lambda (form _",
"lambda (form _)\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n ", ")\n (let ((caddr\n (lambda (x) (car (cdr (cdr x)))))\n (prefi",
" (prefix\n (lambda (prefix symbol)\n (string->symbol\n", "x\n (lambda (prefix symbol)\n (string->symbol\n ",
" (string-append\n (symbol->string prefix)\n ", "(string-append\n (symbol->string prefix)\n (symbol->st",
" (symbol->string symbol))))))\n (letrec\n ((extract\n (l", "ring symbol))))))\n (letrec\n ((extract\n (lambda (spec)\n ",
"ambda (spec)\n (case (car spec)\n ((only rename prefix", " (case (car spec)\n ((only rename prefix except)\n ",
" except)\n (extract (cadr spec)))\n (else\n ", " (extract (cadr spec)))\n (else\n (or (f",
" (or (find-library spec) (error \"library not found\" spec))))))\n ", "ind-library spec) (error \"library not found\" spec))))))\n (collect\n ",
" (collect\n (lambda (spec)\n (case (car spec)\n ", " (lambda (spec)\n (case (car spec)\n ((only)\n ",
" ((only)\n (let ((alist (collect (cadr spec))))\n ", " (let ((alist (collect (cadr spec))))\n (map (lam",
" (map (lambda (var) (assq var alist)) (cddr spec))))\n ((renam", "bda (var) (assq var alist)) (cddr spec))))\n ((rename)\n ",
"e)\n (let ((alist (collect (cadr spec)))\n (", " (let ((alist (collect (cadr spec)))\n (renames (map (",
"renames (map (lambda (x) `((car x) . (cadr x))) (cddr spec))))\n ", "lambda (x) `((car x) . (cadr x))) (cddr spec))))\n (map (lambda",
" (map (lambda (s) (or (assq (car s) renames) s)) alist)))\n ((pre", " (s) (or (assq (car s) renames) s)) alist)))\n ((prefix)\n ",
"fix)\n (let ((alist (collect (cadr spec))))\n (m", " (let ((alist (collect (cadr spec))))\n (map (lambda (s)",
"ap (lambda (s) (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ", " (cons (prefix (caddr spec) (car s)) (cdr s))) alist)))\n ((except",
" ((except)\n (let ((alist (collect (cadr spec))))\n ", ")\n (let ((alist (collect (cadr spec))))\n (let ",
" (let loop ((alist alist))\n (if (null? alist)\n ", "loop ((alist alist))\n (if (null? alist)\n ",
" '()\n (if (memq (caar alist) (cddr spe", " '()\n (if (memq (caar alist) (cddr spec))\n ",
"c))\n (loop (cdr alist))\n ", " (loop (cdr alist))\n (cons (car al",
" (cons (car alist) (loop (cdr alist))))))))\n (else\n ", "ist) (loop (cdr alist))))))))\n (else\n (let ((lib ",
" (let ((lib (or (find-library spec) (error \"library not found\" spec))))\n ", "(or (find-library spec) (error \"library not found\" spec))))\n (",
" (map (lambda (x) (cons x x)) (library-exports lib))))))))\n (", "map (lambda (x) (cons x x)) (library-exports lib))))))))\n (letrec\n ",
"letrec\n ((import\n (lambda (spec)\n (let ", " ((import\n (lambda (spec)\n (let ((lib (extract",
"((lib (extract spec))\n (alist (collect spec)))\n ", " spec))\n (alist (collect spec)))\n (for-e",
" (for-each\n (lambda (slot)\n (libr", "ach\n (lambda (slot)\n (library-import lib",
"ary-import lib (cdr slot) (car slot)))\n alist)))))\n ", " (cdr slot) (car slot)))\n alist)))))\n (for-each impo",
"(for-each import (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (", "rt (cdr form)))))))\n\n(define-macro export\n (lambda (form _)\n (letrec\n ",
"letrec\n ((collect\n (lambda (spec)\n (cond\n ", " ((collect\n (lambda (spec)\n (cond\n ((symbol? spe",
" ((symbol? spec)\n `(,spec . ,spec))\n ((and (list? spec)", "c)\n `(,spec . ,spec))\n ((and (list? spec) (= (length sp",
" (= (length spec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1", "ec) 3) (eq? (car spec) 'rename))\n `(,(list-ref spec 1) . ,(list-ref",
") . ,(list-ref spec 2)))\n (else\n (error \"malformed expo", " spec 2)))\n (else\n (error \"malformed export\")))))\n ",
"rt\")))))\n (export\n (lambda (spec)\n (let ((slot (co", " (export\n (lambda (spec)\n (let ((slot (collect spec)))\n",
"llect spec)))\n (library-export (car slot) (cdr slot))))))\n (f", " (library-export (car slot) (cdr slot))))))\n (for-each export",
"or-each export (cdr form)))))\n\n(export define lambda quote set! if begin define-", " (cdr form)))))\n\n(export define lambda quote set! if begin define-macro\n ",
"macro\n let let* letrec letrec*\n let-values let*-values define-valu", "let let* letrec letrec*\n let-values let*-values define-values\n qua",
"es\n quasiquote unquote unquote-splicing\n and or\n cond case ", "siquote unquote unquote-splicing\n and or\n cond case else =>\n ",
"else =>\n do when unless\n parameterize\n define-syntax\n ", " do when unless\n parameterize\n define-syntax\n syntax-quote",
" syntax-quote syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n", " syntax-unquote\n syntax-quasiquote syntax-unquote-splicing\n let-sy",
" let-syntax letrec-syntax\n syntax-error)\n\n\n", "ntax letrec-syntax\n syntax-error)\n\n\n",
"", "",
"" ""
}; };

4
extlib/benz/reg.c
View File

@ -66,9 +66,9 @@ static pic_value
reg_get(pic_state *pic, struct pic_reg *reg, void *key) reg_get(pic_state *pic, struct pic_reg *reg, void *key)
{ {
if (! pic_reg_has(pic, reg, 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 static pic_value