commit dd3fc72bf1e6d9bc6a5287947f53733f8c087b71
parent d762ba533b5ec0fa6dbf5504fcc786388afc0a64
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Sun, 19 Dec 2010 18:53:45 +0100
Création du dossier lisp à côté de scheme (partie 2)
Diffstat:
4 files changed, 44 insertions(+), 45 deletions(-)
diff --git a/lisp/main.lisp b/lisp/main.lisp
@@ -5,10 +5,9 @@
(load "util")
(load "test-unitaire")
-(load "instructions")
+(load "vm")
(load "match")
-(load "lisp2li")
-(load "meval")
-(load "implementation/mini-meval")
+(load "mini-meval")
+(load "squash-lisp")
(provide 'main)
\ No newline at end of file
diff --git a/lisp/mini-meval.lisp b/lisp/mini-meval.lisp
@@ -418,26 +418,13 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
(when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't set ~w : it is a constant." name))
(push-global! etat name 'variable (mini-meval value etat))))
real-value))
- ((function :name $$)
- (let ((definition (assoc-etat name 'function etat)))
- (if definition
- (cdr definition)
- (mini-meval-error expr etat "Undefined function : ~w." name))))
- ;; TODO : #'(lambda ...)
- ((funcall :name _ :params _*)
- (apply (mini-meval name etat)
- (mapcar (lambda (x) (mini-meval x etat)) params)))
- ((apply :name _ :p1 _ :params _*)
- (let ((fun (mini-meval name etat))
- (args (mapcar (lambda (x) (mini-meval x etat)) (cons p1 params))))
- (apply fun (append (butlast args) (car (last args))))))
((declaim _*)
nil)
((error :format _ :args _*)
(error "mini-meval : fonction error appellée par le code, le message est :~&~w" (apply #'format nil format args)))
((warn :format _ :args _*)
(warn "mini-meval : fonction warn appellée par le code, le message est :~&~w" (apply #'format nil format args)))
- ((go :target $$)
+ ((go :target (? or symbolp numberp))
(when (null target)
(mini-meval-error expr etat "nil ne peut pas être une étiquette pour un go."))
(let ((association (assoc `(,target . tagbody-tag) (etat-local etat) :test #'equal)))
@@ -471,8 +458,20 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
(push-local etat block-name 'block-name (lambda (x) (return-from block-catcher x))))))
((quote :val _)
val)
+ ((function :name $$)
+ (let ((definition (assoc-etat name 'function etat)))
+ (if definition
+ (cdr definition)
+ (mini-meval-error expr etat "Undefined function : ~w." name))))
((function :fun (lambda _ . _))
(mini-meval fun etat))
+ ((funcall :name _ :params _*)
+ (apply (mini-meval name etat)
+ (mapcar (lambda (x) (mini-meval x etat)) params)))
+ ((apply :name _ :p1 _ :params _*)
+ (let ((fun (mini-meval name etat))
+ (args (mapcar (lambda (x) (mini-meval x etat)) (cons p1 params))))
+ (apply fun (append (butlast args) (car (last args))))))
#| Traitement des appels de fonction |#
((:lambda (lambda @ _*) :params _*)
#| - Si c'est une fonction anonyme, on l'exécute. |#
@@ -559,13 +558,14 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
(mini-meval '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) etat)
'(3 4 7 7))
-(deftest (mini-meval let-nil)
- (mini-meval '(let (a (x 3) y) (list a x y)) etat)
- '(nil 3 nil))
+;; TODO
+;; (deftest (mini-meval let-nil)
+;; (mini-meval '(let (a (x 3) y) (list a x y)) etat)
+;; '(nil 3 nil))
-(deftest (mini-meval let-nil)
- (mini-meval '(let* ((x 4) y (z 5)) (list a x y)) etat)
- '(4 nil 5))
+;; (deftest (mini-meval let-nil)
+;; (mini-meval '(let* ((x 4) y (z 5)) (list a x y)) etat)
+;; '(4 nil 5))
(deftest (mini-meval progn)
(mini-meval '(progn 1 2 3 4) etat)
@@ -736,7 +736,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
1)
(deftest (mini-meval tagbody)
- (mini-meval '(tagbody foo (list 1) 42 (list 2) baz (list 3)))
+ (mini-meval '(tagbody foo (list 1) 42 (list 2) baz (list 3)) etat)
nil)
(deftest (mini-meval block)
diff --git a/lisp/squash-lisp.lisp b/lisp/squash-lisp.lisp
@@ -1,4 +1,4 @@
-(require 'mini-meval "implementation/mini-meval")
+(require 'mini-meval "mini-meval")
(require 'match "match")
;; TODO : emballer le résultat de squash-lisp dans un (macrolet ...) pour les "special-operator" qu'on rajoute.
@@ -422,22 +422,22 @@ On a donc une pile de cette forme (les vieilles données sont en haut) :
+;; TODO : D'où sort ce commentaire !?! Probablement faux.
+;; ;; => Si la variable n'existe pas (globale donc)
+;; ;; => la pusher dans l'env-var le plus haut
+;; (set-var var val)
+;; => transformer val dans env-var env-fun
+;; résultat := (maybe-set-indirection var val)
+;; => si la variable n'est pas capturée,
+;; - push résultat sur la l'entrée de la variable dans env-var.
+;; => si la variable est capturée,
+;; - ajouter la variable aux captures de chaque niveau entre sa définition et le niveau courant (?)
+;; - transformer tous les (maybe-*-indirection var) en (*-indirection var) dans l'entrée de la variable dans env-var
+;; renvoyer expr
- ;; => Si la variable n'existe pas (globale donc)
- ;; => la pusher dans l'env-var le plus haut
-(set-var var val)
-=> transformer val dans env-var env-fun
-résultat := (maybe-set-indirection var val)
-=> si la variable n'est pas capturée,
- - push résultat sur la l'entrée de la variable dans env-var.
-=> si la variable est capturée,
- - ajouter la variable aux captures de chaque niveau entre sa définition et le niveau courant (?)
- - transformer tous les (maybe-*-indirection var) en (*-indirection var) dans l'entrée de la variable dans env-var
-renvoyer expr
-
-(funcall fun args*)
-=> transformer les args* dans env-var env-fun
-=> renvoyer (closure-call-fun (cdr (assoc fun env-fun)) args*)
+;; (funcall fun args*)
+;; => transformer les args* dans env-var env-fun
+;; => renvoyer (closure-call-fun (cdr (assoc fun env-fun)) args*)
@@ -465,7 +465,7 @@ renvoyer expr
(unique-sym nil)
(let* (eq type 'let*)))
;; => Pour chaque binding
- (dolist* ((n name) v value)
+ (dolist* ((n name) (v value))
;; => On crée un symbole unique pour représenter cette liaison
(setq unique-sym (make-symbol (string n)))
;; => ajouter unique-sym dans le simple-let qu'on crée
@@ -653,11 +653,11 @@ renvoyer expr
(push var (caar e))
;; => On transforme tous les (get-var var) en (get-var-indirection var)
(dolist (reference-get (fourth variable))
- (setf (car reference-get 'get-var-indirection)))
+ (setf (car reference-get) 'get-var-indirection))
(setf (fourth variable) nil)
;; => On transforme tous les (setq var val) en (setq-indirection var val)
(dolist (reference-set (fifth variable))
- (setf (car reference-set 'setq-indirection)))
+ (setf (car reference-set) 'setq-indirection))
(setf (fifth variable) nil))))
;; => Sinon, ce n'est pas (encore) une capture
;; => push résultat sur l'entrée de la variable dans env-var.
diff --git a/lisp/vm.lisp b/lisp/vm.lisp
@@ -276,4 +276,4 @@
(get-memory vm (get-register vm 'SP)))
t-r1-value)
-(provide 'instructions)
+(provide 'vm)
