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

Ratés sur l'implémentation des tagbodu/go throw/catch block/return-from .

Browse Source
This commit is contained in:
Georges Dupéron 2010-11-30 18:51:19 +01:00
parent c729c7d2a9
commit a3876957b8
2 changed files with 22 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
implementation/mini-meval.lisp
View File

@ -1,6 +1,10 @@
(require 'match "match")
(require 'util "util")
;; TODO : Quand l'ancienne valeur d'une variable spéciale est sauvegardée par un let, si il y a un throw pendant ce temps-là, elle n'est pas restaurée.
;; CLTL 7.11 : Intervening dynamic bindings of special variables and catch tags are undone.
;; TODO : Les variables spéciales ne sont probablement pas correctement capturées par un lambda.
(defmacro etat-local (etat)
`(car ,etat))
@ -260,7 +264,7 @@
(defun splice-up-tagbody-1 (todo-body body result)
(if (endp todo-body)
(acons nil body result)
(if (symbolp (car todo-body))
(if (or (symbolp (car todo-body)) (numberp (car todo-body)))
(splice-up-tagbody-1 (cdr todo-body)
body
(acons (car todo-body) body result))
@ -717,7 +721,11 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
1)
(deftest (mini-meval tagbody)
(mini-meval '(tagbody foo 1 bar 2 baz 3))
(mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go 42) bar (setq x 2) 42) x))
1)
(deftest (mini-meval tagbody)
(mini-meval '(tagbody foo (list 1) 42 (list 2) baz (list 3)))
nil)
(deftest (mini-meval block)

21
implementation/squash-lisp.lisp
View File

@ -11,7 +11,7 @@
(when (endp body)
(push (reverse res) all-res)
(go end))
(when (and (car body) (symbolp (car body)))
(when (and (car body) (or (symbolp (car body)) (numberp (car body))))
(push (reverse res) all-res)
(setq res (list (car body)))
(setq body (cdr body))
@ -118,26 +118,29 @@
(the-body nil)
(unwind-catch-marker-sym (make-symbol "UNWIND-CATCH-MARKER-SYM"))
(new-etat etat)
(unique-label-sym nil)
(unique-label-sym nil))
(dolist (zone spliced-body)
(setq unique-label-sym (make-symbol (format nil "~a" (car zone))))
(setq new-etat (push-local new-etat (car zone) 'squash-tagbody-catch (cons unwind-catch-marker-sym unique-label-sym)))
(setf (car zone) unique-label-sym))
;; Définition de (unwind-catch name &rest body) :
;; `(let ((,name (make-unwind-marker))) ,body)
`(unwind-catch ,unwind-catch-marker-sym
,@(progn (dolist (zone spliced-body)
(setq the-body ,@)
(push `(tagbody-label (car zone)) res)
(push (squash-lisp `(progn (cdr zone)) new-etat) res))
`(simple-tagbody ,@(cdr (reverse res)))))))) ;; cdr pour zapper le tout premier (tagbody-label)
`(let ((,unwind-catch-marker-sym (make-unwind-marker)))
(unwind-catch ,unwind-catch-marker-sym
,@(progn (dolist (zone spliced-body)
(setq the-body ,@)
(push `(tagbody-label (car zone)) res)
(push (squash-lisp `(progn (cdr zone)) new-etat) res))
`(simple-tagbody ,@(cdr (reverse res))))))))) ;; cdr pour zapper le tout premier (tagbody-label)
((go :target $$)
(let ((association (assoc-etat target 'squash-tagbody-catch etat)))
(unless association (error "Squash-Lisp : Can't go to label ~w, it is inexistant or not lexically apparent." target))
`(progn (unwind ,(cadr association)) (simple-go ,(cddr association)))))
;; Le traitement de catch/throw est similaire, sauf que le pointeur est simplement un pointeur vers l'objet utilisé pour le catch / throw.
((catch :tag tag :body _*)
;; Les constantes sont renvoyées telles qu'elles
((? or numberp stringp)