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

squash-lisp-1 & 2 : fusionnés, passent les tests d'équivalence \o/

Browse Source
This commit is contained in:
Georges Dupéron 2011-01-11 23:24:32 +01:00
parent 9a64e12660
commit 57eb25bfd7
4 changed files with 81 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lisp/equiv-tests.lisp
View File

@ -62,7 +62,7 @@
'(3 4 7 5)) '(3 4 7 5))
(deftest-equiv (let*) (deftest-equiv (let*)
'(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) '(let ((x 3) (y 4) (z 5)) z (let* ((z (+ x y)) (w z)) (list x y z w)))
'(3 4 7 7)) '(3 4 7 7))
;; TODO ;; TODO

12
lisp/notes/symbols.txt Normal file
View File

@ -0,0 +1,12 @@
Variables :
boundp/makeunbound
symbol-value/set
Functions
fboundp/?
symbol-function (ou mieux : fdefinition)/(setf fdefinition)
Macros (?)
macro-function teste
macro-function/(setf macro-function)

102
lisp/squash-lisp-1.lisp
View File

@ -49,8 +49,8 @@
rend tous les noms locaux de fonction (flet/labels) et de rend tous les noms locaux de fonction (flet/labels) et de
variables (let/let*/lambda) uniques, mais pas les globaux. variables (let/let*/lambda) uniques, mais pas les globaux.
`super-let' est lui-même transformé dans la foulée en simple-let qui ne fait `super-let' est lui-même transformé dans la foulée en let simplifié qui ne
que déclarer les noms de variables, mais n'affecte pas de valeur fait que déclarer les noms de variables, mais n'affecte pas de valeur
lui-même (les affectations sont faites avec des setq) lui-même (les affectations sont faites avec des setq)
`at-toplevel' permet de déterminer si une expression est considérée comme `at-toplevel' permet de déterminer si une expression est considérée comme
@ -220,20 +220,21 @@
,@(loop ,@(loop
for (type . clause) in expr for (type . clause) in expr
when (eq type 'set) when (eq type 'set)
collect `(setq ,(cdr (assoc (car clause) name)) (transform (cadr clause))) collect `(setq ,(cdr (assoc (car clause) name)) ,(transform (cadr clause)))
when (eq type 'use-var) else when (eq type 'use-var)
do (push (assoc (car clause) name) env-var) do (push (assoc (car clause) name) env-var)
when (eq type 'use-fun) else when (eq type 'use-fun)
do (push (assoc (car clause) name) env-fun) do (push (assoc (car clause) name) env-fun)
when (eq type 'if) else when (eq type 'if)
do `(if ,(transform (car clause)) collect `(if ,(transform (car clause))
(progn ,(mapcar #'transform-super-let (cadr clause))) ,(transform-super-let (cadr clause))
(progn ,(mapcar #'transform-super-let (caddr clause)))) ,(transform-super-let (caddr clause)))
when (eq type 'progn) else when (eq type 'progn)
collect `(progn ,(mapcar (lambda (x) (transform x)) clause)))))) collect `(progn ,@(mapcar (lambda (x) (transform x)) clause))
else do (error "transform-super-let : internal error : ~a not expected here" type)))))
;; Note : ce <let> ne sera pas re-transformé (sinon boucle infinie). ;; Note : ce <let> ne sera pas re-transformé (sinon boucle infinie).
`(let ,(mapcar #'cdr name) `(let ,(mapcar #'cdr name)
,(transform-super-let expr)))) ,(transform-super-let stuff))))
((let ((:name $$ :value _)*) :body _*) ((let ((:name $$ :value _)*) :body _*)
(transform (transform
@ -252,14 +253,14 @@
collect `(use-var ,n)) collect `(use-var ,n))
(progn ,@body)))) (progn ,@body))))
((simple-flet ((:name $$ :params @ :fbody _*)*) :body _*) ((flet ((:name $$ :params @ :fbody _*)*) :body _*)
(transform (transform
`(super-let ,name `(super-let ,name
,@(mapcar (lambda (n params fbody) `(set ,n (lambda ,params (progn ,@fbody)))) name params fbody) ,@(mapcar (lambda (n params fbody) `(set ,n (lambda ,params (progn ,@fbody)))) name params fbody)
,@(mapcar (lambda (n) `(use-fun ,n)) name) ,@(mapcar (lambda (n) `(use-fun ,n)) name)
(progn ,@body)))) (progn ,@body))))
((simple-labels ((:name $$ :params @ :fbody _*)*) :body _*) ((labels ((:name $$ :params @ :fbody _*)*) :body _*)
(transform (transform
`(super-let ,name `(super-let ,name
,@(mapcar (lambda (n) `(use-fun ,n)) name) ,@(mapcar (lambda (n) `(use-fun ,n)) name)
@ -283,6 +284,7 @@
(key (cdr (assoc 'key sliced-lambda-list))) (key (cdr (assoc 'key sliced-lambda-list)))
(other (cdr (assoc 'other sliced-lambda-list))) (other (cdr (assoc 'other sliced-lambda-list)))
(aux (cdr (assoc 'aux sliced-lambda-list)))) (aux (cdr (assoc 'aux sliced-lambda-list))))
(push (cons whole-sym whole-sym) env-var)
`(lambda (&rest ,whole-sym) `(lambda (&rest ,whole-sym)
,(transform ,(transform
`(super-let (,@fixed `(super-let (,@fixed
@ -296,21 +298,21 @@
,@(loop ,@(loop
for param in fixed for param in fixed
collect `(set ,param (car ,whole-sym)) collect `(set ,param (car ,whole-sym))
collect `(use ,param) collect `(use-var ,param)
collect `(progn (setq ,whole-sym (cdr ,whole-sym)))) collect `(progn (setq ,whole-sym (cdr ,whole-sym))))
,@(loop ,@(loop
for (param default predicate) in optional for (param default predicate) in optional
collect `(if ,whole-sym collect `(if ,whole-sym
((set ,param (car whole-sym)) ((set ,param (car ,whole-sym))
(progn (setq ,whole-sym (cdr ,whole-sym))) (progn (setq ,whole-sym (cdr ,whole-sym)))
(use ,param) (use-var ,param)
,@(if predicate `((set ,predicate t) (use predicate)) nil)) ,@(if predicate `((set ,predicate t) (use-var ,predicate)) nil))
((set ,param ,default) ((set ,param ,default)
(use ,param) (use-var ,param)
,@(if predicate `((set ,predicate nil) (use predicate)) nil)))) ,@(if predicate `((set ,predicate nil) (use-var ,predicate)) nil))))
,@(if rest ,@(if rest
`((set ,(car rest) ,whole-sym) `((set ,(car rest) ,whole-sym)
(use ,(car rest))) (use-var ,(car rest)))
nil) nil)
,@(if key ,@(if key
`(progn (if (evenp (length ,whole-sym)) nil (error "Odd number of arguments, but function has &key."))) `(progn (if (evenp (length ,whole-sym)) nil (error "Odd number of arguments, but function has &key.")))
@ -318,7 +320,7 @@
,@(if key ,@(if key
(loop (loop
for (keyword param default predicate) in key for (keyword param default predicate) in key
;; TODO : quand on a trouvé, pouvoir faire set et use (support de simple-tagbody & jump-label super-let) ;; TODO : quand on a trouvé, pouvoir faire set et use-var (support de simple-tagbody & jump-label super-let)
collect (let ((search-key (make-symbol "SEARCH-KEY"))) collect (let ((search-key (make-symbol "SEARCH-KEY")))
`((progn (simple-tagbody `((progn (simple-tagbody
(jump-label ,search-key) (jump-label ,search-key)
@ -334,24 +336,28 @@
nil))) nil)))
(if ,temp-key-sym (if ,temp-key-sym
((set ,param (car ,temp-key-sym)) ((set ,param (car ,temp-key-sym))
(use ,param) (use-var ,param)
,@(if predicate `((set predicate t) (use predicate)) nil)) ,@(if predicate `((set predicate t) (use-var ,predicate)) nil))
((set ,param ,default) ((set ,param ,default)
(use ,param) (use-var ,param)
,@(if predicate `((set predicate nil) (use predicate)) nil)))))) ,@(if predicate `((set predicate nil) (use-var ,predicate)) nil))))))
nil) nil)
;; TODO : not implemented yet : vérifier s'il y a des key non autorisées. ;; TODO : not implemented yet : vérifier s'il y a des key non autorisées.
,@(loop ,@(loop
for (param val) in aux for (param val) in aux
collect `(set ,param ,val) collect `(set ,param ,val)
collect `(use ,param)) collect `(use-var ,param))
(progn ,@body)))))) (progn ,@body))))))
((function :fun (lambda . _)) ((function :fun (lambda . _))
(transform fun)) (transform fun))
((function :fun $$) ((function :fun $$)
`(get-var ,(assoc-or fun env-fun (assoc-or-push fun (derived-symbol (string fun)) (cdr globals))))) (if-assoc fun env-fun
`(get-var ,(cdr assoc))
(progn
(pushnew fun (cdr globals))
`(fdefinition ',fun))))
((funcall :fun _ :params _*) ((funcall :fun _ :params _*)
`(funcall ,(transform fun) ,@(mapcar (lambda (x) (transform x)) params))) `(funcall ,(transform fun) ,@(mapcar (lambda (x) (transform x)) params)))
@ -360,15 +366,27 @@
;; => TODO : définir la fonction funcall : (funcall #'funcall #'cons 1 2) ;; => TODO : définir la fonction funcall : (funcall #'funcall #'cons 1 2)
;; => TODO : définir la fonction apply : (funcall #'apply #'cons '(1 2)) ;; => TODO : définir la fonction apply : (funcall #'apply #'cons '(1 2))
((? or numberp stringp)
`(quote ,expr))
((setq :name $$ :value _) ((setq :name $$ :value _)
`(setq ,(assoc-or name env-var (assoc-or-push name (derived-symbol name) (car globals))) (if-assoc name env-var
,(transform value))) `(setq ,(cdr assoc) ,(transform value))
(progn
(pushnew name (car globals))
`(set ',name ,(transform value)))))
((quote _) ((quote _)
expr) expr)
((? or numberp stringp) ((fdefinition (quote $$))
`(quote ,expr)) expr)
((symbol-value (quote $$))
expr)
((set (quote $$))
expr)
;; TODO : nil et t devraient être des defconst ;; TODO : nil et t devraient être des defconst
;; Doit être avant les symboles ;; Doit être avant les symboles
@ -376,7 +394,11 @@
''nil) ''nil)
($$ ($$
(print `(get-var ,(assoc-or expr env-var (assoc-or-push expr (derived-symbol expr) (car globals)))))) (if-assoc expr env-var
`(get-var ,(cdr assoc))
(progn
(pushnew expr (car globals))
`(symbol-value ',expr))))
;; Appels de fonction ;; Appels de fonction
;; Doivent être après tout le monde. ;; Doivent être après tout le monde.
@ -393,7 +415,7 @@
(transform `(funcall (function ,name) ,@params))) (transform `(funcall (function ,name) ,@params)))
(_ (_
(error "squash-lisp-1: Not implemented yet : ~a" expr))))) (error "squash-lisp-1: Not implemented yet : ~w" expr)))))
(defun squash-lisp-1-wrap (expr) (defun squash-lisp-1-wrap (expr)
`(macrolet ((unwind-catch (object body catch-code) `(macrolet ((unwind-catch (object body catch-code)
@ -419,8 +441,6 @@
;; name) ;; name)
(jump (dest) (jump (dest)
`(go ,dest)) `(go ,dest))
(simple-let (spec body)
`(let spec body))
(get-var (x) (get-var (x)
x)) x))
,expr)) ,expr))
@ -459,8 +479,6 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
(squash-lisp-1-check body)) (squash-lisp-1-check body))
((lambda (&rest $$) :body _) ((lambda (&rest $$) :body _)
(squash-lisp-1-check body)) (squash-lisp-1-check body))
((function :fun $$)
t)
((funcall :fun _ :params _*) ((funcall :fun _ :params _*)
(every #'squash-lisp-1-check (cons fun params))) (every #'squash-lisp-1-check (cons fun params)))
((quote _) ((quote _)
@ -469,8 +487,14 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér
t) t)
((setq :name $$ :value _) ((setq :name $$ :value _)
(squash-lisp-1-check value)) (squash-lisp-1-check value))
((fdefinition (quote $$))
t)
((symbol-value (quote $$))
t)
((set (quote $$) :value _)
(squash-lisp-1-check value))
(_ (_
(warn "squash-lisp-1-check: Assertion failed ! This should not be here : ~a" expr) (warn "squash-lisp-1-check: Assertion failed ! This should not be here : ~w" expr)
nil))) nil)))
(require 'test-unitaire "test-unitaire") (require 'test-unitaire "test-unitaire")

6
lisp/util.lisp
View File

@ -221,11 +221,11 @@
`(with-symbol (,var (derived-symbol ,symbol)) `(with-symbol (,var (derived-symbol ,symbol))
,@body)) ,@body))
(defmacro assoc-or (key alist &rest body) (defmacro if-assoc (key alist body-if body-else)
`(let ((assoc (assoc ,key ,alist))) `(let ((assoc (assoc ,key ,alist)))
(if assoc (if assoc
(cdr assoc) ,body-if
(progn ,@body)))) ,body-else)))
(defmacro assoc-or-push (key datum alist-place) (defmacro assoc-or-push (key datum alist-place)
"Fait un assoc de key dans alist-place, et si l'association échoue, "Fait un assoc de key dans alist-place, et si l'association échoue,