From 9d6a0bb76482293f41758d4409032f5e8c7b51aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 13 Jan 2011 00:22:20 +0100 Subject: [PATCH] Progression en % lors du chargement de match (pour les tests). --- lisp/compilation.lisp | 46 +++++++++++++++++++++---------------------- lisp/main.lisp | 1 + lisp/match.lisp | 26 ++++++++++++++++++++++++ 3 files changed, 50 insertions(+), 23 deletions(-) diff --git a/lisp/compilation.lisp b/lisp/compilation.lisp index 45e73f1..32a7d19 100644 --- a/lisp/compilation.lisp +++ b/lisp/compilation.lisp @@ -84,29 +84,6 @@ (apply #'append (mapcar (lambda (x) (cons (list 'section (car x)) (reverse (cdr x)))) res)))) -(defun compilo-1 (expr &aux res) - (match - (top-level :main $$ (progn (set :names $$ (lambda (:closure-names $$ &rest :params-names $$) (get-var $$) (get-var $$) (let :vars ($$*) :bodys _*)))*)) - expr - (setq res (loop - for name in names - and closure-name in closure-names - and params-name in params-names - and var in vars - and body in bodys - collect `(label name) - collect `(mov (constant ,(+ 2 (length var))) (register r0)) ;; +1 pour les paramètres (nécessaire?) - collect `(push (register ip)) - collect `(jmp (constant ,(syslabel 'reserve-stack))) - collect (compilo-2 `(progn body) (loop - for v in (cons closure-name (cons params-name var)) - for i upfrom 0 - collect `(,var . ,i))))) - `(section code (jmp main) ,@res))) - -(defun compilo (expr) - (flatten-asm (compilo-1 (squash-lisp-1+3 expr)))) - (defun compilo-2 (expr variables) "Vérifie si expr est bien un résultat valable de squash-lisp-1. Permet aussi d'avoir une «grammaire» du simple-lisp niveau 1. @@ -167,6 +144,29 @@ Attention : il y a quelques invariants qui ne sont pas présents dans cette vér nil)))) (compilo-3 expr))) +(defun compilo-1 (expr &aux res) + (match + (top-level :main $$ (progn (set :names $$ (lambda (:closure-names $$ &rest :params-names $$) (get-var $$) (get-var $$) (let :vars ($$*) :bodys _*)))*)) + expr + (setq res (loop + for name in names + and closure-name in closure-names + and params-name in params-names + and var in vars + and body in bodys + collect `(label name) + collect `(mov (constant ,(+ 2 (length var))) (register r0)) ;; +1 pour les paramètres (nécessaire?) + collect `(push (register ip)) + collect `(jmp (constant ,(syslabel 'reserve-stack))) ;; lance le gc pour re-dimensionner le tas si nécessaire / ou bien erreur si dépassement. + collect (compilo-2 `(progn body) (loop + for v in (cons closure-name (cons params-name var)) + for i upfrom 0 + collect `(,var . ,i))))) + `(section code (jmp main) ,@res))) + +(defun compilo (expr) + (flatten-asm (compilo-1 (squash-lisp-1+3 expr)))) + (squash-lisp-1+3 '(+ 2 3)) #| diff --git a/lisp/main.lisp b/lisp/main.lisp index 1bb9121..01ff7c7 100644 --- a/lisp/main.lisp +++ b/lisp/main.lisp @@ -13,6 +13,7 @@ (load "squash-lisp-1") (load "squash-lisp-3") (load "squash-lisp") +(load "compilation") (load "equiv-tests") (provide 'main) diff --git a/lisp/match.lisp b/lisp/match.lisp index cbc63a6..54a1ab7 100644 --- a/lisp/match.lisp +++ b/lisp/match.lisp @@ -719,6 +719,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo (require 'test-unitaire "test-unitaire") (erase-tests match) +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 0%")) + ;;;; Tests de matching (vrai / faux) ;;; Symboles, chiffres, etc @@ -772,6 +774,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;; _ +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 5%")) + (deftest (match _) (match _ 'a) t #'booleq) (deftest (match _) (match _ '(a b)) t #'booleq) (deftest (match _) (match _ '()) t #'booleq) @@ -836,6 +840,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;; @ Mêmes tests que _ , on indique les différences avec ";; diff" à la fin de la ligne. +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 10%")) + (deftest (match @) (match @ 'a) nil #'booleq) ;; diff (deftest (match @) (match @ '(a b)) t #'booleq) (deftest (match @) (match @ '()) t #'booleq) @@ -900,6 +906,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;; @. Mêmes tests que @ , on indique les différences avec ";; diff avec @" à la fin de la ligne. +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 20%")) + (deftest (match @.) (match @. 'a) nil #'booleq) (deftest (match @.) (match @. '(a b)) t #'booleq) (deftest (match @.) (match @. '()) nil #'booleq) ;; diff avec @ @@ -964,6 +972,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;; $ Mêmes tests que _ , on indique les différences avec ";; diff" à la fin de la ligne. +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 30%")) + (deftest (match $) (match $ 'a) t #'booleq) (deftest (match $) (match $ '(a b)) nil #'booleq) ;; diff (deftest (match $) (match $ '()) nil #'booleq) ;; diff @@ -1028,6 +1038,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;; * +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 40%")) + (deftest (match * symbole) (match (a *) '(a a a a)) t #'booleq) (deftest (match * symbole) (match (a *) '(a)) t #'booleq) (deftest (match * symbole) (match (a *) '()) t #'booleq) @@ -1088,6 +1100,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;; + Mêmes tests que * , on indique les différences avec ";; diff" à la fin de la ligne. +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 50%")) + (deftest (match + symbole) (match (a +) '(a a a a)) t #'booleq) (deftest (match + symbole) (match (a +) '(a)) t #'booleq) (deftest (match + symbole) (match (a +) '()) nil #'booleq) ;; diff @@ -1148,6 +1162,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;; ? Mêmes tests que * , on indique les différences avec ";; diff" à la fin de la ligne. +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 60%")) + (deftest (match ? symbole) (match (a ?) '(a a a a)) nil #'booleq) ;; diff (deftest (match ? symbole) (match (a ?) '(a)) t #'booleq) (deftest (match ? symbole) (match (a ?) '()) t #'booleq) @@ -1208,6 +1224,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;; (? tests...) +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 70%")) + ;; TODO : not, nand et nor + notation infixe (ou peut-être pas). ;; Identity par défaut. @@ -1244,6 +1262,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;; Tests de preprocess-capture +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 75%")) + (deftest (match preprocess-capture) (pattern-match-preprocess (:x . nil)) '(x nil nil nil nil)) @@ -1295,6 +1315,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo ;;;; Tests de capture (variables) +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 80%")) + (deftest (match append-captures) (append-captures '((x . (foo bar)) (y . foo) (z . bar)) '(((x . nil) (y . nil) (z . nil)) (e . x))) @@ -1403,6 +1425,8 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo () ((1 2) (3)))) +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 90%")) + (deftest (match capture labels) (match (labels :declarations ((:name $ :params (:param $*) :fbody _*) *) :body _*) '(labels ((foo (x y) (list x y)) @@ -1486,4 +1510,6 @@ donc seule la valeur de la dernière expression de la dernière clause est renvo (test-match-bar 42) 'i-m-else) +(eval-when (:execute :load-toplevel :compile-toplevel) (format t "~&;; loading tests : 100%")) + (provide 'match) \ No newline at end of file