suzanne.soy/2010-m1s1-compilation
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Adaptation de la syntaxe reconue par squash-lisp-2 pour qu'elle corresponde avec celle de squash-lisp-1.

Browse Source
This commit is contained in:
Georges Dupéron 2011-01-09 19:29:00 +01:00
parent 86d1f77faa
commit 9b2433d3c1
1 changed files with 8 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
lisp/squash-lisp-2.lisp
View File

@ -16,15 +16,15 @@
((unwind-protect :body _ :cleanup _)
`(unwind-protect ,(squash-lisp-2 body env-var env-fun globals)
,(squash-lisp-2 cleanup env-var env-fun globals)))
((unwind-catch :object _ :body _ :catch-code _)
`(unwind-catch ,(squash-lisp-2 object env-var env-fun globals)
,(squash-lisp-2 body env-var env-fun globals)
,(squash-lisp-2 catch-code env-var env-fun globals)))
((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _)
`(,type ,(squash-lisp-2 object env-var env-fun globals)
,(squash-lisp-2 body env-var env-fun globals)
,(squash-lisp-2 catch-code env-var env-fun globals)))
((unwind :object _)
`(unwind ,(squash-lisp-2 object env-var env-fun globals)))
((half-unwind :object _ :post-unwind-code _)
`(half-unwind ,(squash-lisp-2 object env-var env-fun globals)
,(squash-lisp-2 post-unwind-code env-var env-fun globals)))
((unwind-for-tagbody :object _ :post-unwind-code _)
`(unwind-for-tagbody ,(squash-lisp-2 object env-var env-fun globals)
,(squash-lisp-2 post-unwind-code env-var env-fun globals)))
((jump-label :name $$)
expr)
((jump :dest $$)
@ -54,7 +54,7 @@
`(setq ,(cdr n) ,(squash-lisp-2 v env-var env-fun globals)))
name value)
,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun
((simple-flet ((:name $$ :value _)*) :body _)
((simple-labels ((:name $$ :value _)*) :body _)
(setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name))
(let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun + env-var -> env-fun
`(simple-let ,(mapcar #'cdr name)