commit 9d6a0bb76482293f41758d4409032f5e8c7b51aa
parent 4c0a45a5c61079c2f071c9ccfcf383d901137969
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Thu, 13 Jan 2011 00:22:20 +0100
Progression en % lors du chargement de match (pour les tests).
Diffstat:
3 files changed, 50 insertions(+), 23 deletions(-)
diff --git 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
@@ -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
@@ -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
