commit 43c4b6ae388ce37941e795eb88f6153ec278ce98
parent 74fea3397cf6fc3162951e6146ba200faed452b3
Author: Bertrand BRUN <bertrand.brun@me.com>
Date: Mon, 8 Nov 2010 14:37:42 +0100
Merge branch 'master' of https://github.com/dumbs/2010-m1s1-compilation
Conflicts:
lisp2li.lisp
Diffstat:
| M | implementation/types.lisp | | | 2 | ++ |
| M | instructions.lisp | | | 49 | +++++++++++++++++++++++-------------------------- |
| M | lisp2li.lisp | | | 534 | ++++++++++++++++++++++++++++++++++++++++++------------------------------------- |
| M | match.lisp | | | 818 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++------------ |
| A | meval-fascicule.lisp | | | 989 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | meval.lisp | | | 274 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------- |
| M | test-unitaire.lisp | | | 36 | +++++++++++++++++++++++++++++++++--- |
| M | util.lisp | | | 100 | ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++- |
8 files changed, 2372 insertions(+), 430 deletions(-)
diff --git a/implementation/types.lisp b/implementation/types.lisp
@@ -1,3 +1,5 @@
+;; CLTL 2 et 2.15
+
;; TODO : est-ce que cette fonction existe ?
(defun tp (x) t)
diff --git a/instructions.lisp b/instructions.lisp
@@ -63,14 +63,15 @@
(defun position1 (x l) (+ 1 (position x l)))
-(defun split-bytes (n nb-bytes append)
- "Découpe N en plusieurs valeurs inférieures à 256,
-en renvoyant une liste de longueur NB-BYTES,
-et termine par la liste APPEND."
- (if (<= nb-bytes 0)
- append
- (cons (ldb (byte 8 (* 8 (- nb-bytes 1))) n)
- (split-bytes n (- nb-bytes 1) append))))
+;; TODO : faire une fonction (append-bits n1 size2 n2 size3 n3 ... sizen nn)
+
+(defun append-bits (&optional (n1 0) &rest rest)
+ (if (endp rest)
+ n1
+ (apply #'append-bits
+ (logior (ash n1 (car rest))
+ (cadr rest))
+ (cddr rest))))
(defvar nb-operateurs (length table-operateurs))
(defvar nb-modes-adressage (length table-modes-adressage))
@@ -88,25 +89,21 @@ et termine par la liste APPEND."
;; '(operateur mode-adressage-1 valeur-1 mode-adressage-2 valeur-2)
;; Si l'instruction ne prend qu'un (ou zéro) paramètre, les champs
;; correspondants sont mis à nil.
-;; TODO : encoder en entier les registres de valeur-1 et valeur-2.
+
(defun isn-encode (instruction)
- (let ((operateur (first instruction))
- (mode-adressage-1 (second instruction))
- (valeur-1 (third instruction))
- (mode-adressage-2 (fourth instruction))
- (valeur-2 (fifth instruction)))
- (let* ((opcode (position1 operateur table-operateurs))
- (opcode (ash opcode nb-modes-adressage))
- (opcode (logior opcode (position1 mode-adressage-1 table-modes-adressage)))
- (opcode (ash opcode nb-modes-adressage))
- (opcode (logior opcode (position1 mode-adressage-2 table-modes-adressage))))
- (split-bytes opcode nb-opcode-bytes
- (list (if (eq mode-adressage-1 'registre)
- (position1 valeur1 (get-register-list (make-vm 1)))
- valeur1)
- (if (eq mode-adressage-2 'registre)
- (position1 valeur2 (get-register-list (make-vm 1)))
- valeur2))))))
+ (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))
+ (if (eq mode-adressage-1 'registre)
+ (position1 valeur-1 (get-register-list (make-vm 1)))
+ valeur-1)
+ (if (eq mode-adressage-2 'registre)
+ (position1 valeur-2 (get-register-list (make-vm 1)))
+ valeur-2))))
;;TODO : Faire les registres
(defun dump-vm (vm)
diff --git a/lisp2li.lisp b/lisp2li.lisp
@@ -1,24 +1,41 @@
-(load "environnement")
-(erase-tests lisp2li)
+(load "util.lisp")
;; `
-(defvar my-quasiquote (car '`(,foo)))
+(defvar my-quasiquote (car '`(,a)))
;; ,
-(defvar my-unquote (caaadr '`(,foo)))
+(defvar my-unquote (caaadr '`(,a)))
;; ,@
-(defvar my-unquote-unsplice (caaadr '`(,@foo)))
-
-(defun map-lisp2li (expr env-var env-fun)
- (mapcar (lambda (x) (lisp2li x env-var env-fun)) expr))
-
-(defun map-lisp2li-let (expr env)
- (mapcar (lambda (x) (add-binding env (car x) (lisp2li (cadr x) env))) (cadr expr)))
-
-(defun make-stat-env (env params)
- (mapcar (lambda (x) (add-binding env x nil)) params)
- env)
+(defvar my-unquote-unsplice (caaadr '`(,@a)))
+
+(defun map-lisp2li (expr env)
+ (mapcar (lambda (x) (lisp2li x env)) expr))
+
+(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
@@ -44,247 +61,259 @@
`(cons ,(transform-quasiquote (car expr))
,(transform-quasiquote (cdr expr))))))
-(defun lisp2li (expr &optional env-var env-fun)
+(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"
- (cond ((null env-var) (lisp2li expr (empty-env-stack) env-fun))
- ((null env-fun) (lisp2li expr env-var (empty-env-stack)))
- ;; literaux
- ((and (atom expr) (constantp expr))
- (cons :lit expr))
- ;; symboles
- ((symbolp expr)
- (let ((cell (get-binding env-var expr)))
- (if cell
- (cons :var (car cell))
- (error "Variable ~S unknown" expr))))
- ;; lambda solitaire ex: (lambda (x) x)
- ((eq 'lambda (car expr))
- (let ((env-bis (make-stat-env (push-new-env env-var "LAMBDA") (second expr))))
- `(:lclosure (,env-bis . ,env-fun)
- ,(lisp2li (third expr)
- env-bis env-fun))))
- ;; lambda ex: ((lambda (x) x) 1)
- ((and (consp (car expr))
- (eq 'lambda (caar expr)))
- `(:call ,(lisp2li (car expr) env-var env-fun)
- ,@(mapcar (lambda (param)
- (lisp2li param env-var env-fun))
- (cdr expr))))
- ;; (not-symbol ...)
- ((not (symbolp (car expr)))
- (warn "~S isn't a symbol" (car expr)))
- ;; fonction inconnue
- ((and (not (fboundp (car expr))) (not (get-binding env-fun (car expr))))
- `(:unknown ,expr (,env-var . ,env-fun)))
- ;; if
- ((eq 'if (car expr))
- (list :if
- (lisp2li (second expr) env-var env-fun)
- (lisp2li (third expr) env-var env-fun)
- (lisp2li (fourth expr) env-var env-fun)))
- ;; quote
- ((eq 'quote (car expr))
- (cons :lit (second expr)))
- ;; quasiquote `
- ((eq my-quasiquote (car expr))
- (lisp2li (transform-quasiquote (cadr expr)) env-var env-fun))
- ;; #'fn (FUNCTION fn)
- ((eq 'function (car expr))
- (list :call 'function (car expr)))
- ;; defun
- ((eq 'defun (car expr))
- (let ((env-bis (make-stat-env (push-new-env env-var "DEFUN") (third expr))))
- (add-top-level-binding env-fun
- (second expr)
- (cons :lclosure (cons (cons env-bis env-fun)
- (map-lisp2li (cdddr expr)
- env-bis env-fun)))))
- (cons :lit (second expr)))
- ;; defvar
- ((eq 'defvar (car expr))
- (add-top-level-binding env-var
- (second expr)
- (lisp2li (third expr) env-var env-fun)))
- ;; setq/setf
- ((eq 'setq (car expr))
- (cons :call (cons 'set-binding (list `(:lit . ,env-var)
- (cons :lit (second expr))
- (cons :lit (third expr))))))
- ;; let
- ((eq 'let (car expr))
- (let ((bindings (cadr expr))
- (body (cddr expr)))
- (lisp2li `((lambda ,(mapcar #'car bindings)
- ,@body)
- ,@(mapcar #'cadr bindings)) env-var env-fun)))
- ;; let*
- ((eq 'let* (car expr))
- (let ((bindings (cadr expr))
- (body (caddr expr)))
- (lisp2li (if (endp bindings)
- body
- `(let (,(car bindings))
- (let* ,(cdr bindings)
- ,body))) env-var env-fun)))
- ;; labels
- ((eq 'labels (car expr))
- (let ((bindings (cadr expr))
- (body (caddr expr))
- (env-bis (push-new-env env-fun "LABELS")))
- (mapcar (lambda (x) (add-binding env-bis (car x)
- (lisp2li `(lambda ,(cadr x) ,(cddr x)) env-var env-bis)))
- bindings)
- `(:lclosure (,env-var ,env-bis) ,(lisp2li body env-var env-bis))))
- ;; progn
- ((eq 'progn (car expr))
- (cons :progn (map-lisp2li (cdr expr) env-var env-fun)))
- ;; macros
- ((macro-function (car expr))
- (lisp2li (macroexpand-1 expr) env-var env-fun))
- ;; fonctions normales
- ((not (special-operator-p (car expr)))
- (cons :call (cons (first expr) (map-lisp2li (cdr expr) env-var env-fun))))
- (T
- (print expr)
- (error "special form not yet implemented ~S" (car expr)))
- ))
+ (cond
+ ;; literaux
+ ((and (atom expr) (constantp expr))
+ (cons :const expr))
+ ;; symboles
+ ((symbolp expr)
+ (let ((cell (assoc expr env)))
+ (if cell
+ `(:cvar ,(cadr cell) ,(caddr cell))
+ (error "Variable ~S unknown" expr))))
+ ;; lambda solitaire ex: (lambda (x) x)
+ ((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)))
+ `(:mcall ,(lisp2li (car expr) env)
+ ,@(mapcar (lambda (param)
+ (lisp2li param env))
+ (cdr expr))))
+ ;; (not-symbol ...)
+ ((not (symbolp (car expr)))
+ (warn "~S isn't a symbol" (car expr)))
+ ;; fonction inconnue
+ ((and (not (fboundp (car expr)))
+ (not (get-defun (car expr))))
+ `(:unknown ,expr ,env))
+ ;; if
+ ((eq 'if (car expr))
+ (list :if
+ (lisp2li (second expr) env)
+ (lisp2li (third expr) env)
+ (lisp2li (fourth expr) env)))
+ ;; quote
+ ((eq 'quote (car expr))
+ (cons :const (second expr)))
+ ;; quasiquote `
+ ((eq my-quasiquote (car expr))
+ (lisp2li (transform-quasiquote (cadr expr)) env))
+ ;; #'fn (FUNCTION fn)
+ ((eq 'function (car expr))
+ `(:sclosure ,(cadr expr)))
+ ;; defun
+ ((eq 'defun (car expr))
+ `(:mcall set-defun (:const . ,(second expr))
+ ,(lisp2li `(lambda ,(third expr) ,@(cdddr expr)) env)))
+ ;; apply
+ ((eq 'apply (car expr))
+ `(:sapply ,(second expr) ,@(cddr expr)))
+ ;; setf
+ ((eq 'setf (car expr))
+ (if (symbolp (cadr expr))
+ (let ((cell (assoc (cadr expr) env)))
+ `(:set-var (,(second cell) ,(third cell))
+ ,(lisp2li (third expr) env)))
+ `(:set-fun ,(caadr expr) ,@(last expr) ,@(cdadr expr))))
+ ;; 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))
+ ;; foctions normales
+ ((not (special-operator-p (car expr)))
+ `(:call ,(first expr) ,@(map-lisp2li (cdr expr) env)))
+ (T
+ (print expr)
+ (error "special form not yet implemented ~S" (car expr)))))
;; Test unitaire
(load "test-unitaire")
(erase-tests lisp2li)
-(deftest (lisp2li :lit)
- (lisp2li '3 () ())
- '(:lit . 3))
-
-(deftest (lisp2li :lit)
- (lisp2li ''x () ())
- '(:lit . x))
-
-(deftest (lisp2li :lit)
- (lisp2li ''(1 2 3) () ())
- '(:lit 1 2 3))
-
-;; test des if
-(deftest (lisp2li :if)
- (lisp2li '(if T T nil) () ())
- '(:if (:lit . T) (:lit . T) (:lit . nil)))
-
-(deftest (lisp2li :if)
- (lisp2li '(if T nil T) () ())
- '(:if (:lit . T) (:lit . nil) (:lit . T)))
-
-;; test des fonctions predefinies
-(deftest (lisp2li :call)
- (lisp2li '(eq 1 1) () ())
- '(:call eq (:lit . 1) (:lit . 1)))
-
-(deftest (lisp2li macros)
- (lisp2li '(and 1 1) () ())
- '(:lit . 1))
-
-;; test des variables
-(deftest (lisp2li :var)
- (lisp2li 'x '(("TOP-LEVEL" (x . 1) (y . 2))) ())
- '(:var . x))
-
-(deftest (lisp2li :var)
- (lisp2li '(if (eq x 3) (- x 3) (+ x 3)) '(("TOP-LEVEL" (x . 3))) ())
- '(:if (:call eq (:var . x) (:lit . 3))
- (:call - (:var . x) (:lit . 3))
- (:call + (:var . x) (:lit . 3))))
-
-(deftest (lisp2li :var)
- (lisp2li '(if (eq x 3)
- (- z 3)
- (- x 5))
- '(("TEST" (z . 5)) ("TOP-LEVEL" (x . 4))) ())
- '(:IF (:CALL EQ (:VAR . X) (:LIT . 3)) (:CALL - (:VAR . Z) (:LIT . 3))
- (:CALL - (:VAR . X) (:LIT . 5))))
-
-;; Test avec des expression plus complexe
-(deftest (lisp2li complexe)
- (lisp2li '(if (eq 1 1) 2 2) () ())
- '(:if (:call eq (:lit . 1) (:lit . 1)) (:lit . 2) (:lit . 2)))
-
-(deftest (lisp2li complexe)
- (lisp2li '(if (eq "abc" 1) "abc" 2) () ())
- '(:IF (:CALL EQ (:LIT . "abc") (:LIT . 1)) (:LIT . "abc") (:LIT . 2)))
-
-(deftest (lisp2li :unknown)
- (lisp2li '(foo 1 1) () ())
- '(:unknown (foo 1 1) ((("TOP-LEVEL")) ("TOP-LEVEL"))))
-
-(deftest (lisp2li :unknown)
- (lisp2li '(if (and (eq 1 1) (= 2 2)) (foo 1 2) (bar 3 4)) () ())
- '(:IF (:CALL = (:LIT . 2)
- (:LIT . 2))
- (:UNKNOWN (FOO 1 2) ((("TOP-LEVEL")) ("TOP-LEVEL")))
- (:UNKNOWN (BAR 3 4) ((("TOP-LEVEL")) ("TOP-LEVEL")))))
-
-;; Test sur le setq
-(deftestvar (lisp2li setq) env (add-binding (empty-env-stack) 'x 1))
-(deftest (lisp2li setq)
- (lisp2li '(setq x 2) env ())
- '(:call set-binding (:lit . (("TOP-LEVEL" (x . 1)))) (:lit . x) (:lit . 2)))
-
-;; Test sur le defun
-(deftest (lisp2li defun valeur-de-retour)
- (lisp2li '(defun fact (n r)
- (if (= n 0)
- r
- (fact (- n 1) (* n r))))
- () ())
- '(:lit . fact))
-
-(deftestvar (lisp2li defun environnement) env (empty-env-stack))
-(deftest (lisp2li defun environnement)
- (progn
- (lisp2li '(defun fact (n r)
- (if (= n 0)
- r
- (fact (- n 1) (* n r))))
- () env)
- env)
- '#1=(("TOP-LEVEL"
- (FACT :LCLOSURE (#2=(("DEFUN" (R) (N)) ("TOP-LEVEL")) . #1#)
- (:IF (:CALL = (:VAR . N) (:LIT . 0)) (:VAR . R)
- (:UNKNOWN (FACT (- N 1) (* N R)) (#2# . #1#)))))))
-
-;; Test sur la lambda expression
-(deftest lisp2li
- (lisp2li '(mapcar (lambda (x) x) '(1 2 3))
- () ())
- '(:call mapcar (:lclosure ((("LAMBDA" (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
- (:var . x)) (:lit 1 2 3)))
-
-(deftest lisp2li
- (lisp2li '((lambda (x y z) (list x y z)) 1 2 3) () ())
- '(:call (:lclosure ((("LAMBDA" (Z) (Y) (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
- (:call list (:var . x) (:var . y) (:var . z)))
- (:lit . 1) (:lit . 2) (:lit . 3)))
-
-;; Test sur le LET
-(deftest lisp2li
- (lisp2li '(let ((x 1) (y 2)) (list x y)) () ())
- '(:call (:lclosure ((("LAMBDA" (Y) (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
- (:call list (:var . x) (:var . y)))
- (:lit . 1) (:lit . 2)))
-
-(deftest lisp2li
- (lisp2li '(let ((x 1) (y (+ x 2))) (list x y)) '(("TOP-LEVEL" (x . 1))) ())
- '(:call (:lclosure ((("LAMBDA" (Y) (X)) ("TOP-LEVEL" (x . 1))) ("TOP-LEVEL"))
- (:call list (:var . x) (:var . y)))
- (:lit . 1) (:call + (:var . x) (:lit . 2))))
-
-;; Test sur le LET*
-(deftest lisp2li
- (lisp2li '(let* ((x 1) (y (+ x 2))) (list x y)) () ())
- '(:CALL (:LCLOSURE ((("LAMBDA" (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
- (:CALL (:LCLOSURE ((("LAMBDA" (Y)) ("LAMBDA" (X)) ("TOP-LEVEL")) ("TOP-LEVEL"))
- (:CALL LIST (:VAR . X) (:VAR . Y)))
- (:CALL + (:VAR . X) (:LIT . 2))))
- (:LIT . 1)))
-
-;(run-tests t)
-\ No newline at end of file
+(deftest (lisp2li make-stat-env)
+ (make-stat-env '(x y z))
+ '((x 0 1) (y 0 2) (z 0 3)))
+
+(deftest (lisp2li make-stat-env)
+ (make-stat-env '(a b c d))
+ '((a 0 1) (b 0 2) (c 0 3) (d 0 4)))
+
+(deftest (lisp2li make-stat-env)
+ (make-stat-env '(a b) '((x 0 1) (y 0 2)))
+ '((a 1 1) (b 1 2) (x 0 1) (y 0 2)))
+
+(deftest (lisp2li make-stat-env)
+ (make-stat-env '(a b &optional c &rest d))
+ '((a 0 1) (b 0 2) (c 0 3) (d 0 4)))
+
+(deftest (lisp2li make-stat-env)
+ (make-stat-env '(x y &optional (z t)))
+ '((x 0 1) (y 0 2) (z 0 3) (z-p 0 4)))
+
+(deftest (lisp2li constante)
+ (lisp2li '3 ())
+ '(:const . 3))
+
+(deftest (lisp2li constante)
+ (lisp2li ''x ())
+ '(:const . x))
+
+(deftest (lisp2li constante)
+ (lisp2li ''(1 2 3) ())
+ '(:const 1 2 3))
+
+(deftest (lisp2li variables)
+ (lisp2li 'x '((x 0 1) (y 0 2)))
+ '(:cvar 0 1))
+
+(deftest (lisp2li fonctions-normales)
+ (lisp2li '(+ 3 4) ())
+ '(:call + (:const . 3) (:const . 4)))
+
+(deftest (lisp2li fonctions-normales)
+ (lisp2li '(list 3 4 (* 6 7)) ())
+ '(:call list (:const . 3) (:const . 4)
+ (:call * (:const . 6) (:const . 7))))
+
+(deftest (lisp2li if)
+ (lisp2li '(if T T nil) ())
+ '(:if (:const . T) (:const . T) (:const . nil)))
+
+(deftest (lisp2li defun)
+ (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)) ())
+ '(:mcall set-defun (:const . foo)
+ (:lclosure 3 :call list
+ (:cvar 0 1)
+ (:cvar 0 2)
+ (:cvar 0 3))))
+
+(deftest (lisp2li setf)
+ (lisp2li '(setf y 42) '((x 0 1) (y 0 2)))
+ '(:set-var (0 2) 42))
+
+(deftest (lisp2li setf)
+ (lisp2li '(setf (cdr '(1 2 3)) 42) ())
+ '(:set-fun cdr 42 '(1 2 3)))
+
+(deftest (lisp2li lambda)
+ (lisp2li '(mapcar (lambda (x y z) (list x y z)) '(1 2 3)) ())
+ '(:call mapcar (:lclosure 3 :call list
+ (:cvar 0 1)
+ (:cvar 0 2)
+ (:cvar 0 3))
+ (:const 1 2 3)))
+
+(deftest (lisp2li lambda)
+ (lisp2li '((lambda (x y z) (list x y z)) 1 2 3) ())
+ '(:mcall (:lclosure 3 :call list
+ (:cvar 0 1)
+ (:cvar 0 2)
+ (: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 '(bar 3) ())
+ '(:unknown (bar 3) ()))
+
+(deftest (lisp2li function)
+ (lisp2li '#'car ())
+ '(:sclosure car))
+
+(deftest (lisp2li apply)
+ (lisp2li '(apply 'list '(1 2 3)) ())
+ '(:sapply 'list '(1 2 3)))
+
+(deftest (lisp2li apply)
+ (lisp2li '(apply #'list '(1 2 3)) ())
+ '(:sapply #'list '(1 2 3)))
+
+(deftest (lisp2li progn)
+ (lisp2li '(progn (list 1 2 3) (+ 3 4)) ())
+ '(:progn (:call list
+ (:const . 1)
+ (:const . 2)
+ (:const . 3))
+ (:call +
+ (: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))))
+
+(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)))
diff --git a/match.lisp b/match.lisp
@@ -33,59 +33,59 @@
;; Dans le cas où le pattern n'est pas "simple", la valeur correspondante
;; sera une liste de toutes les occurences de pattern
-(defun pattern-match-do-lambdas-? (pattern)
+(defun pattern-match-do-lambdas-transform (pattern)
(mapcar (lambda (pred)
- (cond ((atom pred) (list 'quote pred))
+ (cond ((atom pred) (list 'function pred))
((eq (car pred) 'function) pred)
((eq (car pred) 'lambda) pred)
(t
`(lambda (x) ,pred))))
- (cdr pattern)))
+ pattern))
+
+(defun pattern-match-do-lambdas-1 (pattern)
+ (if (atom pattern)
+ `',pattern
+ `(list ',(first pattern)
+ ',(second pattern)
+ ,(if (second pattern)
+ (let ((?-clause (cdr (third pattern)))
+ (type '_))
+ (when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ @ @.)))
+ (setq type (car ?-clause))
+ (setq ?-clause (cdr ?-clause)))
+ ;; TODO : (? or foo (? _ and bar baz) (? $ and quux))
+ (cond ((atom ?-clause) `(list ',type 'and #'identity))
+ ((eq 'and (first ?-clause)) `(list ',type 'and ,@(pattern-match-do-lambdas-transform (cdr ?-clause))))
+ ((eq 'or (first ?-clause)) `(list ',type 'or ,@(pattern-match-do-lambdas-transform (cdr ?-clause))))
+ (t `(list ',type 'and ,@(pattern-match-do-lambdas-transform ?-clause)))))
+ (pattern-match-do-lambdas-1 (third pattern)))
+ ',(fourth pattern)
+ ,(pattern-match-do-lambdas-1 (fifth pattern)))))
(defmacro pattern-match-do-lambdas (pattern)
- "Transforme les (? x <code>) et (? (lambda ...)) en vrais lambdas."
- (cond
- ;; (? x <code>)
- ((and (n-consp 2 pattern)
- (eq '? (first pattern)))
- (cond ((eq 'and (second pattern)) `(list '? 'and ,@(pattern-match-do-lambdas-? (cdr pattern))))
- ((eq 'or (second pattern)) `(list '? 'or ,@(pattern-match-do-lambdas-? (cdr pattern))))
- (t `(list '? 'and ,@(pattern-match-do-lambdas-? pattern)))))
- ;; (p1 p2 ... pn)
- ((consp pattern)
- ;; Transformation de chaque pattern de la liste y compris
- ;; le dernier cdr si ce n'est pas nil.
- (labels ((recurse (pat)
- (cond ((null pat) nil)
- ((atom pat) `(pattern-match-do-lambdas ,pat))
- (t `(cons (pattern-match-do-lambdas ,(car pat))
- ,(recurse (cdr pat)))))))
- (recurse pattern)))
- ;; Autres cas
- (t
- (list 'quote pattern))))
-(defun transform (pat)
- (let ((str-sym (string pat)))
- (if (< (length str-sym) 2)
- pat
- (let* ((sym (map 'list #'identity str-sym))
- (lsym (car (last sym))))
- (if (or (char= lsym #\*)
- (char= lsym #\+)
- (char= lsym #\?))
- (list (intern (format nil "~{~a~}" (butlast sym)))
- (intern (string lsym)))
- pat)))))
-
-;; TODO : peut-être virer cette fonction, elle est *très* moche
-;; et pas très utile.
-(defun pattern-match-preprocess (pattern)
+ "Transforme les (? (<code>)) et (? (lambda ...)) en vrais lambdas."
+ (pattern-match-do-lambdas-1 pattern))
+
+(defun transform-symbol-to-multi (pat)
+ (let ((str-sym (string pat)))
+ (if (< (length str-sym) 2)
+ pat
+ (let* ((sym (map 'list #'identity str-sym))
+ (lsym (car (last sym))))
+ (if (or (char= lsym #\*)
+ (char= lsym #\+)
+ (char= lsym #\?))
+ (list (intern (format nil "~{~a~}" (butlast sym)))
+ (intern (string lsym)))
+ pat)))))
+
+(defun pattern-match-preprocess-multi (pattern)
"Transforme les symbol*, symbol+ et symbol?
en symbol *, symbol + et symbol ?"
(cond ((and (consp pattern) (eq '? (first pattern)))
pattern) ;; On ne touche pas les (? ...)
((consp pattern)
- (labels ((transform (pat)
+ (labels ((transform-symbol-to-multi (pat)
(let ((str-sym (string pat)))
(if (< (length str-sym) 2)
pat
@@ -100,97 +100,427 @@
(recurse (pat)
(cond
((null pat) nil)
- ((symbolp pat) (transform pat))
+ ((symbolp pat) (transform-symbol-to-multi pat))
((atom pat) pat)
+ ((keywordp (car pat)) ;; TODO : non testé !!!
+ `(,(car pat)
+ ,@(recurse (cdr pat))))
((symbolp (car pat))
- (let ((transf (transform (car pat))))
+ (let ((transf (transform-symbol-to-multi (car pat))))
(if (consp transf)
`(,@transf ,@(recurse (cdr pat)))
`(,transf ,@(recurse (cdr pat))))))
- (t (cons (pattern-match-preprocess (car pat))
+ (t (cons (pattern-match-preprocess-multi (car pat))
(recurse (cdr pat)))))))
(recurse pattern)))
+ ((symbolp pattern)
+ (transform-symbol-to-multi pattern))
(t
pattern)))
-(defun pattern-match (pattern expr)
- (cond
- ;; (pattern * ...)
- ((and (n-consp 2 pattern) (eq '* (second pattern)))
- (or (pattern-match (cddr pattern) expr)
- (and (consp expr)
- (pattern-match (car pattern) (car expr))
- (pattern-match pattern (cdr expr)))))
- ;; (pattern + ...)
- ((and (n-consp 2 pattern) (eq '+ (second pattern)))
- (and (consp expr)
- (pattern-match (first pattern) (car expr))
- (pattern-match `(,(first pattern) * ,@(cddr pattern)) (cdr expr))))
- ;; (pattern ? ...)
- ((and (n-consp 2 pattern) (eq '? (second pattern)))
- (or (and (consp expr)
- (pattern-match (first pattern) (car expr))
- (pattern-match (cddr pattern) (cdr expr)))
- (pattern-match (cddr pattern) expr)))
- ;; (? <prédicat(s)>)
- ((and (n-consp 2 pattern) (eq '? (first pattern)))
- (cond
- ;; (? and symbole-1 ... symbole-n)
- ((eq 'and (second pattern))
- (every (lambda (predicat) (funcall predicat expr)) (cddr pattern)))
- ;; (? or symbole-1 ... symbole-n)
- ((eq 'or (second pattern))
- (some (lambda (predicat) (funcall predicat expr)) (cddr pattern)))
- ;; (? (lambda (x) <code>))
- ((functionp (second pattern))
- (funcall (second pattern) expr)) ;; niy
- ;; (? symbole)
- ((symbolp (second pattern))
- (funcall (second pattern) expr))
- (t
- (error "Motif malformé."))))
- ;; (pattern . rest)
- ((consp pattern)
- (and (consp expr)
- (pattern-match (car pattern) (car expr))
- (pattern-match (cdr pattern) (cdr expr))))
- ;; ()
- ((null pattern)
- (null expr))
- ;; $
- ((eq '$ pattern)
- (and (atom expr)
- (not (null expr))))
- ;; @
- ((eq '@ pattern)
- (or (null expr)
- (and (consp expr)
- (pattern-match '@ (cdr expr)))))
- ;; @.
- ((eq '@. pattern)
- (consp expr))
- ;; _
- ((eq '_ pattern)
- t)
- ;; :symbole
- ((and (consp pattern) (keywordp (car pattern)))
- "niy")
- ;; symbole
- ((symbolp pattern)
- (eq pattern expr))
- ;; Autres valeurs
- (t
- (equal pattern expr))))
-
-(defmacro match (pattern expr)
- `(pattern-match
- (pattern-match-preprocess
- (pattern-match-do-lambdas ,pattern))
- ,expr))
+(defun keyword-to-symbol (keyword)
+ (intern (format nil "~a" keyword)))
+
+(defun pattern-match-preprocess-capture (pattern &optional capture-name)
+ "Transforme pattern en un arbre (capture-name is-predicate pattern multi rest)."
+ (if (and (consp pattern) (keywordp (car pattern)))
+ ;; capture-name
+ (if (and (n-consp 2 (cdr pattern)) (member (caddr pattern) '(* + ?)))
+ ;; avec capture-name, avec multi
+ (list (keyword-to-symbol capture-name)
+ nil
+ (pattern-match-preprocess-capture (second pattern) (first pattern))
+ (third pattern)
+ (pattern-match-preprocess-capture (cdddr pattern)))
+ ;; avec capture-name, sans multi
+ (cond
+ ;; (:x . a)
+ ((atom (cdr pattern))
+ (list (keyword-to-symbol (car pattern))
+ nil
+ (cdr pattern)
+ nil
+ nil))
+ ;; (:x . (? ...))
+ ((and (consp pattern) (eq '? (cadr pattern)))
+ (list (keyword-to-symbol (car pattern))
+ t
+ (cdr pattern)
+ nil
+ nil)) ;; TODO
+ ;; (:x cadr-pattern . cddr-pattern)
+ (t
+ (list (keyword-to-symbol capture-name)
+ nil
+ (pattern-match-preprocess-capture (cadr pattern) (car pattern))
+ nil
+ (pattern-match-preprocess-capture (cddr pattern))))))
+ ;; pas de capture-name
+ (if (and (n-consp 2 pattern) (member (cadr pattern) '(* + ?)))
+ ;; sans capture-name, avec multi
+ (list (keyword-to-symbol capture-name)
+ nil
+ (pattern-match-preprocess-capture (first pattern))
+ (second pattern)
+ (pattern-match-preprocess-capture (cddr pattern)))
+ ;; sans capture-name, sans multi
+ (cond
+ ;; a
+ ((atom pattern)
+ (list (keyword-to-symbol capture-name)
+ nil
+ pattern
+ nil
+ nil))
+ ;; (? ...)
+ ((and (consp pattern) (eq '? (car pattern)))
+ (list (keyword-to-symbol capture-name)
+ t
+ pattern
+ nil
+ nil))
+ ;; (car-pattern . cdr-pattern)
+ (t
+ (list (keyword-to-symbol capture-name)
+ nil
+ (pattern-match-preprocess-capture (car pattern))
+ nil
+ (pattern-match-preprocess-capture (cdr pattern))))))))
+
+;; Fonctionnement du match avec *
+;;
+;; (match (:x (:y _ :z _)* :e _) '((a b) (1 2) (foo bar) x))
+;; ;; greedy match ok
+;; => ((:x (a b)) (:y a) (:z b)) ---> (match (:x (:y _ :z _)* :e _) '((1 2) (foo bar) x))
+;; [________________________] ;; greedy match ok
+;; | => ((:x (1 2)) (:y 1) (:z 2)) ---> (match (:x (:y _ :z _)* :e _) '((foo bar) x))
+;; | [________________________] ;; greedy match ok
+;; | | => ((:x (foo bar)) (:y foo) (:z bar)) ---> (match (:x (:y _ :z _)* :e _) '(x))
+;; | | [________________________________] ;; not greedy match !!!!
+;; | | | [ car = make-empty-matches ] [cdr = matches non-greedy ]
+;; | +-------------+ v => (((:x nil) (:y nil) (:z nil)) (:e x))
+;; | | [ --- param 1 = matches here --- ] ([ :x lst of rest of greedy ] [ matches non-greedy ])
+;; | | => (append-captures ((:x (foo bar)) (:y foo) (:z bar)) (((:x nil) (:y nil) (:z nil)) (:e x)))
+;; | | [ ---- greedy matches appended --------] [ matches non-greedy ]
+;; +-------------+ | => (((:x ((foo bar))) (:y (foo)) (:z (bar))) (:e x))
+;; | | [_______________________________________________]
+;; | v v
+;; | [________________________] [_______________________________________________]
+;; | => (append-captures ((:x (1 2)) (:y 1) (:z 2)) (((:x ((foo bar))) (:y (foo)) (:z (bar))) (:e x)))
+;; | => (((:x ((1 2) (foo bar))) (:y (1 foo)) (:z (2 bar))) (:e x))
+;; | [_________________________________________________________]
+;; v v
+;; [________________________] [_________________________________________________________]
+;; => (append-captures ((:x (a b)) (:y a) (:z b)) (((:x ((1 2) (foo bar))) (:y (1 foo)) (:z (2 bar))) (:e x)))
+;; => (((:x ((a b) (1 2) (foo bar))) (:y (a 1 foo)) (:z (b 2 bar))) (:e x))
+;; | |
+;; | first-multi = t |
+;; | => (append (car ___) (cdr ___)) |
+;; v v
+;; => ( (:x ((a b) (1 2) (foo bar))) (:y (a 1 foo)) (:z (b 2 bar)) (:e x))
+
+(defun append-captures-1 (captures-1 captures-2)
+ (if (endp captures-1)
+ nil
+ (if (caar captures-1) ;; ignorer les captures nommées nil
+ (cons (cons (caar captures-1) ;; nom de capture
+ (cons (cdar captures-1) ;; nouvelle capture
+ (cdr (assoc (caar captures-1) captures-2))))
+ (append-captures-1 (cdr captures-1) captures-2))
+ (append-captures-1 (cdr captures-1) captures-2))))
+
+(defun append-captures (captures-1 captures-2)
+ "captures-1 et 2 sont des alist nom-capture . arbre-capture
+ Renvoie une alist nom-capture . (append arbre-c1 arbre-c2)"
+ (cons (append-captures-1 captures-1 (car captures-2))
+ (cdr captures-2)))
+
+(defun make-empty-matches-1 (pattern result)
+ (if (atom pattern)
+ result
+ (let ((here (if (first pattern) ;; pas les captures nommées nil
+ (acons (first pattern) nil result)
+ result)))
+ (if (second pattern) ;; ne pas descendre dans les les (? ...)
+ here
+ (make-empty-matches-1 (fifth pattern)
+ (make-empty-matches-1 (third pattern) here))))))
+
+(defun make-empty-matches (pattern)
+ (reverse (make-empty-matches-1 pattern '())))
+
+(defun acons-capture (capture-name value captures)
+ (if (or capture-name (not captures))
+ (acons capture-name value captures)
+ captures))
+
+(defun append-car-cdr-not-nil (c)
+ (if (or (car c) (cdr c))
+ (append (car c) (cdr c))
+ (acons nil nil nil)))
+
+(defun append-not-nil-1 (a b)
+ (if (endp a)
+ b
+ (if (caar a)
+ (cons (car a) (append-not-nil-1 (cdr a) b))
+ (append-not-nil-1 (cdr a) b))))
+
+(defun append-not-nil (a b)
+ (or (append-not-nil-1 a b)
+ (acons nil nil nil)))
+
+(declaim (ftype function pattern-match)) ;; récursion mutuelle recursive-backtrack / pattern-match
+(defun recursive-backtrack (pattern rest expr capture-name)
+ (or
+ ;; match greedy (on avance dans le *)
+ (and (consp expr)
+ (let ((greedy-left (pattern-match pattern (car expr))))
+ (when greedy-left
+ (let ((greedy-right (recursive-backtrack pattern rest (cdr expr) capture-name)))
+ (when greedy-right
+ (append-captures (acons-capture capture-name (car expr) greedy-left)
+ greedy-right))))))
+ ;; match non-greedy (on match avec le rest)
+ (let ((non-greedy (pattern-match rest expr)))
+ (when non-greedy
+ (cons (acons-capture capture-name expr (make-empty-matches pattern))
+ non-greedy)))))
+
+(defun pattern-match (pat expr)
+ (let ((capture-name (first pat))
+ (is-predicate (second pat))
+ (pattern (third pat))
+ (multi (fourth pat))
+ (rest (fifth pat)))
+ (if multi
+ (if (not (listp expr))
+ nil
+ (cond
+ ;; (pattern * ...)
+ ((eq multi '*)
+ (let ((match (recursive-backtrack pattern rest expr capture-name)))
+ (when match
+ (append-car-cdr-not-nil match))))
+ ;; (pattern + ...)
+ ((eq multi '+)
+ (let ((first-match (and (consp expr) (pattern-match pattern (car expr)))))
+ (when first-match
+ (let ((match (recursive-backtrack pattern rest (cdr expr) capture-name)))
+ (when match
+ (let ((result (append-captures first-match match)))
+ (append-car-cdr-not-nil result)))))))
+ ;; (pattern ? ...)
+ ((eq multi '?)
+ (let ((match (and (consp expr) (pattern-match pattern (car expr)))))
+ (or (when match
+ (let ((match-rest (pattern-match rest (cdr expr))))
+ (when match-rest
+ (append match match-rest)))) ;; TODO : vérifier qu'on n'a pas besoin d'un make-empty-matches en cas de non-match de sous-trucs. (normalement non)
+ (let ((match-only-rest (pattern-match rest expr)))
+ (when match-only-rest
+ (append (acons-capture capture-name expr (make-empty-matches pattern))
+ match-only-rest))))))))
+ (if rest
+ ;; (pattern . rest)
+ (and (consp expr)
+ (let ((left (pattern-match pattern (car expr))))
+ (when left
+ (let ((right (pattern-match rest (cdr expr))))
+ (when right
+ (acons-capture capture-name expr (append-not-nil left right)))))))
+ ;; pattern est un atom
+ (cond
+ ;; (? <prédicat(s)>)
+ (is-predicate
+ (when (and (pattern-match `(nil nil ,(car pattern) nil nil) expr)
+ (cond
+ ;; (? _ and symbole-1 ... symbole-n)
+ ((eq 'and (second pattern))
+ (every (lambda (predicat) (funcall predicat expr)) (cddr pattern)))
+ ;; (? _ or symbole-1 ... symbole-n)
+ ((eq 'or (second pattern))
+ (some (lambda (predicat) (funcall predicat expr)) (cddr pattern)))))
+ (acons-capture capture-name expr nil)))
+ ;; ()
+ ((null pattern)
+ (when (null expr)
+ (acons-capture capture-name expr nil)))
+ ;; $
+ ((eq '$ pattern)
+ (when (and (atom expr)
+ (not (null expr)))
+ (acons-capture capture-name expr nil)))
+ ;; @
+ ((eq '@ pattern)
+ (when (propper-list-p expr)
+ (acons-capture capture-name expr nil)))
+ ;; @.
+ ((eq '@. pattern)
+ (when (consp expr)
+ (acons-capture capture-name expr nil)))
+ ;; _
+ ((eq '_ pattern)
+ (acons-capture capture-name expr nil))
+ ;; Autres valeurs (symbole, nombre, etc.)
+ (t
+ (when (equal pattern expr)
+ (acons-capture capture-name expr nil))))))))
+
+(defmacro pattern-match-preprocess (pattern)
+ "Tous les preprocess de pattern-match en un seul appel."
+ `(pattern-match-do-lambdas
+ ,(pattern-match-preprocess-capture
+ (pattern-match-preprocess-multi
+ pattern))))
+
+(defmacro real-match (pattern expr body &optional else-clause)
+ (let* ((result-sym (make-symbol "result"))
+ (pattern-sym (make-symbol "pattern"))
+ (pattern-preproc (pattern-match-preprocess-capture
+ (pattern-match-preprocess-multi
+ pattern)))
+ (capture-names (mapcar #'car (make-empty-matches pattern-preproc))))
+ `(let* ((,pattern-sym (pattern-match-do-lambdas ,pattern-preproc))
+ (,result-sym (pattern-match ,pattern-sym ,expr)))
+ ;; Filtrage des captures nommées nil.
+ (if ,result-sym
+ ,@(if body
+ `((let ,(mapcar (lambda (x)
+ `(,x (cdr (assoc ',x ,result-sym))))
+ capture-names)
+ ;; "utilisation" des variables pour éviter les warning unused variable.
+ ,@capture-names
+ ,@body))
+ (if capture-names
+ `((remove nil ,result-sym :key #'car))
+ `(t)))
+ ,else-clause))))
+
+(defmacro match (pattern expr &rest body)
+ (if (keywordp pattern)
+ `(real-match (,pattern . ,expr) ,(car body) ,(cdr body))
+ `(real-match ,pattern ,expr ,body)))
+
+(defmacro cond-match-1 (expr cond-clauses)
+ (if (endp cond-clauses)
+ 'nil
+ (if (keywordp (caar cond-clauses))
+ `(real-match (,(caar cond-clauses) . ,(cadar cond-clauses))
+ ,expr
+ ,(cddar cond-clauses)
+ (cond-match-1 ,expr ,(cdr cond-clauses)))
+ `(real-match ,(caar cond-clauses)
+ ,expr
+ ,(cdar cond-clauses)
+ (cond-match-1 ,expr ,(cdr cond-clauses))))))
+
+(defmacro cond-match (expr &rest cond-clauses)
+ (let ((expr-sym (make-symbol "expr")))
+ `(let ((,expr-sym ,expr))
+ (cond-match-1 ,expr-sym ,cond-clauses))))
+
+;; Explication du defmatch-closures
+;;
+;; ========== État initial ==========================================================
+;;
+;; next-rule -----------> ( (lambda else) )
+;; ^
+;; first-car-next-rule ------|
+;;
+;; ========== Après un add-pattern-xxx ==============================================
+;;
+;; next-rule -----------> ( (lambda else) )
+;; ^
+;; `----------------------------------------.
+;; |
+;; old-next-rule -------> ( (lambda (x) (if pattern-1 t (funcall car-next-rule))) )
+;; ^
+;; first-car-next-rule ------|
+;;
+;; ========== Après un autre add-pattern-xxx ========================================
+;;
+;; next-rule -----------> ( (lambda else) )
+;; ^
+;; `----------------------------------------.
+;; |
+;; old-next-rule -------> ( (lambda (x) (if pattern-2 t (funcall car-next-rule))) )
+;; ^
+;; `----------------------------------------.
+;; |
+;; ( (lambda (x) (if pattern-1 t (funcall car-next-rule))) )
+;; ^
+;; first-car-next-rule ------|
+
+(defmacro defmatch-closures (name &rest patbody)
+ "Une première version de defmatch, techniquement intéressante, mais avec beaucoup trop de closures..."
+ (let ((add-pattern-function (intern (format nil "ADD-PATTERN-~a" name)))
+ (set-else-function (intern (format nil "SET-ELSE-~a" name))))
+ (if patbody
+ (let ((pattern (car patbody))
+ (body (cdr patbody))
+ (param-expr-sym (make-symbol "param-expr"))
+ (tail-sym (make-symbol "tail")))
+ (if (eq pattern 'else)
+ `(,set-else-function ,(if (n-consp 2 body)
+ `(lambda ,(car body) ,@(cdr body))
+ `(lambda (x) x ,@body)))
+ (if (keywordp pattern)
+ `(defmatch-closures ,name (,pattern . ,(car body)) ,@(cdr body))
+ `(,add-pattern-function
+ (lambda (,param-expr-sym ,tail-sym)
+ (real-match ,pattern ,param-expr-sym ,body (funcall ,tail-sym ,param-expr-sym)))))))
+ `(let* ((else-rule (list (lambda (x) x nil)))
+ (next-rule (list (list else-rule)))
+ (first-call-next-rule
+ (let ((car-next-rule (car next-rule)))
+ (lambda (x) (funcall (caar car-next-rule) x)))))
+ (defun ,name (x)
+ (funcall first-call-next-rule x))
+ (defun ,set-else-function (else)
+ (setf (car else-rule) else))
+ (defun ,add-pattern-function (func)
+ (let ((old-next-rule next-rule))
+ (setq next-rule (list (list else-rule)))
+ (let ((car-next-rule (car next-rule)))
+ (setf (car (car old-next-rule))
+ (list (lambda (x) (funcall func x (lambda (x) (funcall (caar car-next-rule) x)))))))))))))
+
+(defmacro defmatch (name &rest patbody)
+ "Version de defmatch avec une seule closure par pattern plus deux par name."
+ (let ((add-pattern-function (intern (format nil "ADD-PATTERN-~a" name)))
+ (set-else-function (intern (format nil "SET-ELSE-~a" name))))
+ (if patbody
+ (let ((pattern (car patbody))
+ (body (cdr patbody))
+ (param-expr-sym (make-symbol "param-expr")))
+ (if (eq pattern 'else)
+ `(,set-else-function ,(if (n-consp 2 body)
+ `(lambda ,(car body) ,@(cdr body))
+ `(lambda (x) x ,@body)))
+ (if (keywordp pattern)
+ `(defmatch ,name (,pattern . ,(car body)) ,@(cdr body))
+ `(,add-pattern-function
+ (lambda (,param-expr-sym)
+ (real-match ,pattern
+ ,param-expr-sym
+ ((cons t ,(cons 'progn body)))
+ nil))))))
+ `(let* ((rules nil)
+ (else-rule (lambda (x) x nil)))
+ (defun ,name (x)
+ (cdr (or (some (lambda (r) (funcall r x)) rules)
+ (cons t (funcall else-rule x)))))
+ (defun ,set-else-function (else)
+ (setf else-rule else))
+ (defun ,add-pattern-function (func)
+ (setf rules (append rules (list func))))))))
(load "test-unitaire")
(erase-tests match)
+;;;; Tests de matching (vrai / faux)
+
;;; Symboles, chiffres, etc
(deftest (match atom divers) (match a 'a) t #'booleq)
@@ -676,7 +1006,13 @@
(deftest (match ? sous-motif) (match (a (1 $ ? 2)? c) '(a (1 b 2) c)) t #'booleq)
(deftest (match ? sous-motif) (match (a (1 $ ? 2)? c) '(a c)) t #'booleq)
-;; (? tests...)
+;;; (? tests...)
+
+;; TODO : not, nand et nor + notation infixe (ou peut-être pas).
+
+;; Identity par défaut.
+(deftest (match predicats zéro) (match (?) t) t #'booleq)
+(deftest (match predicats zéro) (match (?) nil) nil #'booleq)
(deftest (match predicats un) (match (? numberp) 1) t #'booleq)
(deftest (match predicats un) (match (? numberp) 'a) nil #'booleq)
@@ -706,4 +1042,246 @@
(deftest (match predicats lambda) (match (? numberp (lambda (y) (> y 3))) 5) t #'booleq)
(deftest (match predicats lambda) (match (? numberp (lambda (y) (> y 3))) 3) nil #'booleq)
-;(run-tests match)
+;; Tests de preprocess-capture
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x . nil))
+ '(x nil nil nil nil))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x . a))
+ '(x nil a nil nil))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x . (a)))
+ '(nil nil (x nil a nil nil) nil (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x a))
+ '(nil nil (x nil a nil nil) nil (nil nil nil nil nil)))
+
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x a *))
+ '(nil nil (x nil a nil nil) * (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (a *))
+ '(nil nil (nil nil a nil nil) * (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (:x (a) *))
+ '(nil nil (x nil (nil nil a nil nil) nil (nil nil nil nil nil)) * (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess nil)
+ '(nil nil nil nil nil))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess a)
+ '(nil nil a nil nil))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (a))
+ '(nil nil (nil nil a nil nil) nil (nil nil nil nil nil)))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess (a * b))
+ '(nil nil (nil nil a nil nil) * (nil nil (nil nil b nil nil) nil (nil nil nil nil nil))))
+
+(deftest (match preprocess-capture)
+ (pattern-match-preprocess ((a)* b))
+ '(nil nil (nil nil (nil nil a nil nil) nil (nil nil nil nil nil)) * (nil nil (nil nil b nil nil) nil (nil nil nil nil nil))))
+
+;;;; Tests de capture (variables)
+
+(deftest (match append-captures)
+ (append-captures '((x . (foo bar)) (y . foo) (z . bar))
+ '(((x . nil) (y . nil) (z . nil)) (e . x)))
+ '(((x . ((foo bar))) (y . (foo)) (z . (bar))) (e . x)))
+
+(deftest (match append-captures)
+ (append-captures '((x . (1 2)) (y . 1) (z . 2))
+ '(((x . ((foo bar))) (y . (foo)) (z . (bar))) (e . x)))
+ '(((x . ((1 2) (foo bar))) (y . (1 foo)) (z . (2 bar))) (e . x)))
+
+(deftest (match make-empty-matches)
+ (make-empty-matches (pattern-match-preprocess (:y _ :z _)))
+ '((y . nil) (z . nil)))
+
+(deftest (match make-empty-matches)
+ (make-empty-matches (pattern-match-preprocess ((:y _)* :z _)))
+ '((y . nil) (z . nil)))
+
+(deftest (match capture misc)
+ (match (:x ((:y _)* :z _)*) '(((foo) (bar) baz) ((1) 2) ((a) (b) (c) d)))
+ '((x . (((foo) (bar) baz) ((1) 2) ((a) (b) (c) d)))
+ (y . ((foo bar) (1) (a b c)))
+ (z . (baz 2 d))))
+
+(deftest (match capture misc)
+ (match (:x ((:y _)* :z _)*) '(((foo) (bar) baz) (2) ((a) (b) (c) d)))
+ '((x . (((foo) (bar) baz) (2) ((a) (b) (c) d)))
+ (y . ((foo bar) () (a b c)))
+ (z . (baz 2 d))))
+
+(deftest (match capture misc)
+ (match (:x ((:y _)* :z _)*) '())
+ '((x . ())
+ (y . ())
+ (z . ())))
+
+(deftest (match capture keyword-for-single-pattern) (match (:x . _) '(foo bar baz) x) '(foo bar baz))
+(deftest (match capture keyword-for-single-pattern) (match :x _ '(foo bar baz) x) '(foo bar baz))
+
+(deftest (match capture litteral-keyword) (match :x :x 'foo x) nil)
+(deftest (match capture litteral-keyword) (match :x :x :x x) :x)
+(deftest (match capture litteral-keyword) (match (:x :x) '(foo) x) nil)
+(deftest (match capture litteral-keyword) (match (:x :x) '(:x) x) :x)
+
+(deftest (match capture last-cons) (match (foo :x . _) '(foo bar baz) x) '(bar baz))
+(deftest (match capture last-cons) (match (:x . _) '(foo bar baz) x) '(foo bar baz))
+
+(deftest (match capture simple) (match :x $ 'foo x) 'foo)
+(deftest (match capture simple) (match :x @ 'foo x) nil)
+
+(deftest (match capture simple)
+ (match (:x _)
+ '(foo)
+ x)
+ 'foo)
+
+(deftest (match capture multi ext 1)
+ (match (:x _ *)
+ '(foo bar baz)
+ x)
+ '(foo bar baz))
+
+(deftest (match capture multi int 1)
+ (match ((:x _) *)
+ '((foo) (bar) (baz))
+ x)
+ '(foo bar baz))
+
+(deftest (match capture multi ext 2)
+ (match ((:x _ *) *)
+ '((foo bar baz) ;; expr de ext 1
+ ()
+ (quux))
+ x)
+ '((foo bar baz) ;; résultat de ext 1
+ ()
+ (quux)))
+
+(deftest (match capture multi int 2)
+ (match (((:x _) *) *)
+ '(((foo) (bar) (baz)) ;; expr de int 1
+ ()
+ ((quux)))
+ x)
+ '((foo bar baz) ;; résultat de int 1
+ ()
+ (quux)))
+
+(deftest (match capture multi ext 3)
+ (match (((:x _ *) *) *)
+ '(((foo bar baz) () (quux)) ;; expr de ext 2
+ ()
+ ((1 2) (3)))
+ x)
+ '(((foo bar baz) () (quux)) ;; résultat de ext 2
+ ()
+ ((1 2) (3))))
+
+(deftest (match capture multi int 3)
+ (match ((((:x _) *) *) *)
+ '((((foo) (bar) (baz)) () ((quux))) ;; expr de int 2
+ ()
+ (((1) (2)) ((3))))
+ x)
+ '(((foo bar baz) () (quux)) ;; résultat de int 2
+ ()
+ ((1 2) (3))))
+
+(deftest (match capture labels)
+ (match (labels :declarations ((:name $ :params (:param $*) :fbody _*) *) :body _*)
+ '(labels ((foo (x y) (list x y))
+ (bar (z w) (print z) (print w))
+ (quux ()))
+ (foo 1 2)
+ (bar 3 4))
+ param)
+ '((x y) (z w) ()))
+
+;; Extrait une liste associative nom . lambda correspondant aux déclarations,
+;; en rajoutant labels- devant chaque nom de paramètre (juste pour le fun).
+(deftest (match capture labels)
+ (match (labels :declarations ((:name $ :params (:param $*) :fbody _*) *) :body _*)
+ '(labels ((foo (x y) (list x y))
+ (bar (z w) (print z) (print w))
+ (quux ()))
+ (foo 1 2)
+ (bar 3 4))
+ (mapcar (lambda (name params fbody)
+ `(,name . (lambda ,(mapcar (lambda (param)
+ (intern (format nil "LABELS-~w" param)))
+ params)
+ ,@fbody)))
+ name params fbody))
+ '((foo . (lambda (labels-x labels-y) (list x y)))
+ (bar . (lambda (labels-z labels-w) (print z) (print w)))
+ (quux . (lambda ()))))
+
+(deftest (match cond-match)
+ (cond-match
+ '(a b)
+ ((:x $ $) (list 1 x))
+ ((:y $ @) (list 2 y))
+ ((:z _) (list 3 z)))
+ '(1 a))
+
+(deftest (match cond-match)
+ (cond-match
+ '(a (b))
+ ((:x $ $) (list 1 x))
+ ((:y $ @) (list 2 y))
+ ((:z _) (list 3 z)))
+ '(2 a))
+
+(deftest (match cond-match)
+ (cond-match
+ '(x)
+ ((:x $ $) (list 1 x))
+ ((:y $ @) (list 2 y))
+ ((:z _) (list 3 z)))
+ '(3 x))
+
+
+(defmatch test-match-foo)
+
+(defmatch test-match-foo (:x $ $) (list 'x x))
+(defmatch test-match-foo (:y $ @) (list 'y y))
+(defmatch test-match-foo (:z _) (list 'z z))
+(defmatch test-match-foo else (x) x 'i-m-else)
+
+(deftest (match defmatch)
+ (test-match-foo '(a b))
+ '(x a))
+
+(deftest (match defmatch)
+ (test-match-foo '(a (b)))
+ '(y a))
+
+(deftest (match defmatch)
+ (test-match-foo '((3)))
+ '(z (3)))
+
+(deftest (match defmatch)
+ (test-match-foo 42)
+ 'i-m-else)
+
+(defmatch test-match-bar)
+(defmatch test-match-bar else 'i-m-else)
+(deftest (match defmatch)
+ (test-match-bar 42)
+ 'i-m-else)
diff --git a/meval-fascicule.lisp b/meval-fascicule.lisp
@@ -0,0 +1,989 @@
+#|
+Exo 4.1 Vérifier ce que fait la fonction "error" dans le poly ou le manuel en ligne.
+
+24.1. General Error-Signaling Functions (beginning only)
+The functions in this section provide various mechanisms for signaling warnings, breaks,
+continuable errors, and fatal errors.
+
+In each case, the caller specifies an error message (a string) that may be processed (and
+perhaps displayed to the user) by the error-handling mechanism. All messages are constructed
+by applying the function format to the quantities nil, format-string, and all the args to produce
+a string.
+
+An error message string should not contain a newline character at either the beginning or end,
+and should not contain any sort of herald indicating that it is an error. The system will take care
+of these according to whatever its preferred style may be.
+
+Conventionally, error messages are complete English sentences ending with a period.
+Newlines in the middle of long messages are acceptable. There should be no indentation after
+a newline in the middle of an error message. The error message need not mention the name of the
+function that signals the error; it is assumed that the debugger will make this information available.
+
+Implementation note: If the debugger in a particular implementation displays error messages
+indented from the prevailing left margin (for example, indented by seven spaces because they
+are prefixed by the seven-character herald ``Error: ''), then the debugger should take care of
+inserting the appropriate indentation into a multi-line error message. Similarly, a debugger that
+prefixes error messages with semicolons so that they appear to be comments should take care of
+inserting a semicolon at the beginning of each line in a multi-line error message. These rules
+are suggested because, even within a single implementation, there may be more than one program
+that presents error messages to the user, and they may use different styles of presentation.
+The caller of error cannot anticipate all such possible styles, and so it is incumbent upon the
+presenter of the message to make any necessary adjustments.
+
+Common Lisp does not specify the manner in which error messages and other messages are displayed.
+For the purposes of exposition, a fairly simple style of textual presentation will be used in the
+examples in this chapter. The character > is used to represent the command prompt symbol for a debugger.
+
+
+[Function]
+error format-string &rest args
+
+This function signals a fatal error. It is impossible to continue from this kind of error;
+thus error will never return to its caller.
+
+The debugger printout in the following example is typical of what an implementation might print when
+error is called. Suppose that the (misspelled) symbol emergnecy-shutdown has no property named command
+(all too likely, as it is probably a typographical error for emergency-shutdown).
+
+(defun command-dispatch (cmd)
+ (let ((fn (get cmd 'command)))
+ (if (not (null fn))
+ (funcall fn))
+ (error "The command ~S is unrecognized." cmd))))
+
+(command-dispatch 'emergnecy-shutdown)
+Error: The command EMERGNECY-SHUTDOWN is unrecognized.
+Error signaled by function COMMAND-DISPATCH.
+>
+
+
+Compatibility note: Lisp Machine Lisp calls this function ferror.
+MacLisp has a function named error that takes different arguments and can signal either a fatal
+or a continuable error.
+|#
+
+#|
+Exo 4.2 Vérifier ce que fait la fontion "assoc" dans le poly ou le manuel en ligne.
+
+15.6. Association Lists
+
+An association list, or a-list, is a data structure used very frequently in Lisp.
+An a-list is a list of pairs (conses); each pair is an association. The car of a pair is called
+the key, and the cdr is called the datum.
+
+An advantage of the a-list representation is that an a-list can be incrementally augmented
+simply by adding new entries to the front. Moreover, because the searching function assoc
+searches the a-list in order, new entries can ``shadow'' old entries. If an a-list is viewed
+as a mapping from keys to data, then the mapping can be not only augmented but also altered in a
+non-destructive manner by adding new entries to the front of the a-list.
+
+Sometimes an a-list represents a bijective mapping, and it is desirable to retrieve a key given a datum.
+For this purpose, the ``reverse'' searching function rassoc is provided. Other variants of a-list
+searches can be constructed using the function find or member.
+
+It is permissible to let nil be an element of an a-list in place of a pair. Such an element is not
+considered to be a pair but is simply passed over when the a-list is searched by assoc.
+
+[Function]
+acons key datum a-list
+
+acons constructs a new association list by adding the pair (key . datum) to the old a-list.
+
+(acons x y a) == (cons (cons x y) a)
+
+This is a trivial convenience function, but I find I use it a lot.
+
+
+
+[Function]
+pairlis keys data &optional a-list
+
+pairlis takes two lists and makes an association list that associates elements of the first list
+to corresponding elements of the second list. It is an error if the two lists keys and data are not
+of the same length. If the optional argument a-list is provided, then the new pairs are added to the
+front of it.
+
+The new pairs may appear in the resulting a-list in any order; in particular, either forward or
+backward order is permitted. Therefore the result of the call
+
+(pairlis '(one two) '(1 2) '((three . 3) (four . 19)))
+
+might be
+
+((one . 1) (two . 2) (three . 3) (four . 19))
+
+but could equally well be
+
+((two . 2) (one . 1) (three . 3) (four . 19))
+
+
+[Function]
+assoc item a-list &key :test :test-not :key
+assoc-if predicate a-list
+assoc-if-not predicate a-list
+
+[Function]
+assoc-if predicate a-list &key :key
+assoc-if-not predicate a-list &key :key
+
+The omission of :key arguments for these functions in the first edition was probably an oversight.
+
+Each of these searches the association list a-list. The value is the first pair in the a-list such
+that the car of the pair satisfies the test, or nil if there is no such pair in the a-list. For example:
+
+(assoc 'r '((a . b) (c . d) (r . x) (s . y) (r . z)))
+ => (r . x)
+(assoc 'goo '((foo . bar) (zoo . goo))) => nil
+(assoc '2 '((1 a b c) (2 b c d) (-7 x y z))) => (2 b c d)
+
+It is possible to rplacd the result of assoc provided that it is not nil, in order to ``update'' the
+``table'' that was assoc's second argument. (However, it is often better to update an a-list by
+adding new pairs to the front, rather than altering old pairs.) For example:
+
+(setq values '((x . 100) (y . 200) (z . 50)))
+(assoc 'y values) => (y . 200)
+(rplacd (assoc 'y values) 201)
+(assoc 'y values) => (y . 201) now
+
+A typical trick is to say (cdr (assoc x y)). Because the cdr of nil is guaranteed to be nil,
+this yields nil if no pair is found or if a pair is found whose cdr is nil. This is useful
+if nil serves its usual role as a ``default value.''
+
+The two expressions
+
+(assoc item list :test fn)
+
+and
+
+(find item list :test fn :key #'car)
+
+are equivalent in meaning with one important exception: if nil appears in the a-list in place of
+a pair, and the item being searched for is nil, find will blithely compute the car of the nil
+in the a-list, find that it is equal to the item, and return nil, whereas assoc will ignore the
+nil in the a-list and continue to search for an actual pair (cons) whose car is nil.
+See find and position.
+
+Compatibility note: In MacLisp, the assoc function uses an equal comparison rather than eql,
+which is the default test for assoc in Common Lisp. Where in MacLisp one would write (assoc x y),
+in Common Lisp one must write (assoc x y :test #'equal) to get the completely identical effect.
+Similarly, one can get the precise effect, and no more, of the MacLisp (assq x y) by writing in
+Common Lisp (assoc x y :test #'eq).
+
+In Interlisp, assoc uses an eq test, and sassoc uses an Interlisp equal test.
+
+
+[Function]
+rassoc item a-list &key :test :test-not :key
+rassoc-if predicate a-list
+rassoc-if-not predicate a-list
+
+[Function]
+rassoc-if predicate a-list &key :key
+rassoc-if-not predicate a-list &key :key
+
+The omission of :key arguments for these functions in the first edition was probably an oversight.
+change_end
+
+rassoc is the reverse form of assoc; it searches for a pair whose cdr satisfies the test, rather than
+the car. If the a-list is considered to be a mapping, then rassoc treats the a-list as representing
+the inverse mapping. For example:
+
+(rassoc 'a '((a . b) (b . c) (c . a) (z . a))) => (c . a)
+
+The expressions
+
+(rassoc item list :test fn)
+
+and
+
+(find item list :test fn :key #'cdr)
+
+are equivalent in meaning, except when the item is nil and nil appears in place of a pair in the a-list.
+See the discussion of the function assoc.
+
+|#
+
+#|
+Exo 4.3 Définir la fonction "meval-body" qui prend en paramètre une liste d'expressions évaluables
+et un environnement, qui les évalue en séquence et retourne la valeur retourée par la dernière.
+|#
+#|
+(defun meval-body (liste-expr env)
+;; on boul
+ )
+ |#
+
+#|
+Exo 4.4 Définir la fonction "meval-args" qui prend en paramètre une liste d'expressions évaluables
+et un environnement, qui les évalue en séquence et retourne la liste de leurs valeurs.
+|#
+#|
+(defun meval-args (liste-expr)
+ )
+|#
+
+
+#|
+Exo 4.5 Définir la fonction "make-env" qui prend en paramètre une liste de symboles, une liste de
+valeurs et un environnement : construit l'environnement (une liste d'association) en appariant
+les paramètres aux valeurs correspondantes et signale une exception si paramètres et arguments
+ne concordent pas. On ne traitera d'abord que le cas des paramètres obligatoires. Si l'environnement
+passé en paramètre n'est pas vide, le nouvel environnement doit l'inclure.
+|#
+#|
+(defun make-env (liste-symb liste-val env)
+ )
+ |#
+
+#|
+Exo 4.6 Définir la fonction "meval-lambda" qui applique une lambda-fonction quelconque à des valeurs
+d'arguments dans un certain environnement. Cette fonction servira aussi pour les autres cas
+d'application de fonction, par exemple pour les macros.
+Exemple d'utilisation :
+((and (consp (car expr)) (eq 'lambda (caar expr))) ; lambda-fonction
+(meval-lambda (car expr) (meval-args (cdr expr) env) env))
+ ;; une fonction est un symbole non constant
+((get-defun (car expr))
+(meval-lambda (get-defun (car expr)) (meval-args (cdr expr) env) ()))
+...)
+|#
+#|
+(defun meval-lambda (expr)
+ )
+|#
+
+#|
+Exo 4.7 Vérifier ce que fait la fonction "get" dans le poly ou le manuel en ligne.
+
+10.1. The Property List
+
+Since its inception, Lisp has associated with each symbol a kind of tabular data structure called
+a property list (plist for short). A property list contains zero or more entries; each entry
+associates with a key (called the indicator), which is typically a symbol, an arbitrary Lisp object
+(called the value or, sometimes, the property). There are no duplications among the indicators; a
+property list may only have one property at a time with a given name. In this way, given a symbol
+and an indicator (another symbol), an associated value can be retrieved.
+
+A property list is very similar in purpose to an association list. The difference is that a property
+list is an object with a unique identity; the operations for adding and removing property-list entries
+are destructive operations that alter the property list rather than making a new one. Association lists,
+on the other hand, are normally augmented non-destructively (without side effects) by adding new entries
+to the front (see acons and pairlis).
+
+A property list is implemented as a memory cell containing a list with an even number (possibly zero)
+of elements. (Usually this memory cell is the property-list cell of a symbol, but any memory cell
+acceptable to setf can be used if getf and remf are used.) Each pair of elements in the list
+constitutes an entry; the first item is the indicator, and the second is the value. Because property-list
+functions are given the symbol and not the list itself, modifications to the property list can be
+recorded by storing back into the property-list cell of the symbol.
+
+When a symbol is created, its property list is initially empty. Properties are created by using get
+within a setf form.
+
+Common Lisp does not use a symbol's property list as extensively as earlier Lisp implementations did.
+Less-used data, such as compiler, debugging, and documentation information, is kept on property lists
+in Common Lisp.
+
+In Common Lisp, the notion of ``disembodied property list'' introduced in MacLisp is eliminated.
+It tended to be used for rather kludgy things, and in Lisp Machine Lisp is often associated with
+the use of locatives (to make it ``off by one'' for searching alternating keyword lists).
+In Common Lisp special setf-like property-list functions are introduced: getf and remf.
+
+
+[Function]
+get symbol indicator &optional default
+
+get searches the property list of symbol for an indicator eq to indicator. The first argument
+must be a symbol. If one is found, then the corresponding value is returned; otherwise default
+is returned.
+
+If default is not specified, then nil is used for default.
+
+Note that there is no way to distinguish an absent property from one whose value is default.
+
+(get x y) == (getf (symbol-plist x) y)
+
+Suppose that the property list of foo is (bar t baz 3 hunoz "Huh?"). Then, for example:
+
+(get 'foo 'baz) => 3
+(get 'foo 'hunoz) => "Huh?"
+(get 'foo 'zoo) => nil
+
+Compatibility note: In MacLisp, the first argument to get could be a list, in which case the cdr
+of the list was treated as a so-called ``disembodied property list.'' The first argument to get
+could also be any other object, in which case get would always return nil. In Common Lisp, it is
+an error to give anything but a symbol as the first argument to get.
+
+setf may be used with get to create a new property-value pair, possibly replacing an old pair
+with the same property name. For example:
+
+(get 'clyde 'species) => nil
+(setf (get 'clyde 'species) 'elephant) => elephant
+and now (get 'clyde 'species) => elephant
+
+The default argument may be specified to get in this context; it is ignored by setf but may be
+useful in such macros as push that are related to setf:
+
+(push item (get sym 'token-stack '(initial-item)))
+
+means approximately the same as
+
+(setf (get sym 'token-stack '(initial-item))
+ (cons item (get sym 'token-stack '(initial-item))))
+
+which in turn would be treated as simply
+
+(setf (get sym 'token-stack)
+ (cons item (get sym 'token-stack '(initial-item))))
+
+[Function]
+remprop symbol indicator
+
+This removes from symbol the property with an indicator eq to indicator. The property indicator
+and the corresponding value are removed by destructively splicing the property list.
+It returns nil if no such property was found, or non-nil if a property was found.
+
+(remprop x y) == (remf (symbol-plist x) y)
+
+For example, if the property list of foo is initially
+
+(color blue height 6.3 near-to bar)
+
+then the call
+
+(remprop 'foo 'height)
+
+returns a non-nil value after altering foo's property list to be
+
+(color blue near-to bar)
+
+[Function]
+symbol-plist symbol
+
+This returns the list that contains the property pairs of symbol; the contents of the property-list
+cell are extracted and returned.
+
+Note that using get on the result of symbol-plist does not work. One must give the symbol itself
+to get or else use the function getf.
+
+setf may be used with symbol-plist to destructively replace the entire property list of a symbol.
+This is a relatively dangerous operation, as it may destroy important information that the
+implementation may happen to store in property lists. Also, care must be taken that the new property
+list is in fact a list of even length.
+
+Compatibility note: In MacLisp, this function is called plist; in Interlisp, it is called getproplist.
+
+[Function]
+getf place indicator &optional default
+
+getf searches the property list stored in place for an indicator eq to indicator.
+If one is found, then the corresponding value is returned; otherwise default is returned.
+If default is not specified, then nil is used for default. Note that there is no way to
+distinguish an absent property from one whose value is default. Often place is computed
+from a generalized variable acceptable to setf.
+
+setf may be used with getf, in which case the place must indeed be acceptable as a place to setf.
+The effect is to add a new property-value pair, or update an existing pair, in the property
+list kept in the place. The default argument may be specified to getf in this context;
+it is ignored by setf but may be useful in such macros as push that are related to setf.
+See the description of get for an example of this.
+
+Compatibility note: The Interlisp function listget is similar to getf. The Interlisp function
+listput is similar to using getf with setf.
+
+[Macro]
+remf place indicator
+
+This removes from the property list stored in place the property with an indicator eq to indicator.
+The property indicator and the corresponding value are removed by destructively splicing the property list.
+remf returns nil if no such property was found, or some non-nil value if a property was found.
+The form place may be any generalized variable acceptable to setf. See remprop.
+
+[Function]
+get-properties place indicator-list
+
+get-properties is like getf, except that the second argument is a list of indicators.
+get-properties searches the property list stored in place for any of the indicators in
+indicator-list until it finds the first property in the property list whose indicator
+is one of the elements of indicator-list. Normally place is computed from a generalized
+variable acceptable to setf.
+
+get-properties returns three values. If any property was found, then the first two values are
+the indicator and value for the first property whose indicator was in indicator-list, and
+the third is that tail of the property list whose car was the indicator (and whose cadr
+is therefore the value). If no property was found, all three values are nil. Thus the
+third value serves as a flag indicating success or failure and also allows the search to be
+restarted, if desired, after the property was found.
+|#
+
+#|
+"Exo 4.8a" Il reste enfin à définir "get-defun". On pourrait construire un environnement spécial -
+il s'agit bien d'ailleurs d'un environnement spécial, réservé aux fonctions et global - en réutilisant
+des listes d'association, mais cela poserait divers problèmes techniques et le plus simple est
+d'utiliser les propriétés des symboles et la fonction "get". On définira alors "get-defun" ainsi : ..
+|#
+(defun get-defun (symb)
+ (get symb :defun))
+#|
+... où "symb" est le symbole, c-à-d le nom de fonction concerné et ":defun" est un 'keyword',
+c-à-d un symbole constant arbitraire. Cependant, si "get" est bien "setf-able", ce n'est plus
+le cas de "get-defun".
+|#
+#|
+Exo 4.8 Ecrire "get-defun" sous forme de maro et vérifier que cette nouvelle version est bien
+setf-able.
+|#
+#|
+(defun get-defun (symb)
+ )
+|#
+
+#|
+Exo 4.9 Vérifier ce que fait la fonction "symbol-function" dans le poly ou le manuel en ligne.
+
+[Function]
+symbol-function symbol
+
+symbol-function returns the current global function definition named by symbol.
+An error is signalled if the symbol has no function definition; see fboundp.
+Note that the definition may be a function or may be an object representing a special
+form or macro. In the latter case, however, it is an error to attempt to invoke the object
+as a function. If it is desired to process macros, special forms, and functions equally
+well, as when writing an interpreter, it is best first to test the symbol with macro-function
+and special-form-p and then to invoke the functional value only if these two tests both yield false.
+
+This function is particularly useful for implementing interpreters for languages embedded in Lisp.
+
+symbol-function cannot access the value of a lexical function name produced by flet or labels;
+it can access only the global function value.
+
+The global function definition of a symbol may be altered by using setf with symbol-function.
+Performing this operation causes the symbol to have only the specified definition as its
+global function definition; any previous definition, whether as a macro or as a function,
+is lost. It is an error to attempt to redefine the name of a special form (see table 5-1).
+
+change_begin
+X3J13 voted in June 1988 (FUNCTION-TYPE) to clarify the behavior of symbol-function in the
+light of the redefinition of the type function.
+
+ * It is permissible to call symbol-function on any symbol for which fboundp returns true.
+ Note that fboundp must return true for a symbol naming a macro or a special form.
+
+ * If fboundp returns true for a symbol but the symbol denotes a macro or special form,
+ then the value returned by symbol-function is not well-defined but symbol-function will
+ not signal an error.
+
+ * When symbol-function is used with setf the new value must be of type function.
+ It is an error to set the symbol-function of a symbol to a symbol, a list, or the
+ value returned by symbol-function on the name of a macro or a special form.
+|#
+
+#|
+Exo 4.10 Vérifier ce que fait la fonction "special-form-p" dans le poly ou le manuel en ligne.
+
+[Function]
+special-form-p symbol
+
+The function special-form-p takes a symbol. If the symbol globally names a special form, then
+a non-nil value is returned; otherwise nil is returned. A returned non-nil value is typically
+a function of implementation-dependent nature that can be used to interpret (evaluate) the special form.
+
+It is possible for both special-form-p and macro-function to be true of a symbol. This is
+possible because an implementation is permitted to implement any macro also as a special form
+for speed. On the other hand, the macro definition must be available for use by programs
+that understand only the standard special forms listed in table 5-1.
+|#
+
+#|
+Exo 4.11 Vérifier ce que fait la fonction "fboundp" dans le poly ou le manuel en ligne.
+
+[Function]
+fboundp symbol
+
+fboundp is true if the symbol has a global function definition. Note that fboundp is true
+when the symbol names a special form or macro. macro-function and special-form-p may be used
+to test for these cases.
+
+change_begin
+X3J13 voted in June 1988 (FUNCTION-TYPE) to emphasize that, despite the tightening of the
+definition of the type function, fboundp must return true when the argument names a special
+form or macro.
+
+See also symbol-function and fmakunbound.
+
+X3J13 voted in March 1989 (FUNCTION-NAME) to extend fboundp to accept any function-name (a
+symbol or a list whose car is setf-see section 7.1). Thus one may write (fboundp '(setf cadr))
+to determine whether a setf expansion function has been globally defined for cadr.
+change_end
+|#
+
+#|
+Exo 4.12 Tester "symbol-function", "special-form-p" et "fboundp" sur des arguments de différents types :
+autre que symbol, sur des symboles avec ou sans définition fonctionnelle, et enfin avec des définitions
+fonctionnelles de différents types (formes syntaxiques, macros, fonctions globales ou locales).
+|#
+
+#|
+Exo 4.13 Méta-définir les fonctions "fact" et "fibo". Les tester.
+|#
+#|
+(defun fact-meta ()
+ )
+|#
+#|
+(defun fibo-meta ()
+ )
+|#
+
+#|
+Exo 4.14 Considérer l'expression (meval '(meval '(fibo 10))) et en déduire quelle va
+être la première erreur produite par son évaluation. Vérifier par un test. Si ça marche du
+premier coup, c'est mauvais signe : vérifier que meval a bien été méta-définie (par
+(meval '(defun meval ...))) !
+|#
+
+#|
+Exo 4.15 Etendre la définition de "make-env" aux mots-clés &optional et &rest.
+On se basera sur le fait que la spécification des ces mots-clés repose sur un automate
+implicite. Expliciter l'automate et l'implémentation par des fonctions adéquates
+(voir aussi Chapitre 3, en particulier la section 3.3)
+|#
+
+(defun meval (expr &optional env)
+ (cond
+ ((and (atom expr) (constantp expr)) ; constante atomique
+ (print "constante atomique")
+ expr)
+ ((atom expr) ; atom non constant, donc variable
+ (print "atom non constant, donc variable")
+ (let ((cell (assoc expr env)))
+ (if cell
+ (cdr cell)
+ (error "~s n'est pas une variable" expr))))
+ ;; plus d'atome à partir d'ici
+ ((and (consp (car expr)) (eq 'lambda (caar expr))) ;; lambda-fonction
+ (print "lambda-fonction")
+ ;; ((meval-lambda (car expr) (meval-args (cdr expr) env) env))
+ (meval-body (cddar expr)
+ (make-env (cadar expr)
+ (meval-args (cdr expr) env)
+ env)))
+ ((or (not (symbolp (car expr))) (constantp (car expr))) ;; ?? en cas de "nil"
+ ;; une fonction est un symbole non constant
+ (error "~s ne peut être une fonction" (car expr)))
+; ((get-defun (car expr))
+; (let ((fun (get-defun (car expr))))
+; ;; (meval-lambda (get-defun (car expr)) (meval-args (cdr expr) env) ()))
+; (meval-body (cddr fun)
+; (make-env (cadr fun)
+; (meval-args (cdr expr) env)
+; ()))))
+; ((eq 'defun (car expr))
+; (setf (get-defun (cadr expr))
+; '(lambd ,@(cddr expr))))
+ ((eq 'quote (car expr)) ;; quote
+ (print "quote")
+ (cadr expr))
+ ((not (fboundp (car expr))) ;; faux gd // à étudier
+ (error "~s symbole sans définition fonctionnelle" (car expr)))
+ ((special-form-p (car expr))
+ (print "forme spéciale non implémentée")
+ (if (null env)
+ (eval expr)
+ (error "~s forme spéciale NYI" (car expr))))
+; (t (apply (symbol-function (car expr)) (meval-args (cdr expr) env)))
+ ; TODO : la fin est fausse
+ ((null env)
+ (eval expr))
+ (t (error "impossible d'évaluer ~s dans l'environnement ~s" expr env))
+ ;(t (eval expr)) ; triche
+
+ ))
+
+#|
+Exo 4.16 Définir cette fonction mload : (voir fascicule, page 23) on regardera dans le manuel le
+chapitre sur les entrées-sorties, en particulier les fonctions open, read et close, ainsi que le traitement
+de la fin de fichier
+|#
+
+#|
+23.2. Opening and Closing Files
+When a file is opened, a stream object is constructed to serve as the file system's ambassador
+to the Lisp environment; operations on the stream are reflected by operations on the file in the
+file system. The act of closing the file (actually, the stream) ends the association; the
+transaction with the file system is terminated, and input/output may no longer be performed
+on the stream. The stream function close may be used to close a file; the functions described
+below may be used to open them. The basic operation is open, but with-open-file is usually
+more convenient for most applications.
+
+[Function]
+open filename &key :direction :element-type :if-exists :if-does-not-exist :external-format
+
+This returns a stream that is connected to the file specified by filename. The filename is the
+name of the file to be opened; it may be a string, a pathname, or a stream. (If the filename
+is a stream, then it is not closed first or otherwise affected; it is used merely to provide
+a file name for the opening of a new stream.)
+
+The keyword arguments specify what kind of stream to produce and how to handle errors:
+
+:direction
+ This argument specifies whether the stream should handle input, output, or both.
+ :input
+ The result will be an input stream. This is the default.
+ :output
+ The result will be an output stream.
+ :io
+ The result will be a bidirectional stream.
+ :probe
+ The result will be a no-directional stream (in effect, the stream is created and then closed). This is useful for determining whether a file exists without actually setting up a complete stream.
+:element-type
+ This argument specifies the type of the unit of transaction for the stream. Anything that can
+ be recognized as being a finite subtype of character or integer is acceptable. In particular,
+ the following types are recognized:
+ string-char
+ The unit of transaction is a string-character. The functions read-char and/or write-char
+ may be used on the stream. This is the default.
+ character
+ The unit of transaction is any character, not just a string-character. The functions read-char and/or write-char may be used on the stream.
+
+ to eliminate the type string-char, add the type base-character, and redefine open to use the type character as the default :element-type.
+
+ The preceding two possibilities should therefore be replaced by the following.
+ character
+ The unit of transaction is any character, not just a string-character. The functions
+ read-char and write-char (depending on the value of the :direction argument) may be
+ used on the stream. This is the default.
+ base-character
+ The unit of transaction is a base character. The functions read-char and write-char
+ (depending on the value of the :direction argument) may be used on the stream.
+ (unsigned-byte n)
+ The unit of transaction is an unsigned byte (a non-negative integer) of size n.
+ The functions read-byte and/or write-byte may be used on the stream.
+ unsigned-byte
+ The unit of transaction is an unsigned byte (a non-negative integer); the size of the byte
+ is determined by the file system. The functions read-byte and/or write-byte may be used
+ on the stream.
+ (signed-byte n)
+ The unit of transaction is a signed byte of size n.
+ The functions read-byte and/or write-byte may be used on the stream.
+ signed-byte
+ The unit of transaction is a signed byte; the size of the byte is determined by the
+ file system. The functions read-byte and/or write-byte may be used on the stream.
+ bit
+ The unit of transaction is a bit (values 0 and 1). The functions read-byte and/or
+ write-byte may be used on the stream.
+ (mod n)
+ The unit of transaction is a non-negative integer less than n. The functions read-byte
+ and/or write-byte may be used on the stream.
+ :default
+ The unit of transaction is to be determined by the file system, based on the file it finds. The type can be determined by using the function stream-element-type.
+:if-exists
+ This argument specifies the action to be taken if the :direction is :output or :io and a file of
+ the specified name already exists. If the direction is :input or :probe, this argument is ignored.
+ :error
+ Signals an error. This is the default when the version component of the
+ filename is not :newest.
+ :new-version
+ Creates a new file with the same file name but with a larger version number. This is the
+ default when the version component of the filename is :newest.
+ :rename
+ Renames the existing file to some other name and then creates a new file with the
+ specified name.
+ :rename-and-delete
+ Renames the existing file to some other name and then deletes it (but does not expunge it,
+ on those systems that distinguish deletion from expunging). Then create a new file with the specified name.
+ :overwrite
+ Uses the existing file. Output operations on the stream will destructively modify the
+ file. If the :direction is :io, the file is opened in a bidirectional mode that allows
+ both reading and writing. The file pointer is initially positioned at the beginning of
+ the file; however, the file is not truncated back to length zero when it is opened.
+ This mode is most useful when the file-position function can be used on the stream.
+ :append
+ Uses the existing file. Output operations on the stream will destructively modify the
+ file. The file pointer is initially positioned at the end of the file. If the :direction
+ is :io, the file is opened in a bidirectional mode that allows both reading and writing.
+ :supersede
+ Supersedes the existing file. If possible, the implementation should arrange not to
+ destroy the old file until the new stream is closed, against the possibility that the
+ stream will be closed in ``abort'' mode (see close). This differs from :new-version in
+ that :supersede creates a new file with the same name as the old one, rather than a
+ file name with a higher version number.
+ nil
+ Does not create a file or even a stream, but instead simply returns nil to indicate failure.
+ If the :direction is :output or :io and the value of :if-exists is :new-version, then the version
+ of the (newly created) file that is opened will be a version greater than that of any other file
+ in the file system whose other pathname components are the same as those of filename.
+ If the :direction is :input or :probe or the value of :if-exists is not :new-version, and
+ the version component of the filename is :newest, then the file opened is that file already
+ existing in the file system that has a version greater than that of any other file in the file
+ system whose other pathname components are the same as those of filename.
+:if-does-not-exist
+ This argument specifies the action to be taken if a file of the specified name does not already exist.
+ :error
+ Signals an error. This is the default if the :direction is :input, or if the :if-exists
+ argument is :overwrite or :append.
+ :create
+ Creates an empty file with the specified name and then proceeds as if it had
+ already existed (but do not perform any processing directed by the :if-exists argument).
+ This is the default if the :direction is :output or :io, and the :if-exists argument is
+ anything but :overwrite or :append.
+ nil
+ Does not create a file or even a stream, but instead simply returns nil to indicate failure.
+ This is the default if the :direction is :probe.
+:external-format
+ This argument specifies an implementation-recognized scheme for representing characters in files.
+ The default value is :default and is implementation-defined but must support the base characters.
+ An error is signaled if the implementation does recognize the specified format.
+
+ This argument may be specified if the :direction argument is :input, :output, or :io.
+ It is an error to write a character to the resulting stream that cannot be represented
+ by the specified file format. (However, the #\Newline character cannot produce such an
+ error; implementations must provide appropriate line division behavior for all character streams.)
+
+When the caller is finished with the stream, it should close the file by using the close function. The with-open-file form does this automatically, and so is preferred for most purposes. open should be used only when the control structure of the program necessitates opening and closing of a file in some way more complex than provided by with-open-file. It is suggested that any program that uses open directly should use the special form unwind-protect to close the file if an abnormal exit occurs.
+
+[Macro]
+with-open-file (stream filename {options}*)
+ {declaration}* {form}*
+with-open-file evaluates the forms of the body (an implicit progn) with the variable stream bound
+to a stream that reads or writes the file named by the value of filename. The options are evaluated
+and are used as keyword arguments to the function open.
+
+When control leaves the body, either normally or abnormally (such as by use of throw), the file
+is automatically closed. If a new output file is being written, and control leaves abnormally,
+the file is aborted and the file system is left, so far as possible, as if the file had never
+been opened. Because with-open-file always closes the file, even when an error exit is taken,
+it is preferred over open for most applications.
+
+filename is the name of the file to be opened; it may be a string, a pathname, or a stream.
+
+For example:
+(with-open-file (ifile name
+ :direction :input)
+ (with-open-file (ofile (merge-pathname-defaults ifile
+ nil
+ "out")
+ :direction :output
+ :if-exists :supersede)
+ (transduce-file ifile ofile)))
+...
+(with-open-file (ifile name
+ :direction :input
+ :if-does-not-exist nil)
+ ;; Process the file only if it actually exists.
+ (when (streamp name)
+ (compile-cobol-program ifile)))
+
+Implementation note: While with-open-file tries to automatically close the stream on exit from
+the construct, for robustness it is helpful if the garbage collector can detect discarded
+streams and automatically close them.
+
+...
+
+READ
+
+[Function]
+read &optional input-stream eof-error-p eof-value recursive-p
+
+read reads in the printed representation of a Lisp object from input-stream, builds a corresponding
+Lisp object, and returns the object.
+
+Note that when the variable *read-suppress* is not nil, then read reads in a printed representation
+as best it can, but most of the work of interpreting the representation is avoided (the intent
+being that the result is to be discarded anyway). For example, all extended tokens produce
+the result nil regardless of their syntax.
+
+|#
+(defun mload ()
+ )
+
+#|
+Exo 4.17 - Définir 'get-defmacro' comme une macro.
+|#
+
+#|
+Exo 4.18 - Définir la fonction 'displace' qui prend en argument 2 cellules, met dans la première
+le contenu de la seconde et retourne la première. Rajouter le cas où le résultat de la macro-expansion
+est un atome.
+|#
+
+#|
+Exo 4.19 - Définir la fonction 'm-macroexmand-1' qui expanse une fois une macro méta-définie
+par analogie avec 'macroexpand-1'
+|#
+
+#|
+Exo 4.20 - Définir la fonction m-macroexpand qui expanse complètement une macro métadéfinie,
+par analogie avec 'macroexpand'. Le principe de 'macroexpand' est d'appliquer 'macroexpand-1'
+tant que le résultat de l'expansion est toujours une macro. On traitera dans cette fonction
+aussi bien les macros méta-définies que les prédéfinies.
+|#
+
+#|
+Exo 4.21 - Définir la fonction 'meval-let' qui méta-évalue une expression 'let'.
+|#
+
+#|
+Exo 4.22 - Définir la fonction 'meval-cond' qui méta-évalue une expression 'cond',
+comme si c'était une forme syntaxique.
+|#
+
+#|
+Exo 4.23 - Etendre 'msetf' à l'affectation d'arité quelconque.
+|#
+
+#|
+Exo 4.24 - Intégrer la macro-expansion de 'place' dans 'msetf' : traiter les deux cas de macros
+méta-définies et prédéfinies.
+|#
+
+#|
+Exo 4.25 - Au lieu d'énumérer dans 'msetf' toutes les fonctions setf-able, le mieux est
+d'évaluer tous les arguments de 'place', de reconstruire l'expression 'place' en remplaçant les arguments
+par leur quotée, d'évaluer 'val', puis de reconstruire l'expression 'expr' avec 'place' transformée et
+la valeur de 'val' quotée. On peut alors évaluer 'expr' pour effectuer l'affectation : tous les
+arguments étant quotés, cette évaluation peut se faire dans un environnement vide.
+|#
+
+#|
+Exo 4.26 - Définir 3 fonctions de l'exemple du compteur dans le polycopié LISP
+|#
+
+#|
+Exo 4.27 - Définir cette fonction 'meval-args*' qui est à 'meval-args' ce que
+'list*' est à 'list'.
+|#
+
+#|
+Exo 4.28 - Tester les fermetures sur le schéma de terminalisation des récursions enveloppées
+par passage de continuation. Voir polycopié de LISP.
+|#
+
+#|
+Exo 4.29 - Redéfinir les fonctions 'make-closure' et 'meval-closure' pour tenir compte de
+l'environnement fonctionnel.
+|#
+
+#|
+Exo 4.30 - Etendre le traitement de 'function' aux fonctions locales.
+|#
+
+#|
+Exo 4.31 - Définir la fonction 'make-flet-fenv' qui construit cet environnement fonctionnel.
+|#
+
+#|
+Exo 4.32 - Définir la fonction 'make-labels-fenv' qui construit cet environnement fonctionnel
+circulaire. On appellera 'make-flet-fenv' en lui passant un environnement fonctionnel "vide"
+qu'il s'agira ensuite de remplacer par son résultat même, par exemple par appel de 'displace'.
+|#
+
+#|
+Exo 4.33 - Définir la fonction 'destruct' qui construit un environnement de façon similaire à
+'make-env' mais avec la destructuration.
+|#
+
+#|
+Exo 4.34 - Traiter la forme syntaxique destructuring-bind' dans 'meval'.
+|#
+
+#|
+Exo 4.35 - Etendre la fonction 'make-env' pour qu'elle inclue la destructuration sur les
+paramètres obligatoires, tout en conservant la possibilité des mots-clés &optional, &key,
+&rest avec leur syntaxe habituelle.
+|#
+
+#|
+Exo 4.36 - Etendre la fonction 'destruct' pour qu'elle interdise la double occurrence d'un
+paramètre dans l'arbre.
+|#
+
+#|
+Exo 4.37 - Définir la fonction 'match' qui apparie un motif et une valeur dans un
+environnement qu'elle étend et retourne. En cas d'échec, retourne le mot-clé :fail.
+La fonction est similaire à 'destruct' mais elle intègre ces nouvelles contraintes.
+|#
+
+#|
+Exo 4.38 - Définir la fonction 'meval-case-match' qui implémente la forme syntaxique
+'case-match' dans le méta-évaluateur.
+|#
+
+#|
+Exo 4.39 - Définir la macro 'defil' qui construit progressivement la 'case-match' qui
+fait office de corps de la fonction.
+Le filtrage s'applique particulièrement bien aux macros, les différents motifs correspondant
+à l'analyse par cas à faire sur la syntaxe de l'expression.
+|#
+
+#|
+Exo 4.40 - Définir la macro 'defil-macro' qui construit progressivement le 'case-match'
+qui fait office de corps d'une macro.
+|#
+
+#|
+Exo 4.41 - Définir la macro 'or' par filtrage. Faire de même pour les différents exemples de
+macros du polycopié de LISP.
+|#
+
+#|
+Exo 4.42 - Définir la fonction 'rewrite-1' qui prend en entrée une donnée et une liste
+de règles de réécriture et réécrit la donnée suivant la règle de réécriture donnée par le
+motif et la production. Retourne :fail si l'appariement ne réussit pas.
+|#
+
+#|
+Exo 4.43 - Définir la fonction 'rewrite' qui prend en entrée une donnée et une liste de règles
+de réécriture et réécrit la donnée tant qu'une règle s'applique.
+|#
+
+#|
+Exo 4.44 - Définir la macro 'defrewrite-macro' qui définit une macro par des règles de
+réécriture, comme les 'let-syntax' et 'syntax-rules' de SCHEME. Cela revient à remplacer
+la construction explicite de l'expansion, avec 'backquote' par une construction implicite où
+l'action associée à chaque motif est implicitement 'backquotée' et où chaque variable
+figurant dans le motif y est implicitement virgulée.
+|#
+
+#|
+Exo 4.45 - Définir la macro 'or' par règles de réécriture et faire de même pour les différents
+exemples de macros du polycopié de LISP. Comment pourrait-ont éviter avec 'or' les problèmes
+de capture de variable ? (cf. Section sur les macros dans le chapitre 3 du polycopié LISP).
+|#
+
+#|
+Exo 4.46 - Etendre la fonction 'match' aux variables segments. On définira deux fonctions
+auxiliaires pour tester si une variable est segment et pour en extraire la variable simple
+correspondante. Pour simplifier ce traitement, on peut utiliser une forme parenthésée pour
+les segments, par exemple (*x), avec le risque de limiter les squelettes possibles : il faut
+en tout cas bien placer la clause sur les segments.
+|#
+
+#|
+Exo 4.47 - Définir dans 'meval' les deux formes syntaxiques 'delay' et 'force'.
+|#
+
+#|
+Exo 4.48 - Il n'est en fait pas nécessaire de passer par des formes syntaxiques pour définir
+les retardements. Définir 'delay' comme une macro et 'force' comme une fonction.
+|#
+
+#|
+Exo 4.49 - Définir le flot 'enum-fibo' qui énumère la suite de Fibonacci. Voir aussi la
+fonction 'next-fibo' dans le polycopié de LISP.
+|#
+
+#|
+Exo 4.50 - Définir le flot enum-prime qui énumère les nombres premiers. Voir aussi la
+fonction 'next-prime' dans le polycopié de LISP.
+|#
+
+#|
+Exo 4.51 - Définir la fonction 'scheme-symbol-function'.
+|#
+
+#|
+(deftest jc-meval
+ (meval "bonjour")
+ "bonjour")
+|#
diff --git a/meval.lisp b/meval.lisp
@@ -1,41 +1,261 @@
-(defun meval (expr env)
- "Interprète le langage intermédiaire passé en paramètre."
- (cond ((eq ':lit (first expr))
- (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))
- (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)))
- ))
+(load "match")
+
+(defun get-env-num (num env)
+"Récupère l’environnement correspondant à celui souhaité."
+ (defun get-env-num-t (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)
+ "Récupère l’environnement le plus bas"
+ (if (or (= (array-total-size env) 0)
+ (eq (aref env 0) nil))
+ env
+ (get-lower-env (aref env 0))))
+
+(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))
+ env)
+
+(defun make-env (size list-values env &optional pos-rest)
+ "Construis l’environnement en appariant les paramètres aux valeurs
+ correspondantes et signale une exception si paramètres et arguments
+ ne concordent pas. Si l’environnement passe en paramètre n’est pas vide,
+ le nouvel environnement y est inclus."
+ (cond ((and (not pos-rest)
+ (< size (length list-values)))
+ (error "Too arguments"))
+ ((> size (length list-values))
+ (error "Too few arguments"))
+ (T
+ (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)))
+ (if pos-rest
+ (make-rest lower-env
+ list-values
+ pos-rest)
+ (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)
(mapcar (lambda (x) (meval x env)) list))
-(defun foo (x) x)
+(defun meval-progn (list env)
+ "Mevalue toutes les sous expressions et renvoie
+la valeur de la dernier"
+ (if (endp list)
+ nil
+ (if (endp (cdr list))
+ (meval (car list) env)
+ (progn
+ (meval (car list) env)
+ (meval-progn (cdr list) env)))))
+
+(defun meval-body (list-expr env)
+ "Évalue en séquence la liste des expressions et
+retourne la valeur retournée par la dernière"
+ (if (endp list-expr)
+ nil
+ (if (endp (cdr list-expr))
+ (meval (car list-expr) env)
+ (progn
+ (meval (car list-expr) env)
+ (meval-body (cdr list-expr) env)))))
+
+(defun meval-args (list-expr env)
+ "Évalue en séquence la liste des expressions et
+retourne la liste de leurs valeurs"
+ (if (endp list-expr)
+ nil
+ (if (endp (cdr list-expr))
+ `(,(meval (car list-expr) env))
+ `(,(meval (car list-expr) env)
+ ,@(meval-args (cdr list-expr) env)))))
+
+(defun meval-lambda (lclosure args env)
+ "Applique une λ-fonction quelconque à des valeurs
+d’arguments dans un certain environnement."
+ (match (:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*) lclosure
+ (meval lclosure
+ (make-env size args env rest))))
+
+(defun msetf (place val env)
+ (let ((sub-env (get-env-num (first place) env)))
+ (if sub-env
+ (setf (aref sub-env (second place))
+ (meval val env)))))
+(defun make-closure (lmbd env)
+ `(,lmbd . ,env))
+
+(defun meval-closure (clos args)
+ (meval-lambda (cadr clos) args (cddr clos)))
+
+(defun meval (expr &optional (env #()))
+ "Interprète le langage intermédiaire passé en paramètre."
+ (cond-match expr
+ ((:nil :const :val . _) expr val)
+ ((:nil :cvar :num-env (? integerp) :index (? integerp))
+ (let ((sub-env (get-env-num num-env env)))
+ (if sub-env
+ (aref sub-env index)
+ (error "The variable unbound" expr))))
+ ((:nil :if :predicat @. :expr1 @. :expr2 @.)
+ (if (meval predicat env)
+ (meval expr1 env)
+ (meval expr2 env)))
+ ((:nil :call :func-name _ :body _*)
+ (apply (symbol-function func-name) (map-meval body env)))
+ ((:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*)
+ (meval-lambda lambda (meval-args args env) env))
+ (match (:nil :progn :body @.+)
+ (meval-body body env))
+ ((:nil :lclosure (? integerp) (? integerp)? :body _*)
+ (meval-body `(,body) env))
+ ((:nil :set-var :place @. :value _)
+ (msetf place value env))
+ (_*
+ (error "form special ~S not yet implemented" 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)
+
+(deftestvar (meval make-env) empty-env #())
+(deftest (meval make-env)
+ (make-env 2 '(1 2) empty-env)
+ #(() 1 2)
+ #'equalp)
+
+(deftestvar (meval make-env) env #(() 1 2))
+(deftest (meval make-env)
+ (make-env 2 '(7 8) env)
+ #(#(() 7 8) 1 2)
+ #'equalp)
+
+(deftestvar (meval make-env make-rest) env #(() nil nil))
+(deftest (meval make-env make-rest)
+ (make-rest env '(1 2 3 4) 2)
+ #(() 1 (2 3 4))
+ #'equalp)
+
+(deftestvar (meval make-env &rest) env #(() 1 2))
+(deftest (meval make-env &rest)
+ (make-env 2 '(7 8 9) env 2)
+ #(#(() 7 (8 9)) 1 2)
+ #'equalp)
+
+(deftest (meval make-env &rest)
+ (make-env 1 '(nil) env 1)
+ #(#(() (nil)) 1 2)
+ #'equalp)
+
+(deftest (meval meval-body)
+ (meval-body '((:const . 3)) #())
+ '3)
+
+(deftest (meval meval-body)
+ (meval-body '((:const . 3) (:call cons (:const . 1) (:const . 2))) #())
+ '(1 . 2))
+
+(deftest (meval meval-args)
+ (meval-args '((:const . 3)) #())
+ '(3))
+
+(deftest (meval meval-args)
+ (meval-args '((:const . 3) (:const 1 2 3)) #())
+ '(3 (1 2 3)))
+
+(deftest (meval meval-args)
+ (meval-args '((:cvar 0 1) (:call cons (:cvar 0 3)
+ (:cvar 0 2))) #(() 1 2 3))
+ '(1 (3 . 2)))
+
+(deftest (meval meval-lambda)
+ (meval-lambda '(:lclosure 2 :call cons
+ (:cvar 0 1)
+ (:cvar 0 2))
+ '(1 2) #())
+ '(1 . 2))
+
+(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))
+
+(deftestvar (meval :set-var) env #(() 2))
+(deftest (meval :set-var)
+ (progn
+ (meval (lisp2li '(setf x 42) ()) env)
+ env)
+ #(() 42))
diff --git a/test-unitaire.lisp b/test-unitaire.lisp
@@ -40,7 +40,7 @@
(setf all-tests (list nil nil nil nil))
(let ((from (test-get-module (butlast module))))
(setf (first from)
- (delete (last module)
+ (delete (car (last module))
(first from)
:key #'car)))))
@@ -76,17 +76,28 @@
(format t "~& comparison : ~w~&" _compare)
nil))))))
+(defvar b '(x x))
+(defmacro generates-error-p (code)
+ `(car (handler-case (progn (push 'a b) (cons nil ,code))
+ (error (e) (cons t e)))))
+
+(defmacro deftest-error (module test &optional (expected t))
+ `(deftest ,module (generates-error-p ,test)
+ ,expected))
+
(defmacro deftestvar (module name value)
`(test-add-variable ',module
- (list ',name (list 'copy-tree ',value))))
+ (list ',name (list 'copy-all ',value))))
+
+(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)
(if (endp submodules)
t
(and (real-run-tests (append module-name (list (caar submodules))) (cdar submodules))
(run-tests-submodules module-name (cdr submodules)))))
-(defvar run-tests-counter 0)
(defun real-run-tests (module-name from)
(if (second from)
(progn
@@ -119,6 +130,23 @@
(unless (listp module) (setq module (list module)))
`(test-remove-module ',module))
+(erase-tests test-unitaire)
+(deftest (test-unitaire copy-all)
+ (let* ((foo #(a b (1 #(2 4 6) 3) c))
+ (copy-of-foo (copy-all foo)))
+ copy-of-foo
+ (setf (aref (cadr (aref copy-of-foo 2)) 1) (cons 'MODIFIED (random 42)))
+ (equalp foo #(a b (1 #(2 4 6) 3) c)))
+ t #'booleq)
+
+(deftest (test-unitaire copy-all)
+ (let* ((foo #(a x (1 #(2 4 7) 5) c))
+ (copy-of-foo (copy-all foo)))
+ copy-of-foo
+ (setf (aref (cadr (aref foo 2)) 1) (cons 'MODIFIED (random 42)))
+ (equalp foo #(a x (1 #(2 4 7) 5) c)))
+ nil #'booleq)
+
;;; Exemples d'utilisation.
;; (erase-tests (a sub-1))
@@ -135,7 +163,9 @@
;; (deftest (a sub-2) (eq 'x 'x) t)
;; (deftest (b sub-1) (eq 'y 'y) t)
;; (deftest c (eq 'foo 'foo) t)
+;; (deftest-error c (if (eq 42 42) (error "foo") (error "bar")))
+;; Pour lancer les tests :
;; (run-tests (a sub-1) b t)
;; (run-tests ())
;; (run-tests t)
diff --git a/util.lisp b/util.lisp
@@ -1,5 +1,4 @@
;; Fonctions utiles
-
;; Liste de quelques fonctions pratiques de LISP :
;; (rplacd x val) = (setf (cdr x) val)
;; (rplaca x val) = (setf (car x) val)
@@ -34,3 +33,102 @@
t
(and (consp l)
(n-consp (- n 1) (cdr l)))))
+
+(defun propper-list-p (l)
+ (or (null l)
+ (and (consp l)
+ (propper-list-p (cdr l)))))
+
+(defun range (a &optional b)
+ (cond ((null b) (range 0 a))
+ ((> a b) (loop for i from a above b collect i))
+ (T (loop for i from a below b collect i))))
+
+(defun shift (n l)
+ (if (<= n 0)
+ l
+ (shift (- n 1) (cdr l))))
+
+(defmacro curry (fun &rest params)
+ `(lambda (&rest actual-params)
+ (apply ,fun
+ ,@(mapcar (lambda (x n)
+ (if (eq :skip x)
+ `(nth ,(- n 1) actual-params)
+ x))
+ params
+ (range (length params)))
+ (shift ,(count-if (lambda (x) (eq x :skip)) params)
+ actual-params))))
+
+(defun mload (name)
+ (let ((fd (open name)))
+ (cons 'progn
+ (loop
+ for line = (read fd nil 'eof)
+ while (not (eq line 'eof))
+ collect line
+ finally (close fd)))))
+
+(defun propper-list-p (l)
+ (or (null l)
+ (and (consp l)
+ (propper-list-p (cdr l)))))
+
+(defun m-macroexpand-1 (macro)
+ ;; TODO : not implemented yet m-macroexpand-1
+ macro ;; Pour éviter le unused variable.
+ ())
+
+(defmacro get-defun (symb)
+ `(get ,symb :defun))
+
+(defun set-defun (symb expr)
+ (setf (get-defun symb)
+ expr))
+
+(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))
+
+;; TODO : ne copie pas les listes de propriétés des symboles.
+;; Vu que ce n'est techniquement pas réalisable, il faut en tenir
+;; compte dans les tests unitaires etc.
+(defun copy-all (data)
+ "Copie récursivement un arbre de listes et de tableaux."
+ (cond
+ ((consp data)
+ (cons (copy-all (car data))
+ (copy-all (cdr data))))
+ ((arrayp data)
+ (let ((res (make-array (array-dimensions data))))
+ (dotimes (i (array-total-size data))
+ (setf (row-major-aref res i) (copy-all (row-major-aref data i))))
+ res))
+ ((stringp data)
+ (copy-seq data))
+ ((null data)
+ nil)
+ ((symbolp data)
+ data)
+ ((numberp data)
+ data)
+ ((characterp data)
+ data)
+ (t
+ (warn "copy-all : Je ne sais pas copier ~w" data)
+ data)))
