commit eed75e446c555f126eab5da132227fcc06ee6ef7
parent 78b4ccfd0b5aa468700b74c73a391f7c5c199c7d
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Wed, 12 Jan 2011 14:09:19 +0100
Début compilation + ** autour des defvar
Diffstat:
5 files changed, 156 insertions(+), 82 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -1,9 +1,9 @@
-;; all-tests : <module-struct>
+;; *all-tests* : <module-struct>
;; <module-struct> : (<alist-of-submodules> executed-bit variables tests)
;; <alist-of-submodules> : ((nom-module . <module-struct>) (nom-module2 . <module>) ...)
-(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
@@ -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)
