Début compilation + ** autour des defvar
This commit is contained in:
Georges Dupéron
parent
78b4ccfd0b
commit
eed75e446c
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
32
lisp/vm.lisp
32
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user