From eed75e446c555f126eab5da132227fcc06ee6ef7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Wed, 12 Jan 2011 14:09:19 +0100 Subject: [PATCH] =?UTF-8?q?D=C3=A9but=20compilation=20+=20**=20autour=20de?= =?UTF-8?q?s=20defvar?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lisp/compilation.lisp | 118 ++++++++++++++++++++++++++++++++++------ lisp/main.lisp | 2 +- lisp/mini-meval.lisp | 58 ++++++++++---------- lisp/test-unitaire.lisp | 28 +++++----- lisp/vm.lisp | 32 ++++------- 5 files changed, 156 insertions(+), 82 deletions(-) diff --git a/lisp/compilation.lisp b/lisp/compilation.lisp index 6d5a80b..4cc93ca 100644 --- a/lisp/compilation.lisp +++ b/lisp/compilation.lisp @@ -5,11 +5,11 @@ (require 'util "util") (require 'squash-lisp "implementation/squash-lisp") -(defvar asm-fixnum-size 32) -(defvar asm-max-fixnum (expt 2 asm-fixnum-size)) +(defvar *asm-fixnum-size* 32) +(defvar *asm-max-fixnum* (expt 2 *asm-fixnum-size*)) (defun type-number (type) (position type '(placeholder fixnum bignum symbol string cons nil))) -(defvar label-ctr 0) +(defvar *label-ctr* 0) (defmacro fasm (&rest stuff) `(format nil ,@stuff)) @@ -18,24 +18,24 @@ ;; My-compile -(defvar result-asm nil) -(defvar sections '(data code)) +(defvar *result-asm* nil) +(defvar *sections* '(data code)) (defun real-asm-block (section label body) - (when (not (member section sections)) + (when (not (member section *sections*)) (error "Section assembleur inconnue : ~w" section)) - (push (format nil "section .~w" section) result-asm) - (push (format nil "~a:" label) result-asm) - (mapcar (lambda (x) (push x result-asm)) body) + (push (format nil "section .~w" section) *result-asm*) + (push (format nil "~a:" label) *result-asm*) + (mapcar (lambda (x) (push x *result-asm*)) body) label) (defun asm-block (section label-base &rest body) (real-asm-block section - (format nil "~a-~a" label-base (incf label-ctr)) + (format nil "~a-~a" label-base (incf *label-ctr*)) body)) -(defvar asm-once nil) +(defvar *asm-once* nil) (defun asm-once (section label &rest body) (unless (member label asm-once :test #'string-equal) (push label asm-once) @@ -43,26 +43,26 @@ label) (defmacro my-compile (expr) - `(progn (setq result-asm nil) + `(progn (setq *result-asm* nil) (setq asm-once nil) (my-compile-1 `(:main ,(lisp2cli ',expr))) - (format nil "~&~{~%~a~}" (flatten (reverse result-asm))))) + (format nil "~&~{~%~a~}" (flatten (reverse *result-asm*))))) ;;; Règles de compilation (defmatch my-compile-1) ;; fixnum -(defmatch my-compile-1 (:nil :const :num . (? numberp (< x asm-max-fixnum))) +(defmatch my-compile-1 (:nil :const :num . (? numberp (< x *asm-max-fixnum*))) (asm-block 'data "fixnum-constant" (db-type 'fixnum) (fasm "db ~a" num))) ;; bignum -(defmatch my-compile-1 (:nil :const :num . (? numberp (>= x asm-max-fixnum))) +(defmatch my-compile-1 (:nil :const :num . (? numberp (>= x *asm-max-fixnum*))) (asm-block 'data "bignum-constant" (db-type 'bignum) - (let ((lst (split-bytes num asm-fixnum-size))) + (let ((lst (split-bytes num *asm-fixnum-size*))) (fasm "~{~&db ~a~}" (cons (length lst) lst))))) ;; string @@ -117,8 +117,90 @@ (fasm "label @~a" else-label) (compile si-faux) (fasm "label @~a" end-if-label))) - - + + + + ;=========================== + ; ((( V2 *))) + ;=========================== + +(defun compilo (expr) + (match + (top-level :main $$ + (progn (set :name $$ (lambda :params (&rest $$) :unused (get-var $$) + (let :vars ($$*) :body _*)))*)) + expr + (setq res + (loop + for n in name + and p in params + and v in vars + and b in body + collect `(label n) + collect `(mov ,(+ 1 (length vars)) r0) + collect `(call ,(syslabel reserve-stack)) + (setq res (append `((jmp ,main)) (flatten-asm res))) + res)) + +(defun squash-lisp-3-check-internal (expr) + "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. +Attention : il y a quelques invariants qui ne sont pas présents dans cette vérification." + (cond-match + expr + ;; simple-tagbody est équivalent à un progn, mais nécessaire pour les macrolet. + (((? (member x '(progn simple-tagbody))) :body _*) + (every #'squash-lisp-3-check-internal body)) + ((if :condition _ :si-vrai _ :si-faux _) + (and (squash-lisp-3-check-internal condition) + (squash-lisp-3-check-internal si-vrai) + (squash-lisp-3-check-internal si-faux))) + ((unwind-protect :body _ :cleanup _) + (and (squash-lisp-3-check-internal body) + (squash-lisp-3-check-internal cleanup))) + ;; tagbody-unwind-catch est équivalent à unwind-catch, mais nécessaire pour les macrolet. + (((? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body (progn _*) :catch-code _) + (and (squash-lisp-3-check-internal object) + (squash-lisp-3-check-internal body) + (squash-lisp-3-check-internal catch-code))) + ((unwind :object _) + (squash-lisp-3-check-internal object)) + ((unwind-for-tagbody :object _ :post-unwind-code _) + (and (squash-lisp-3-check-internal object) + (squash-lisp-3-check-internal post-unwind-code))) + ((jump-label :name $$) + t) + ((jump :dest $$) + t) + ;; ((let ($$*) :body _) + ;; (squash-lisp-3-check-internal body)) + ;; ((lambda (&rest $$) :unused _ :body (let ($$*) _*)) + ;; (squash-lisp-3-check-internal body)) + ((funcall :fun _ :params _*) + (every #'squash-lisp-3-check-internal (cons fun params))) + ((quote _) + t) + ((get-var $$) + t) + ((setq :name $$ :value _) + (squash-lisp-3-check-internal value)) + ((fdefinition (quote $$)) + t) + ((symbol-value (quote $$)) + t) + ((set (quote $$) :value _) + (squash-lisp-3-check-internal value)) + ((make-captured-var $$) + t) + ((get-captured-var $$) + t) + ((set-captured-var $$ :value _) + (squash-lisp-3-check-internal value)) + (_ + (warn "squash-lisp-3-check-internal: Assertion failed ! This should not be here : ~w" expr) + nil))) + + ;;; Exemples (my-compile '(1 2 3)) diff --git a/lisp/main.lisp b/lisp/main.lisp index 6ee600b..1bb9121 100644 --- a/lisp/main.lisp +++ b/lisp/main.lisp @@ -3,7 +3,7 @@ ;; Chargement de tous les fichiers, dans l'ordre du tri topologique ;; pour tous les re-charger, sans les charger deux fois. -;; TODO : mettre de ** autour des variables en defvar. +(setq *load-verbose* t) (load "util") (load "test-unitaire") diff --git a/lisp/mini-meval.lisp b/lisp/mini-meval.lisp index 342aee4..d0b0f3a 100644 --- a/lisp/mini-meval.lisp +++ b/lisp/mini-meval.lisp @@ -265,15 +265,15 @@ (cdr (assoc 'other lambda-list)) (cdr (assoc 'aux lambda-list)))) -(defun splice-up-tagbody-1 (todo-body body result) - (if (endp todo-body) +(defun splice-up-tagbody-1 (remaining-body body result) + (if (endp remaining-body) (acons nil body result) - (if (or (symbolp (car todo-body)) (numberp (car todo-body))) - (splice-up-tagbody-1 (cdr todo-body) + (if (or (symbolp (car remaining-body)) (numberp (car remaining-body))) + (splice-up-tagbody-1 (cdr remaining-body) body - (acons (car todo-body) body result)) - (splice-up-tagbody-1 (cdr todo-body) - (cons (car todo-body) body) + (acons (car remaining-body) body result)) + (splice-up-tagbody-1 (cdr remaining-body) + (cons (car remaining-body) body) result)))) (defun splice-up-tagbody (body) @@ -526,7 +526,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau 7) (deftest (mini-meval defvar) - (mini-meval '(progn (defvar x 42) x) etat) + (mini-meval '(progn (defvar *test-var-x* 42) *test-var-x*) etat) 42) ;; Syntaxe supplémentaire non reconnue par le standard : (#'fun param*) @@ -541,9 +541,9 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau (deftest (mini-meval defvar special) (mini-meval '(progn - (defun foo1 () var) - (defun foo2 () (let ((var 4)) (list var (foo1)))) - (defvar var 123) + (defun foo1 () *test-var-y*) + (defun foo2 () (let ((*test-var-y* 4)) (list *test-var-y* (foo1)))) + (defvar *test-var-y* 123) (list (foo1) (foo2))) etat) '(123 (4 4))) @@ -568,7 +568,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau '((a b) ('a 'b) (a b))) (deftest (mini-meval setf setq) - (mini-meval '(list (defvar x 42) x (setq x 123) x) etat) + (mini-meval '(list (defvar *test-var-z* 42) *test-var-z* (setq *test-var-z* 123) *test-var-z*) etat) '(x 42 123 123)) ;; TODO : tests setf @@ -582,7 +582,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau '42) (deftest (mini-meval function internal) - (mini-meval '(progn (defvar bar (list (lambda (x) (+ x 40)) 1 2 3)) (funcall (car bar) 2)) etat) + (mini-meval '(progn (defvar *test-var-bar* (list (lambda (x) (+ x 40)) 1 2 3)) (funcall (car *test-var-bar*) 2)) etat) '42) (deftest (mini-meval call-function internal) @@ -591,28 +591,28 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau (deftest (mini-meval lambda closure single-instance) (mini-meval '(progn - (defvar foo (let ((y 1)) (cons (lambda (x) (list x y)) (lambda (z) (setq y (+ y z)) nil)))) - (list (funcall (car foo) 4) (funcall (cdr foo) 5) (funcall (car foo) 4))) etat) + (defvar *test-var-foo* (let ((y 1)) (cons (lambda (x) (list x y)) (lambda (z) (setq y (+ y z)) nil)))) + (list (funcall (car *test-var-foo*) 4) (funcall (cdr *test-var-foo*) 5) (funcall (car *test-var-foo*) 4))) etat) '((4 1) nil (4 6))) (deftest (mini-meval lambda closure multiple-instances) (mini-meval '(progn (defun counter (&optional (ctr 0)) (cons (lambda () ctr) (lambda (&optional (x 1)) (setq ctr (+ ctr x)) nil))) - (defvar foo0 (counter)) - (defvar foo42 (counter 42)) + (defvar *test-var-foo0* (counter)) + (defvar *test-var-foo42* (counter 42)) (list - (funcall (car foo0)) ;; show 0 - (funcall (car foo42)) ;; show 42 - (funcall (cdr foo0)) ;; add 0 - (funcall (car foo0)) ;; show 0 - (funcall (cdr foo42)) ;; add 42 - (funcall (car foo42)) ;; show 42 - (funcall (car foo0)) ;; shwo 0 - (funcall (car foo42)) ;; show 42 - (funcall (cdr foo42) 6) ;; add 42 (+ 6) - (funcall (cdr foo0) 5) ;; add 0 (+ 5) - (funcall (car foo42)) ;; show 42 - (funcall (car foo0)))) ;; show 0 + (funcall (car *test-var-foo0*)) ;; show 0 + (funcall (car *test-var-foo42*)) ;; show 42 + (funcall (cdr *test-var-foo0*)) ;; add 0 + (funcall (car *test-var-foo0*)) ;; show 0 + (funcall (cdr *test-var-foo42*)) ;; add 42 + (funcall (car *test-var-foo42*)) ;; show 42 + (funcall (car *test-var-foo0*)) ;; shwo 0 + (funcall (car *test-var-foo42*)) ;; show 42 + (funcall (cdr *test-var-foo42*) 6) ;; add 42 (+ 6) + (funcall (cdr *test-var-foo0*) 5) ;; add 0 (+ 5) + (funcall (car *test-var-foo42*)) ;; show 42 + (funcall (car *test-var-foo0*)))) ;; show 0 etat) '(0 42 nil 1 nil 43 1 43 nil nil 49 6)) diff --git a/lisp/test-unitaire.lisp b/lisp/test-unitaire.lisp index 687dc4e..1f1bb93 100644 --- a/lisp/test-unitaire.lisp +++ b/lisp/test-unitaire.lisp @@ -1,9 +1,9 @@ -;; all-tests : +;; *all-tests* : ;; : ( executed-bit variables tests) ;; : ((nom-module . ) (nom-module2 . ) ...) -(defvar all-tests (list nil nil nil nil) "Liste de tous les tests") +(defvar *all-tests* (list nil nil nil nil) "Liste de tous les tests") -(defun test-get-module (module &optional (from all-tests)) +(defun test-get-module (module &optional (from *all-tests*)) (unless (listp module) (setq module (list module))) (if (endp module) from @@ -19,7 +19,7 @@ (defun test-get-variables (module) (third (test-get-module module))) (defun test-get-tests (module) (fourth (test-get-module module))) -(defun test-collect-down-tree (fn module &optional (from all-tests)) +(defun test-collect-down-tree (fn module &optional (from *all-tests*)) (unless (listp module) (setq module (list module))) (if (endp module) (cons (funcall fn from) nil) @@ -27,13 +27,13 @@ (test-collect-down-tree fn (cdr module) (cdr (assoc (car module) (car from))))))) -(defun test-get-variables-and-above (module &optional (from all-tests)) +(defun test-get-variables-and-above (module &optional (from *all-tests*)) (remove-duplicates (apply #'append (mapcar #'reverse (test-collect-down-tree #'third module from))) :key #'car)) (defun test-set-executed (from &optional (value t)) (setf (second from) value)) -(defun test-clear-all-executed (&optional (from all-tests)) +(defun test-clear-all-executed (&optional (from *all-tests*)) (setf (second from) nil) (mapcar #'test-clear-all-executed (mapcar #'cdr (first from)))) @@ -48,7 +48,7 @@ (defun test-remove-module (module) (if (null module) - (setf all-tests (list nil nil nil nil)) + (setf *all-tests* (list nil nil nil nil)) (let ((from (test-get-module (butlast module)))) (setf (first from) (delete (car (last module)) @@ -92,7 +92,7 @@ `(test-add-variable ',module (list ',name ',value))) -(defvar run-tests-counter 0) +(defvar *run-tests-counter* 0) (declaim (ftype function real-run-tests)) ;; récursion mutuelle real-run-tests / run-tests-submodules (defun run-tests-submodules (module-name submodules) @@ -104,28 +104,28 @@ (defun real-run-tests (module-name from) (if (second from) (progn - (format t "~&~%-~{ ~w~}~& [Déjà vu]~&" (or module-name '(all-tests))) + (format t "~&~%-~{ ~w~}~& [Déjà vu]~&" (or module-name '(*all-tests*))) t) (progn - (format t "~&~%>~{ ~w~}~&" (or module-name '(all-tests))) + (format t "~&~%>~{ ~w~}~&" (or module-name '(*all-tests*))) (setf (second from) t) ;; marquer comme exécuté. (let ((nb-fail (count-if-not #'funcall (reverse (fourth from))))) (if (= nb-fail 0) (progn - (incf run-tests-counter (length (fourth from))) + (incf *run-tests-counter* (length (fourth from))) (run-tests-submodules module-name (reverse (first from)))) (format t "Module ~w failed ~w tests. Stopping.~&" module-name nb-fail)))))) (defmacro run-tests (&rest modules) (when (null modules) (setq modules '(nil))) (setq modules (substitute nil t modules)) - (setq run-tests-counter 0) + (setq *run-tests-counter* 0) `(progn (test-clear-all-executed) (if (every #'real-run-tests ',(mapcar (lambda (x) (if (listp x) x (list x))) modules) ',(mapcar #'test-get-module modules)) - (progn (format t "~a tests passed sucessfully." run-tests-counter) + (progn (format t "~a tests passed sucessfully." *run-tests-counter*) t) nil))) @@ -138,7 +138,7 @@ (format t "~&~4@<~d~> ~4@<~d~> >~{ ~w~}~&" (length (fourth from)) (count-nb-tests from) - (or module-name '(all-tests))) + (or module-name '(*all-tests*))) (mapcar (lambda (x) (real-show-tests (append module-name (list (car x))) (cdr x))) (first from)) nil) diff --git a/lisp/vm.lisp b/lisp/vm.lisp index 2240830..66385d5 100644 --- a/lisp/vm.lisp +++ b/lisp/vm.lisp @@ -1,11 +1,3 @@ -;; "objet" VM. -;; Instanciation : -;; (defvar vm (make-vm 100)) -;; Appels de méthode : -;; (send vm get-memory 42) -;; (send vm set-memory 42 5) -;; (send vm get-register R1) -;; (send vm set-register R2 (send vm get-register 42)) (defun make-vm (size &optional debug) (cons (make-array size :initial-element 0) `(;; Registres généraux. @@ -58,11 +50,11 @@ ;;TODO : Rajouter une fonction resolve pour resoudre les differents modes d'adresssage. ;; TODO : Penser a ajouter une table des opcodes -(defvar table-operateurs +(defvar *table-operateurs* '(load store move add sub mult div incr decr push pop jmp jsr rtn cmp jeq jpg jpp jpe jge jne nop halt)) -(defvar table-modes-adressage +(defvar *table-modes-adressage* '(constant direct registre indexé indirect indirect-registre indirect-indexé)) ;; Fonctions de manipulation de bits : @@ -83,12 +75,12 @@ (cadr rest)) (cddr rest)))) -(defvar nb-operateurs (length table-operateurs)) -(defvar nb-modes-adressage (length table-modes-adressage)) -(defvar nb-opcode-bytes - (ceiling (/ (+ (integer-length (+ 1 nb-operateurs)) +(defvar *nb-operateurs* (length *table-operateurs*)) +(defvar *nb-modes-adressage* (length *table-modes-adressage*)) +(defvar *nb-opcode-bytes* + (ceiling (/ (+ (integer-length (+ 1 *nb-operateurs*)) (* 2 - (integer-length (+ 1 nb-modes-adressage)))) + (integer-length (+ 1 *nb-modes-adressage*)))) ;; On divise par 8 car 8 bits dans un byte. 8))) @@ -103,11 +95,11 @@ (defun isn-encode (instruction) (loop for (operateur mode-adressage-1 valeur-1 mode-adressage-2 valeur-2) = instruction - return (list (append-bits (position1 operateur table-operateurs) - nb-modes-adressage - (position1 mode-adressage-1 table-modes-adressage) - nb-modes-adressage - (position1 mode-adressage-2 table-modes-adressage)) + return (list (append-bits (position1 operateur *table-operateurs*) + *nb-modes-adressage* + (position1 mode-adressage-1 *table-modes-adressage*) + *nb-modes-adressage* + (position1 mode-adressage-2 *table-modes-adressage*)) (if (eq mode-adressage-1 'registre) (position1 valeur-1 (get-register-list (make-vm 1))) valeur-1)