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

Progression en % lors du chargement de match (pour les tests).

Browse Source
This commit is contained in:
Georges Dupéron 2011-01-13 00:22:20 +01:00
parent 4c0a45a5c6
commit 9d6a0bb764
3 changed files with 50 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
lisp/compilation.lisp
View File

@ -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))
#|

1
lisp/main.lisp
View File

@ -13,6 +13,7 @@
(load "squash-lisp-1")
(load "squash-lisp-3")
(load "squash-lisp")
(load "compilation")
(load "equiv-tests")
(provide 'main)

26
lisp/match.lisp
View File

@ -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)