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

Correction d'un bug sur splice-up-lambda-list.

Browse Source
This commit is contained in:
Georges Dupéron 2011-01-10 00:19:11 +01:00
parent a4936b757e
commit f0294de736
2 changed files with 64 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
lisp/match.lisp
View File

@ -564,37 +564,54 @@
#| #|
Syntaxe du match-automaton : Syntaxe du match-automaton :
(match-automaton expression initial-state (match-automaton expression initial-state
(stateX stateY [pattern] [code]) (stateX stateY [pattern] [code [code ...]])
(stateX stateY [pattern] [code]) (stateX stateY [pattern] [code [code ...]])
...) ...)
Si pattern n'est pas fourni, alors stateY est soit accept ou reject, pour indiquer qu'on accepte ou rejette l'expression si on arrive sur cet état à la fin. - certains noms d'état pour stateX et stateY sont réservés : initial accept reject do collect
Si pattern est fourni, cela signifie «Si l'élément courant de l'expression matche avec ce pattern, passer à l'élément suivant et aller dans l'état stateY.».
Lorsque l'expression est acceptée, pattern-match renvoie une liste associative ((state1 élément-1 ... élément-n) (state2 e1..eN) ...) (stateX stateY)
Les éléments à droite de chaque nom d'état sont obtenus de la manière suivante : - Si pattern n'est pas fourni, alors stateY est en général accept ou reject, pour indiquer qu'on accepte ou rejette l'expression si on arrive sur cet état à la fin.
Si code est fourni, il est exécuté, et sa valeur de retour est ajoutée à la fin de la liste correspondant à stateX (l'état de départ). - stateY peut aussi être un autre état, auquel cas, si tous les pattern de stateX échouent, ou si on se retrouve à la fin (de la liste qu'on analyse),
Si code n'est pas fourni, rien n'est ajouté à cette liste. on jump vers stateY au lieu d'aller à reject (note : il est possible de faire une boucle infinie ainsi).
Lorsqu'on est sur un certain état, chaque transition partant de cet état est testée dans l'ordre d'écriture, et la première qui matche est choisie.
(stateX stateY pattern)
- Si pattern est fourni, cela signifie «Si l'élément courant de l'expression matche avec ce pattern, passer à l'élément suivant et aller dans l'état stateY.».
- Lorsque l'expression est acceptée, pattern-match renvoie une liste associative ((state1 élément-1 ... élément-n) (state2 e1..eN) ...)
- Les éléments à droite de chaque nom d'état sont obtenus de la manière suivante :
- Si code est fourni: (stateX stateY pattern code*)
il est exécuté, et sa valeur de retour est ajoutée à la fin de la liste correspondant à stateX (l'état de départ).
- Si code n'est pas fourni : (stateX stateY pattern)
rien n'est ajouté à cette liste.
- Lorsqu'on est sur un certain état, chaque transition partant de cet état est testée dans l'ordre d'écriture, et la première qui matche est choisie.
De plus, il est possible de spécifier des clauses spéciales, au lieu des (stateX stateY [pattern] [code]) : De plus, il est possible de spécifier des clauses spéciales, au lieu des (stateX stateY [pattern] [code]) :
- (initial code ...), qui exécute le code avant de démarrer (pas très utile...) - (initial code ...) qui exécute le code avant de démarrer (pas très utile…)
- (accept code ...), qui exécute le code dans le cas où l'expression est acceptée. La valeur renvoyée par ce code sera la valeur de retour de match-automaton.
- (accept code ...) qui exécute le code dans le cas où l'expression est acceptée. La valeur renvoyée par ce code sera la valeur de retour de match-automaton.
Dans cette clause, on peut accéder à la valeur qui aurait dû être renvoyée via la variable return-value. Dans cette clause, on peut accéder à la valeur qui aurait dû être renvoyée via la variable return-value.
- (reject code ...), qui exécute le code dans le cas où l'expression est rejetée. La valeur renvoyée par ce code sera la valeur de retour de match-automaton.
- (reject code ...) qui exécute le code dans le cas où l'expression est rejetée. La valeur renvoyée par ce code sera la valeur de retour de match-automaton.
Dans cette clause, le dernier élément considéré est stocké dans last-element. Dans cette clause, le dernier élément considéré est stocké dans last-element.
Cet élément est celui qui a causé le reject, ou nil si on est au début de la liste, ou nil si on est à la fin de la liste sans accept. Cet élément est celui qui a causé le reject, ou nil si on est au début de la liste, ou nil si on est à la fin de la liste sans accept.
;;De même, le dernier état courant est dans last-state. De même, le dernier état courant est dans last-state.
- (stateX do code ...) qui exécute code à chaque fois qu'on entre sur stateX.
On peut accéder à last-element et last-state.
- (stateX collect code ...) qui exécute code à chaque fois qu'on entre sur stateX et ajoute sa valeur de retour à la fin de la liste correspondant à stateX.
On peut accéder à last-element et last-state.
Il peut y avoir plusieurs initial, accept et reject, auquel cas tous sont exécutés dans l'ordre d'écriture, et sont concaténés dans un progn, Il peut y avoir plusieurs initial, accept et reject, auquel cas tous sont exécutés dans l'ordre d'écriture, et sont concaténés dans un progn,
donc seule la valeur de la dernière expression de la dernière clause est renvoyée. donc seule la valeur de la dernière expression de la dernière clause est renvoyée.
|# |#
;; ATTENTION, par excès de flemme, match-automaton ne supporte pas la syntax ;; ATTENTION, par excès de flemme, match-automaton ne supporte pas la syntaxe
;; (macro :var atom expr code) ;; de découplage du nom de capture et de l'élément : (macro :var atom expr code)
;; ATTENTION, j'ai renoncé à rendre ce code lisible. ;; ATTENTION, j'ai renoncé à rendre ce code lisible.
(defun match--grouped-transition-to-progns (grouped-transition) (defun match--transitions-to-progns (transitions)
;; On remet to, pattern et code bout à bout (c'est tout du code) ;; On remet to, pattern et code bout à bout (c'est tout du code)
(mapcar (lambda (x) `(progn ,(car x) ,@(cadr x) ,@(caddr x))) (mapcar (lambda (x) `(progn ,(car x) ,@(cadr x) ,@(caddr x)))
(cdr grouped-transition))) transitions))
(defmacro match-automaton (expr initial-state &rest rules) (defmacro match-automaton (expr initial-state &rest rules)
(match ((:from $$ :to _ :pattern _? :code _*) *) rules (match ((:from $$ :to _ :pattern _? :code _*) *) rules
@ -611,14 +628,14 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo
(block ,block-sym (block ,block-sym
(tagbody (tagbody
initial initial
(progn ,(match--grouped-transition-to-progns (assoc 'initial grouped-transitions))) (progn ,(match--transitions-to-progns (cdr (assoc 'initial grouped-transitions))))
(go ,initial-state) (go ,initial-state)
accept accept
(let ((return-value (list ,@(mapcar (lambda (s) `(cons ',(car s) (reverse ,(cdr s)))) storage)))) (let ((return-value (list ,@(mapcar (lambda (s) `(cons ',(car s) (reverse ,(cdr s)))) storage))))
return-value return-value
(return-from ,block-sym (return-from ,block-sym
(progn return-value (progn return-value
,@(match--grouped-transition-to-progns (assoc 'accept grouped-transitions))))) ,@(match--transitions-to-progns (cdr (assoc 'accept grouped-transitions))))))
reject reject
(return-from ,block-sym (return-from ,block-sym
(let ((last-element ,last-element-sym) (let ((last-element ,last-element-sym)
@ -626,7 +643,7 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo
last-element last-element
last-state last-state
(progn nil (progn nil
,@(match--grouped-transition-to-progns (assoc 'reject grouped-transitions))))) ,@(match--transitions-to-progns (cdr (assoc 'reject grouped-transitions))))))
;; On va générer ceci : ;; On va générer ceci :
;; state1 ;; state1
;; (cond-match ... (go state2) ... (go state1) ...) ;; (cond-match ... (go state2) ... (go state1) ...)
@ -636,19 +653,34 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo
;; (cond-match ... (go accept) ... (go state1) ...))) ;; (cond-match ... (go accept) ... (go state1) ...)))
,@(loop ,@(loop
for (from . transitions) in grouped-transitions for (from . transitions) in grouped-transitions
and temp-do = nil
and temp-collect = nil
;; syntaxe (stateX code) => exécute le code à chaque fois qu'on rentre dans stateX.
for jump = (member nil (reverse transitions) :key #'second)
unless (member from '(initial accept reject)) unless (member from '(initial accept reject))
collect from collect from
and collect `(setq ,last-state-sym ',from) and collect `(setq ,last-state-sym ',from)
and collect `(setq ,last-element-sym (car ,expr-sym)) and collect `(setq ,last-element-sym (car ,expr-sym))
and if (member nil transitions :key #'second) and if jump
collect `(when (endp ,expr-sym) (go accept)) ;; TODO : aller à l'état désigné par la dernière transition "finale". + syntaxe (stateX code) => exécute le code à chaque fois qu'on rentre dans stateX. ;; va à l'état désigné par la dernière transition "finale".
collect `(when (endp ,expr-sym) (go ,(caar jump)))
else else
collect `(when (endp ,expr-sym) (go reject)) collect `(when (endp ,expr-sym) (go reject))
end end
and do (setq temp-do (remove nil (mapcar (lambda (x) (when (eq 'do (car x)) `(progn ,@(cadr x) ,@(caddr x)))) transitions)))
and do (setq temp-collect (remove nil (mapcar (lambda (x) (when (eq 'collect (car x)) `(progn ,@(cadr x) ,@(caddr x)))) transitions)))
and when (or temp-do temp-collect)
collect `(let ((last-element ,last-element-sym)
(last-state ,last-state-sym))
last-element
last-state
,@(if temp-do `((progn ,@temp-do)) nil)
,@(if temp-collect `((push (progn ,@temp-collect) ,(cdr (assoc from storage)))) nil))
end
and collect `(cond-match (car ,expr-sym) and collect `(cond-match (car ,expr-sym)
,@(loop ,@(loop
for (to pattern code) in transitions for (to pattern code) in transitions
when pattern unless (or (not pattern) (eq to 'do) (eq to 'collect))
if code if code
collect `(,@pattern collect `(,@pattern
(push (progn ,@code) ,(cdr (assoc from storage))) (push (progn ,@code) ,(cdr (assoc from storage)))
@ -658,7 +690,7 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo
collect `(,@pattern collect `(,@pattern
(setq ,expr-sym (cdr ,expr-sym)) (setq ,expr-sym (cdr ,expr-sym))
(go ,to))) (go ,to)))
(_ (go reject)))))))))) (_ ,(if jump `(go ,(caar jump)) '(go reject)))))))))))
(require 'test-unitaire "test-unitaire") (require 'test-unitaire "test-unitaire")
(erase-tests match) (erase-tests match)

7
lisp/mini-meval.lisp
View File

@ -125,6 +125,7 @@
;; - transformation de la récursion terminale. ;; - transformation de la récursion terminale.
;; - vérifier qu'on a pas transformé certaines fonctions en formes spéciales (il faut qu'on puisse toujours les récupérer avec #'). ;; - vérifier qu'on a pas transformé certaines fonctions en formes spéciales (il faut qu'on puisse toujours les récupérer avec #').
;; - sortir le defun du mini-meval ?
;; cell (un seul pointeur, transparent (y compris pour le type), ;; cell (un seul pointeur, transparent (y compris pour le type),
;; avec trois fonctions spéciales pour le get / set / tester le type), ;; avec trois fonctions spéciales pour le get / set / tester le type),
@ -147,13 +148,13 @@
(optional optional (:var . $$) `(,var nil nil)) (optional optional (:var . $$) `(,var nil nil))
(optional optional (:var $$ :default _? :svar $$?) `(,var ,(car default) ,(car svar))) (optional optional (:var $$ :default _? :svar $$?) `(,var ,(car default) ,(car svar)))
(rest reject $&) (rest reject $&)
(rest rest2 (:var . $$) `(,var)) (rest rest2 (:var . $$) var)
(rest2 accept) (rest2 accept)
(rest2 key &key) (rest2 key &key)
(rest2 aux &aux) (rest2 aux &aux)
(rest2 reject $&) (rest2 reject $&)
(key accept) (key accept)
(key other &allow-other-keys t) (key other &allow-other-keys)
(key aux &aux) (key aux &aux)
(key reject $&) (key reject $&)
(key key (:keyword . $k) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) nil nil)) ;; Not in the standard ! (key key (:keyword . $k) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) nil nil)) ;; Not in the standard !
@ -161,6 +162,7 @@
(key key (:keyword $$ :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) ,(car default) ,(car svar))) ;; Not in the standard ! (key key (:keyword $$ :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) ,(car default) ,(car svar))) ;; Not in the standard !
(key key (:var $$ :default _? :svar $$?) `(,var ,var ,(car default) ,(car svar))) (key key (:var $$ :default _? :svar $$?) `(,var ,var ,(car default) ,(car svar)))
(key key ((:keyword $k :var $$) :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,var ,(car default) ,(car svar))) (key key ((:keyword $k :var $$) :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,var ,(car default) ,(car svar)))
(other collect t)
(other accept) (other accept)
(other aux &aux) (other aux &aux)
(other reject $&) (other reject $&)
@ -171,6 +173,7 @@
(reject (error "slice-up-lambda-list : ~w ne peut être ici." last-element)))) (reject (error "slice-up-lambda-list : ~w ne peut être ici." last-element))))
;; Exemples : ;; Exemples :
;; TODO : en faire des tests unitaires.
;; (slice-up-lambda-list '(a b &optional u &rest c &key ((:foo bar)) :quux (:baz 'glop) &aux (x 1) (y (+ x 2)))) ;; (slice-up-lambda-list '(a b &optional u &rest c &key ((:foo bar)) :quux (:baz 'glop) &aux (x 1) (y (+ x 2))))
;; (slice-up-lambda-list '(a b &rest)) ;; (slice-up-lambda-list '(a b &rest))
;; (slice-up-lambda-list '(a b)) ;; (slice-up-lambda-list '(a b))