commit 017f4e0d02fc4cc1605b3e99994892a62848a272
parent f914ed3bf61f016bb7348563c1030a737e43b3e0
Author: Georges Dupéron <jahvascriptmaniac+github@free.fr>
Date: Sat, 6 Nov 2010 23:41:23 +0100
Merge branch 'master' of github:dumbs/2010-m1s1-compilation
Diffstat:
| M | lisp2li.lisp | | | 118 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++------------------------ |
| M | meval.lisp | | | 223 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++---------- |
| M | util.lisp | | | 45 | +++++++++++++++++++++++++++++++++++++-------- |
3 files changed, 316 insertions(+), 70 deletions(-)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -11,33 +11,31 @@
(defun map-lisp2li (expr env)
(mapcar (lambda (x) (lisp2li x env)) expr))
-(defun m-macroexpand-1 (macro)
- ())
-
-(defmacro get-defun (symb)
- `(get ,symb :defun))
-
-(defun set-defun (li)
- (setf (get-defun (cdaddr li))
- (cdddr li)))
-
-(defmacro get-defmacro (symb)
- `(get ,symb :defmacro))
-
-(defun set-defmacro (li)
- (setf (get-defmacro (cdaddr li))
- (cdddr li)))
-
-(defun make-stat-env (params &optional env)
- (append
- (loop
- for var in (remove '&optional (remove '&rest params))
- for num-env = (+ (or (second (first env)) -1) 1)
- for position = 1 then (+ position 1)
- unless (member var '(&optional &rest))
- collect (list var num-env position))
- env))
-
+(defun make-stat-env-optional (params env position num-env)
+ (cond ((endp params)
+ env)
+ ((consp (car params))
+ `((,(caar params) ,num-env ,position)
+ (,(intern (format nil "~a-P" (caar params))) ,num-env ,(+ 1 position))
+ . ,(make-stat-env-optional (cdr params) env (+ 2 position) num-env)))
+ ((eq '&rest (car params))
+ (make-stat-env (cdr params) env position num-env))
+ (T
+ `((,(car params) ,num-env ,position)
+ . ,(make-stat-env-optional (cdr params) env (+ 1 position) num-env)))))
+
+(defun make-stat-env (params &optional env (position 1) num-env)
+ (unless num-env (setq num-env (+ (or (second (first env)) -1) 1)))
+ (cond ((endp params)
+ env)
+ ((eq '&optional (car params))
+ (make-stat-env-optional (cdr params) env position num-env))
+ ((eq '&rest (car params))
+ (make-stat-env (cdr params) env position num-env))
+ (T
+ `((,(car params) ,num-env ,position)
+ . ,(make-stat-env (cdr params) env (+ 1 position))))))
+
(defun transform-quasiquote (expr)
(cond
;; a
@@ -61,7 +59,24 @@
(T
`(cons ,(transform-quasiquote (car expr))
,(transform-quasiquote (cdr expr))))))
-
+
+(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)
+ (if (n-consp 2 expr)
+ (cons 'progn expr)
+ (car expr)))
+
(defun lisp2li (expr env)
"Convertit le code LISP en un code intermédiaire reconnu
par le compilateur et par l’interpréteur"
@@ -76,10 +91,15 @@ par le compilateur et par l’interpréteur"
`(:cvar ,(cadr cell) ,(caddr cell))
(error "Variable ~S unknown" expr))))
;; lambda solitaire ex: (lambda (x) x)
- ((eq 'lambda (car expr))
- `(:lclosure . ,(cons (length (second expr))
- (lisp2li (third expr)
- (make-stat-env (second expr))))))
+ ((eq 'lambda (car expr)) ;; TODO : ameliorer le cas du lambda
+ (if (member '&rest (second expr))
+ `(:lclosure . (,(get-nb-params (second expr))
+ ,(+ 1 (mposition '&rest (second expr)))
+ ,(lisp2li (implicit-progn (cddr expr))
+ (make-stat-env (second expr) env))))
+ `(:lclosure . ,(cons (get-nb-params (second expr))
+ (lisp2li (implicit-progn (cddr expr))
+ (make-stat-env (second expr) env))))))
;; lambda ex: ((lambda (x) x) 1)
((and (consp (car expr))
(eq 'lambda (caar expr)))
@@ -125,6 +145,9 @@ par le compilateur et par l’interpréteur"
;; progn
((eq 'progn (car expr))
(cons :progn (map-lisp2li (cdr expr) env)))
+ ;; declaim
+ ((eq 'declaim (car expr))
+ (cons :const nil))
;; macros
((macro-function (car expr))
(lisp2li (macroexpand expr) env))
@@ -189,8 +212,8 @@ par le compilateur et par l’interpréteur"
'(:if (:const . T) (:const . T) (:const . nil)))
(deftest (lisp2li defun)
- (lisp2li '(defun foo (x) x) ())
- '(:mcall set-defun (:const . foo) (:lclosure 1 :cvar 0 1)))
+ (lisp2li '(defun bar (x) x) ())
+ '(:mcall set-defun (:const . bar) (:lclosure 1 :cvar 0 1)))
(deftest (lisp2li defun)
(lisp2li '(defun foo (x y z) (list x y z)) ())
@@ -224,9 +247,32 @@ par le compilateur et par l’interpréteur"
(:cvar 0 3))
(:const . 1) (:const . 2) (:const . 3)))
+(deftest (lisp2li lambda)
+ (lisp2li `(lambda (x y z) (list x y z)) ())
+ '(:lclosure 3 :call list
+ (:cvar 0 1)
+ (:cvar 0 2)
+ (:cvar 0 3)))
+
+(deftest (lisp2li lambda)
+ (lisp2li `(lambda (x y z) (list x y z) (+ x y)) ())
+ '(:lclosure 3 :progn (:call list
+ (:cvar 0 1)
+ (:cvar 0 2)
+ (:cvar 0 3))
+ (:call +
+ (:cvar 0 1)
+ (:cvar 0 2))))
+
+(deftest (lisp2li rest)
+ (lisp2li `(lambda (x &rest y) (cons x y)) ())
+ '(:lclosure 2 2 (:call cons
+ (:cvar 0 1)
+ (:cvar 0 2))))
+
(deftest (lisp2li unknown)
- (lisp2li '(foo 3) ())
- '(:unknown (foo 3) ()))
+ (lisp2li '(bar 3) ())
+ '(:unknown (bar 3) ()))
(deftest (lisp2li function)
(lisp2li '#'car ())
diff --git a/meval.lisp b/meval.lisp
@@ -1,41 +1,212 @@
-(defun meval (expr env)
+(setq *debug* nil)
+(load "match")
+
+(defun get-env-num (num env)
+ (format *debug* "~&get-env-num ~&~T=> num = ~a ~&~T=> env = ~a" num env)
+ (defun get-env-num-t (num env counter)
+ (format *debug* "~&get-env-num-t ~&~T=> num = ~a ~&~T=> env = ~a ~&~T=> counter = ~a" num env counter)
+ (cond ((= counter num) env)
+ ((eq (aref env 0) nil) nil)
+ (T
+ (get-env-num-t num (aref env 0) (+ 1 counter))
+ )))
+ (get-env-num-t num env 0))
+
+(defun get-lower-env (env)
+ (format *debug* "~&get-lower-env ~&~T=> env = ~a" env)
+ (if (or (= (array-total-size env) 0)
+ (eq (aref env 0) nil))
+ env
+ (get-lower-env (aref env 0))))
+
+(defun make-env (size list-values env)
+ "Construit un nouvel environnement de taille <size> dans <env>
+et remplie ce nouvelle environnement avec les valeurs contenu dans
+<list-values>"
+ (format *debug* "~&make-env ~&~T=> size = ~a ~&~T=> list-value = ~a ~&~T=> env = ~a" size list-values env)
+ (if (= (array-total-size env) 0)
+ (setf env (make-array (+ 1 size)))
+ (setf (aref (get-lower-env env) 0) (make-array (+ 1 size))))
+ (let ((lower-env (get-lower-env env)))
+ (format *debug* "~&(make-env let) ~&~T=> lower-env = ~a" lower-env)
+ (loop
+ for value in list-values
+ for rank = 1 then (+ rank 1)
+ do (setf (aref lower-env rank) value)
+ ))
+ env)
+
+(defun map-meval (list env)
+ (format *debug* "~&map-meval ~&~T=> list = ~a ~&~T=> env = ~a" list env)
+ (mapcar (lambda (x) (meval x env)) list))
+
+(defun meval-progn (list env)
+ "Mevalue toutes les sous expressions et renvoie
+la valeur de la dernier"
+ (format *debug* "~&meval-progn ~&~T=> list = ~a ~&~T env = ~a" list env)
+ (if (endp list)
+ nil
+ (if (endp (cdr list))
+ (meval (car list) env)
+ (progn
+ (meval (car list) env)
+ (meval-progn (cdr list) env)))))
+
+(defun modify-lower-env (lower-env value pos)
+ (format *debug* "~&modify-lower-env ~&~T=> lower-env = ~a ~&~T=> value = ~a ~&~T=> pos = ~a" lower-env value pos)
+ (let ((env-bis (make-array (+ pos 1))))
+ (defun construct-new-lower-env (new-env old-env)
+ (format *debug* "~&construct-new-lower-env ~&~T=> new-env = ~a ~&~T=> old-env = ~a" new-env old-env)
+ (loop
+ for i = 0 then (+ i 1)
+ do (setf (aref new-env i) (aref old-env i))
+ while (<= i (- pos 1))
+ ))
+ (setf (aref lower-env pos) value)
+ (construct-new-lower-env env-bis lower-env)
+ (format *debug* "~&modify-lower-env ~&~T env-bis = ~a" env-bis)
+ (setf lower-env env-bis)
+ ))
+
+(defun make-rest (env &optional (pos-rest 1))
+ (format *debug* "~&make-rest ~&~T=> env = ~a ~&~T=> pos-rest = ~a" env pos-rest)
+ (let* ((lower-env (get-lower-env env))
+ (size (- (if (= 0 (array-total-size lower-env))
+ 1
+ (array-total-size lower-env))
+ 1)))
+ (defun make-rest-lower-env (lower-env pos)
+ (format *debug* "~&make-rest-lower-env ~&~T=> lower-env = ~a ~&~T=> pos = ~a ~&~T=> size = ~a" lower-env pos size)
+ (cond ((>= pos size)
+ (cons (aref lower-env pos) nil))
+ ((< pos pos-rest)
+ (make-rest-lower-env lower-env (+ pos 1)))
+ (T
+ (cons (aref lower-env pos)
+ (make-rest-lower-env lower-env (+ pos 1))))))
+ (modify-lower-env (get-lower-env env) (make-rest-lower-env (get-lower-env env) pos-rest) pos-rest)
+ (format *debug* "~&make-rest ~&~T=> lower-env = ~a" (get-lower-env env)))
+ env)
+
+(defun meval (expr &optional (env #()))
"Interprète le langage intermédiaire passé en paramètre."
- (cond ((eq ':lit (first expr))
+ (format *debug* "~&meval ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
+ (cond ((match :const (first expr))
+ (format *debug* "~&(meval :const) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
(cdr expr))
- ((eq ':var (first expr))
- (let ((cell (get-binding env (cdr expr))))
- (if cell
- (cdr cell)
- (error "The variable ~S is unbound" (cdr expr)))))
- ((eq ':if (car expr))
+ ((match :cvar (first expr))
+ (format *debug* "~&(meval :cvar) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
+ (let ((sub-env (get-env-num (second expr) env)))
+ (if sub-env
+ (aref sub-env (third expr))
+ (error "The variable ~S is unbound" expr))))
+ ((match :if (first expr))
+ (format *debug* "~&(meval :if) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
(if (meval (second expr) env)
(meval (third expr) env)
(meval (fourth expr) env)))
- ((eq ':call (first expr))
- (apply (second expr) (map-meval (cddr expr) env)))
- ))
-
-(defun map-meval (list env)
- (mapcar (lambda (x) (meval x env)) list))
-
-(defun foo (x) x)
+ ((match :call (first expr))
+ (format *debug* "~&(meval :call) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
+ (apply (symbol-function (cadr expr)) (map-meval (cddr expr) env)))
+ ((match :mcall (first expr))
+ (format *debug* "~&(meval :mcall) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
+ (if (consp (second expr))
+ (let ((closure (second expr)))
+ (format *debug* "~&~T=> closure = ~a" closure)
+ (cond ((and (atom (third closure))
+ (constantp (third closure))
+ (integerp (third closure)))
+ (meval closure
+ (make-rest (make-env (length (cddr expr))
+ (map-meval (cddr expr) env)
+ env)
+ (caddr closure))))
+ (T
+ (cond ((< (second closure) (length (cddr expr)))
+ (error "Too arguments"))
+ ((> (second closure) (length (cddr expr)))
+ (error "Too few arguments"))
+ (T
+ (meval closure
+ (make-env (second closure)
+ (map-meval (cddr expr)env)
+ env)))))))
+ (error "form not yet implemented")))
+ ((match :progn (first expr))
+ (format *debug* "~&(meval :progn) ~&~T=> expr = ~a ~&~T=> env = ~a" expr env)
+ (meval-progn (cdr expr) env))
+ ((match :lclosure (first expr))
+ (format *debug* "~&(meval :lclosure) ~&~T=> expr = ~a~&~T=> env = ~a" expr env)
+ (if (and (atom (caddr expr))
+ (constantp (caddr expr))
+ (integerp (caddr expr)))
+ (meval-progn (cdddr expr) env)
+ (meval-progn `(,(cddr expr)) env)))
+ (T
+ (error "form special ~S not yet implemented" (car expr)))))
;; Test unitaire
(load "test-unitaire")
+(load "lisp2li")
(erase-tests meval)
-(deftest meval
- (meval '(:lit . 3) ())
+(deftest (meval :const)
+ (meval (lisp2li 3 ()))
3)
-(deftest meval
- (meval '(:var . x) '(("TEST" (s . ()) (z . 4) (x . 5) (u . 6))))
+(deftest (meval quote)
+ (meval (lisp2li '3 ()))
+ 3)
+
+(deftest (meval quote)
+ (meval (lisp2li ''3 ()))
+ 3)
+
+(deftest (meval quote)
+ (meval (lisp2li '''3 ()))
+ ''3)
+
+(deftest (meval :cvar)
+ (meval (lisp2li 'x '((x 0 2))) #(() 4 5 6))
5)
-(deftest meval
- (meval '(:var . s2) '(("TEST" (s . ()) (s1 . 7) (s2 . 8))
- ("TOP-LEVEL" (x . 4) (x1 . 5) (x2 . 6))))
+(deftest (meval :cvar)
+ (meval '(:cvar 1 2) #(#(() 7 8) 4 5 6))
8)
-(deftest meval
- (meval '(:call + (:lit . 3) (:var . x)) '(("TOP-LEVEL" (x1 . 4) (x . 5) (z . 6))))
- 8)
+(deftest (meval :call)
+ (meval '(:call + (:const . 3) (:cvar 0 1)) #(() 4 5 6))
+ 7)
+
+(deftest (meval :call)
+ (meval '(:call list (:const . 3) (:const . 2)))
+ '(3 2))
+
+(deftest (meval :if)
+ (meval '(:if (:const . T)
+ (:const . T)
+ (:const . nil)))
+ T)
+
+(deftest (meval :if)
+ (meval '(:if (:call eq (:const . 1)
+ (:cvar 0 1))
+ (:const . T)
+ (:const . nil)) #(() 1 2 3))
+ T)
+
+(deftest (meval :mcall :lclosure)
+ (meval (lisp2li '((lambda (x y) (cons x y)) 1 2) ()))
+ '(1 . 2))
+
+(deftest (meval :mcall :lclosure)
+ (meval (lisp2li '((lambda (x &rest y) (cons x y)) 1 2 3 4) ()))
+ '(1 2 3 4))
+
+(deftest (meval defun)
+ (meval '(defun foo (x) x))
+ foo)
+
+(deftest (meval defun)
+ (meval '(defun foo (x y z) (list x y z)))
+ foo)
+
diff --git a/util.lisp b/util.lisp
@@ -57,12 +57,40 @@
(shift ,(count-if (lambda (x) (eq x :skip)) params)
actual-params))))
-(defun readfile (name)
+(defun mload (name)
(let ((fd (open name)))
- `(progn
- ,(loop
- for line = (read fd nil 'eof)
- when (not (eq line 'eof))
- do (cons line nil)
- else return (close fd)
- ))))
+ (cons 'progn
+ (loop
+ for line = (read fd nil 'eof)
+ while (not (eq line 'eof))
+ collect line
+ finally (close fd)
+ ))))
+
+(defun m-macroexpand-1 (macro)
+ ())
+
+(defmacro get-defun (symb)
+ `(get ,symb :defun))
+
+(defun set-defun (symb expr)
+ (setf (get-defun (cdaddr li))
+ (cdddr li)))
+
+(defmacro get-defmacro (symb)
+ `(get ,symb :defmacro))
+
+(defun set-defmacro (li)
+ (setf (get-defmacro (cdaddr li))
+ (cdddr li)))
+
+(defun mposition (symb list)
+ (defun mposition-t (symb list counter)
+ (cond ((endp list) nil)
+ ((eq symb (car list)) counter)
+ ((or (eq (car list) '&optional)
+ (eq (car list) '&rest))
+ (mposition-t symb (cdr list) counter))
+ (T
+ (mposition-t symb (cdr list) (+ 1 counter)))))
+ (mposition-t symb list 0))
+\ No newline at end of file
