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

Correction de quelques bugs.

Browse Source
This commit is contained in:
Georges Dupéron 2010-11-20 01:09:43 +01:00
parent cab12e533a
commit 5aabdd03c8
4 changed files with 76 additions and 57 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
implementation/mini-meval.lisp
View File

@ -285,7 +285,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
(error "mini-meval : fonction error appellée par le code, le message est :~&~w" (apply #'format nil format args)))
((go :target $$)
(when (null target)
(min-meval-error expr etat-global etat-local "mini-meval : nil ne peut pas être une étiquette pour un return-from."))
(mini-meval-error expr etat-global etat-local "mini-meval : nil ne peut pas être une étiquette pour un return-from."))
(let ((association (assoc* `(,target . tagbody-tag) #'equal etat-local etat-global)))
(if association
(funcall (cdr association))

82
lisp2li.lisp
View File

@ -10,9 +10,11 @@
;; ,@
(defvar my-unquote-unsplice nil);(caaadr '`(,@a)))
(declaim (ftype function lisp2li)) ;; Double récursion map-lisp2li / lisp2li.
(defun map-lisp2li (expr env)
(mapcar (lambda (x) (lisp2li x env)) expr))
(declaim (ftype function make-stat-env1)) ;; Double récursion make-stat-env1 / make-stat-env-optional
(defun make-stat-env-optional (params env position num-env)
(cond ((endp params)
env)
@ -36,17 +38,18 @@
`((,(caar env) ,(+ 1 (cadar env)) ,(caddar env))
. ,(recalculation (cdr env))))))
(defun make-stat-env1 (params &optional env (position 1) num-env)
(cond ((endp params)
env)
((eq '&optional (car params))
(make-stat-env-optional (cdr params) env position num-env))
((eq '&rest (car params))
(make-stat-env1 (cdr params) env position num-env))
(T
`((,(car params) 0 ,position)
. ,(make-stat-env1 (cdr params) env (+ 1 position) num-env)))))
(defun make-stat-env (params &optional env (position 1))
(defun make-stat-env1 (params &optional env (position 1) num-env)
(cond ((endp params)
env)
((eq '&optional (car params))
(make-stat-env-optional (cdr params) env position num-env))
((eq '&rest (car params))
(make-stat-env1 (cdr params) env position num-env))
(T
`((,(car params) 0 ,position)
. ,(make-stat-env1 (cdr params) env (+ 1 position) num-env)))))
(make-stat-env1 params (recalculation env) position 0))
(defun transform-quasiquote (expr)
@ -73,16 +76,17 @@
`(cons ,(transform-quasiquote (car expr))
,(transform-quasiquote (cdr expr))))))
(defun get-nb-params-t (params r)
(cond ((endp params)
r)
((or (eq '&optional (car params))
(eq '&rest (car params)))
(get-nb-params-t (cdr params) r))
(T
(get-nb-params-t (cdr params) (+ 1 r)))))
(defun get-nb-params (params)
"Renvoie le nombre exact de paramètres sans les &optional et &rest"
(defun get-nb-params-t (params r)
(cond ((endp params)
r)
((or (eq '&optional (car params))
(eq '&rest (car params)))
(get-nb-params-t (cdr params) r))
(T
(get-nb-params-t (cdr params) (+ 1 r)))))
(get-nb-params-t params 0))
(defun implicit-progn (expr)
@ -246,6 +250,9 @@ par le compilateur et par l’interpréteur"
;; declaim
((eq 'declaim (car expr))
(cons :const nil))
;; the
((eq 'the (car expr))
(lisp2li (third expr)))
;; macros
((macro-function (car expr))
(lisp2li (macroexpand-1 expr) env))
@ -502,25 +509,28 @@ par le compilateur et par l’interpréteur"
(:const . 3)
(:const . 4))))
(deftest (lisp2li macro)
(lisp2li '(cond ((eq (car '(1 2 3)) 1) T)
((eq (car '(1 2 3)) 2) 2)
(T nil))
())
'(:if (:call eq (:call car (:const 1 2 3)) (:const . 1))
(:const . T)
(:if (:call eq (:call car (:const 1 2 3)) (:const . 2))
(:const . 2)
(:const . nil))))
;; TODO : on ne peut pas faire de tests sur des macros qu'on n'a pas implémentées nous-mêmes,
;; car sinon le résultat dépend de l'implémentation.
(deftest (lisp2li macro)
(lisp2li '(and (eq (car '(1 2)) 1)
T)
())
'(:if (:call not
(:call eq (:call car (:const 1 2)) (:const . 1)))
(:const . nil)
(:const . T)))
;; (deftest (lisp2li macro)
;; (lisp2li '(cond ((eq (car '(1 2 3)) 1) T)
;; ((eq (car '(1 2 3)) 2) 2)
;; (T nil))
;; ())
;; '(:if (:call eq (:call car (:const 1 2 3)) (:const . 1))
;; (:const . T)
;; (:if (:call eq (:call car (:const 1 2 3)) (:const . 2))
;; (:const . 2)
;; (:const . nil))))
;; (deftest (lisp2li macro)
;; (lisp2li '(and (eq (car '(1 2)) 1)
;; T)
;; ())
;; '(:if (:call not
;; (:call eq (:call car (:const 1 2)) (:const . 1)))
;; (:const . nil)
;; (:const . T)))
(deftest (lisp2li let)
(lisp2li '(let ((x 1) (y 2))

47
meval.lisp
View File

@ -5,15 +5,16 @@
0
(+ 1 (env-size (aref env 0)))))
(defun get-env-num-r (num env counter)
(cond ((or (equalp env #()) (eq env nil))
env)
((= num counter)
env)
(T
(get-env-num-r num (aref env 0) (- counter 1)))))
(defun get-env-num (num env)
"Récupère l’environnement correspondant à celui souhaité."
(defun get-env-num-r (num env counter)
(cond ((or (equalp env #()) (eq env nil))
env)
((= num counter)
env)
(T
(get-env-num-t num (aref env 0) (- counter 1)))))
(get-env-num-r num env (- (env-size env) 1)))
(defun current-env (env)
@ -31,19 +32,21 @@
env
(get-lower-env (aref env 0))))
(defun make-rest-lower-env (lower-env pos values pos-rest)
(cond ((= pos pos-rest)
(setf (aref lower-env pos) values))
(T
(setf (aref lower-env pos) (car values))
(make-rest-lower-env lower-env
(+ pos 1)
(cdr values)
pos-rest))))
(defun make-rest (env values &optional (pos-rest 1))
"Construit l'environnement en rajoutant tous les valeurs
du &rest dans une cellule de l'env sous forme d'une liste"
(let ((size (- (array-total-size env) 1)))
(defun make-rest-lower-env (lower-env pos values)
(cond ((= pos pos-rest)
(setf (aref lower-env pos) values))
(T
(setf (aref lower-env pos) (car values))
(make-rest-lower-env lower-env
(+ pos 1)
(cdr values)))))
(make-rest-lower-env env 1 values))
(make-rest-lower-env env 1 values pos-rest))
env)
(defun make-env (size list-values env &optional pos-rest)
@ -59,8 +62,8 @@ du &rest dans une cellule de l'env sous forme d'une liste"
(error "Too few arguments"))
(T
(if (= (array-total-size new-env) 0)
(setf new-env (make-array (+ 1 size)))
(setf (aref (get-lower-env new-env) 0) (make-array (+ 1 size))))
(setf new-env (make-array (+ 1 size) :initial-element nil))
(setf (aref (get-lower-env new-env) 0) (make-array (+ 1 size) :initial-element nil)))
(let ((lower-env (get-lower-env new-env)))
(if pos-rest
(make-rest lower-env
@ -73,6 +76,8 @@ du &rest dans une cellule de l'env sous forme d'une liste"
)))
new-env))))
(declaim (ftype function meval)) ;; Récursion mutuelle meval / map-meval + meval-body + meval-args + meval-lambda + msetf
(defun map-meval (list env)
(mapcar (lambda (x) (meval x env)) list))
@ -287,6 +292,10 @@ d’arguments dans un certain environnement."
(meval (lisp2li '(setf x 42) '((x 0 1))) env)
env)
#(() 42)
#'equalp)
;; Pour une raison totalement inexplicable, ce test fail avec #'equalp sous sbcl
;; alors que les deux objets sont equalp en dehors du test (si on les met dans deux
;; variable globale pour tester après). Pour l'instant, cette fonction suffira.
(lambda (x y)
(every #'identity (map 'list (lambda (x y) (or (eq x y) (and (numberp x) (numberp y) (= x y)))) x y))))
(provide 'meval)

2
test-unitaire.lisp
View File

@ -28,7 +28,7 @@
(cdr (assoc (car module) (car from)))))))
(defun test-get-variables-and-above (module &optional (from all-tests))
(apply #'append (mapcar #'reverse (test-collect-down-tree #'third module from))))
(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))