Ajout du support partiel des variables spéciales dans mini-meval (ne me demmandez pas pourquoi j'ai fait ça, je sais plus).
This commit is contained in:
Georges Dupéron
parent
a93589b657
commit
5a9f63794b
75
bootstrap/7.8.3-dolist-dotimes.lisp
Normal file
75
bootstrap/7.8.3-dolist-dotimes.lisp
Normal file
|
|
@ -0,0 +1,75 @@
|
|||
(defmacro my-dolist (spec &rest body)
|
||||
(let ((var (car spec))
|
||||
(listform (cadr spec))
|
||||
(resultform (caddr spec))
|
||||
(loopsym (make-symbol "loop"))
|
||||
(endsym (make-symbol "end"))
|
||||
(listsym (make-symbol "list")))
|
||||
`(let ((,var nil)
|
||||
(,listsym ,listform))
|
||||
(tagbody
|
||||
,loopsym
|
||||
(setq ,var (car ,listsym))
|
||||
(when (endp ,listsym)
|
||||
(go ,endsym))
|
||||
(progn ,@body)
|
||||
(setq ,listsym (cdr ,listsym))
|
||||
(go ,loopsym)
|
||||
,endsym)
|
||||
,resultform)))
|
||||
|
||||
;; (let ((foo 42)) (my-dolist (a '(1 2 3) foo) (print a)))
|
||||
;; => 1
|
||||
;; => 2
|
||||
;; => 3
|
||||
;; => 42
|
||||
;; (my-dolist (a '(1 2 3)) (print a))
|
||||
;; => 1
|
||||
;; => 2
|
||||
;; => 3
|
||||
;; => nil
|
||||
;; (my-dolist (a '(1 2 3) a) (print a))
|
||||
;; => 1
|
||||
;; => 2
|
||||
;; => 3
|
||||
;; => nil
|
||||
;; (my-dolist (a '()) (print a))
|
||||
;; => nil
|
||||
|
||||
(defmacro my-dotimes (spec &rest body)
|
||||
(let ((var (car spec))
|
||||
(countform (cadr spec))
|
||||
(resultform (caddr spec))
|
||||
(loopsym (make-symbol "loop"))
|
||||
(endsym (make-symbol "end"))
|
||||
(countersym (make-symbol "counter"))
|
||||
(maxsym (make-symbol "max")))
|
||||
`(let ((,var nil)
|
||||
(,maxsym ,countform)
|
||||
(,countersym 0))
|
||||
(tagbody
|
||||
,loopsym
|
||||
(setq ,var ,countersym)
|
||||
(when (>= ,countersym ,maxsym)
|
||||
(go ,endsym))
|
||||
(progn ,@body)
|
||||
(setq ,countersym (+ ,countersym 1))
|
||||
(go ,loopsym)
|
||||
,endsym
|
||||
(when (< 0 ,var) (setq ,var 0)))
|
||||
,resultform)))
|
||||
|
||||
;; (my-dotimes (i 3) (print i))
|
||||
;; => 0
|
||||
;; => 1
|
||||
;; => 2
|
||||
;; => nil
|
||||
;; (my-dotimes (i 3 i) (print i))
|
||||
;; => 0
|
||||
;; => 1
|
||||
;; => 2
|
||||
;; => 3
|
||||
;; (my-dotimes (i -5 i) (print i))
|
||||
;; => 0
|
||||
;; (my-dotimes (i -5) (print i))
|
||||
;; => nil
|
||||
|
|
@ -1,11 +1,111 @@
|
|||
(require 'match "match")
|
||||
(require 'util "util")
|
||||
|
||||
;; TODO (dans mini-meval et/ou compilateur) :
|
||||
(defmacro etat-local (etat)
|
||||
`(car ,etat))
|
||||
|
||||
(defmacro etat-global (etat)
|
||||
`(cadr ,etat))
|
||||
|
||||
(defmacro etat-special (etat)
|
||||
;; Variables spéciales et constantes. (ou devrait-on mettre les constantes dans etat-global ?)
|
||||
;; Note sur les constantes : On ne protège pas contre la modification de parties d'une constante non atomiqe (mais clisp non plus, donc ça va).
|
||||
`(caddr ,etat))
|
||||
|
||||
(defun assoc-etat (var type etat)
|
||||
(let ((search (cons var type)))
|
||||
(or (assoc search (etat-special etat) :test #'equal)
|
||||
(assoc search (etat-local etat) :test #'equal)
|
||||
(assoc search (etat-global etat) :test #'equal))))
|
||||
|
||||
(defun assoc-special (var type etat)
|
||||
(assoc (cons var type) (etat-special etat) :test #'equal))
|
||||
|
||||
(defun replace-local (etat new-etat-local)
|
||||
(cons new-etat-local (cdr etat)))
|
||||
|
||||
(defun push-local (etat var type value)
|
||||
(when (and (eq type 'variable) (assoc-etat var 'constant etat))
|
||||
(error "mini-meval : Can't bind ~w : it is a constant." var))
|
||||
(replace-local etat (acons (cons var type) value (etat-local etat))))
|
||||
|
||||
(defun push-local-or-special (etat var type value immediate)
|
||||
(let ((association (assoc-special var type etat))
|
||||
(new-etat nil))
|
||||
(if association
|
||||
(progn
|
||||
(setq new-etat (push-local etat var 'special-bakcup (cons association (cdr association))))
|
||||
(if immediate
|
||||
(progn (setf (cdr association) value)
|
||||
new-etat)
|
||||
(push-local new-etat var 'special-future-phantom (cons association value))))
|
||||
(push-local etat var 'variable value))))
|
||||
|
||||
(defun affect-future-specials (new-etat etat)
|
||||
(setq new-etat (etat-local new-etat))
|
||||
(setq etat (etat-local etat))
|
||||
(tagbody
|
||||
loop
|
||||
(when (eq new-etat etat) (go fin))
|
||||
(when (eq (cdaar new-etat) 'special-future-phantom)
|
||||
(setf (cdr (cadar new-etat)) (cddar new-etat)))
|
||||
(setq new-etat (cdr new-etat))
|
||||
(go loop)
|
||||
fin))
|
||||
|
||||
(defun pop-special-backups (new-etat etat)
|
||||
(setq new-etat (etat-local new-etat))
|
||||
(setq etat (etat-local etat))
|
||||
(tagbody
|
||||
loop
|
||||
(when (eq new-etat etat) (go fin))
|
||||
(when (eq (cdaar new-etat) 'special-bakcup)
|
||||
(setf (cdr (cadar new-etat)) (cddar new-etat)))
|
||||
(setq new-etat (cdr new-etat))
|
||||
(go loop)
|
||||
fin))
|
||||
|
||||
(defun push-global! (etat name type value)
|
||||
(setf (etat-global etat) (acons (cons name type) value (etat-global etat)))
|
||||
etat)
|
||||
|
||||
(defun push-special! (etat name type value)
|
||||
(setf (etat-special etat) (acons (cons name type) value (etat-special etat)))
|
||||
etat)
|
||||
|
||||
(defun reduce-on-local-1 (new-etat-local callback lists)
|
||||
(let ((res nil))
|
||||
(tagbody
|
||||
loop
|
||||
(when (member nil lists) (go fin))
|
||||
(setq res (apply callback new-etat-local (mapcar #'car lists)))
|
||||
(setq new-etat-local (acons (cons (car res) (cadr res))
|
||||
(caddr res)
|
||||
new-etat-local))
|
||||
(setq lists (mapcar #'cdr lists))
|
||||
(go loop)
|
||||
fin)
|
||||
new-etat-local))
|
||||
|
||||
(defun reduce-on-local (etat callback &rest lists)
|
||||
(if (null lists)
|
||||
etat
|
||||
(replace-local etat (reduce-on-local-1 (etat-local etat) callback lists))))
|
||||
|
||||
;; DONE
|
||||
;; - loop
|
||||
;; - dolist / dotimes
|
||||
;; - match-automaton(tagbody+block)
|
||||
|
||||
;; HALF-DONE (TODO)
|
||||
;; - read
|
||||
;; - warn
|
||||
;; - ` (quasiquote)
|
||||
|
||||
;; TODO (dans mini-meval et/ou compilateur) :
|
||||
;; - syntaxe courte du let
|
||||
;; - declaim
|
||||
;; - format
|
||||
;; - ` (quasiquote)
|
||||
;; - setf (écrire la macro)
|
||||
;; - fdefinition, funcctionp, …
|
||||
;; - symbolp, keywordp, keywords non mutables + nil et t, intern, make-symbol
|
||||
|
|
@ -13,13 +113,10 @@
|
|||
;; - and / or (macros => if)
|
||||
;; - &rest
|
||||
;; - eq (vérifier qu'on préserve bien l'égalité de pointeurs là où il faut) / = / eql / equal / equalp
|
||||
;; - load / open / read / close
|
||||
;; - load / open / close
|
||||
;; - defvar (gestion correcte des variables spéciales)
|
||||
;; - loop
|
||||
;; - dolist / dotimes
|
||||
;; - array support (array-total-size, row-major-aref, copy-seq)
|
||||
;; - string support (char=, map, string (symbol => string), format, print)
|
||||
;; - warn
|
||||
;; - coder un reverse rapide.
|
||||
;; - transformation de la récursion terminale.
|
||||
|
||||
|
|
@ -55,11 +152,11 @@
|
|||
(key other &allow-other-keys t)
|
||||
(key aux &aux)
|
||||
(key reject $&)
|
||||
(key key (:keyword . $k) `(,keyword ,(keyword-to-symbol keyword) nil nil))
|
||||
(key key (:keyword . $k) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) nil nil)) ;; Not in the standard !
|
||||
(key key (:var . $$) `(,var ,var nil nil))
|
||||
(key key (:keyword $$ :default _? :svar $$?) `(,keyword ,(keyword-to-symbol keyword) ,(car default) ,(car svar)))
|
||||
(key key (:keyword $$ :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) ,(car default) ,(car svar))) ;; Not in the standard !
|
||||
(key key (:var $$ :default _? :svar $$?) `(,var ,var ,(car default) ,(car svar)))
|
||||
(key key ((:keyword $k :var $$) :default _? :svar $$?) `(,keyword ,var ,(car default) ,(car svar)))
|
||||
(key key ((:keyword $k :var $$) :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,var ,(car default) ,(car svar)))
|
||||
(other accept)
|
||||
(other aux &aux)
|
||||
(other reject $&)
|
||||
|
|
@ -74,27 +171,116 @@
|
|||
;; (slice-up-lambda-list '(a b &rest))
|
||||
;; (slice-up-lambda-list '(a b))
|
||||
|
||||
(declaim (ftype function mini-meval)) ;; récursion mutuelle mini-meval-params / mini-meval
|
||||
(defun mini-meval-params (params global local fixed optional rest key other aux)
|
||||
(if fixed
|
||||
(if (endp params)
|
||||
(error "mini-meval-params : not enough parameters !")
|
||||
(mini-meval-params (cdr params) global (acons `(,(car fixed) . variable) (car params) local) (cdr fixed) optional rest key other aux))
|
||||
(if optional
|
||||
(let* ((var (caar optional))
|
||||
(value (if (endp params)
|
||||
(mini-meval (cadar optional) global local)
|
||||
(car params)))
|
||||
(svar (caddar optional))
|
||||
(new-local (acons `(,var . variable) value local))
|
||||
(new-local-2 (if svar
|
||||
(acons `(,svar . variable) (endp params) new-local)
|
||||
new-local)))
|
||||
(mini-meval-params (cdr params) global new-local-2 nil (cdr optional) rest key other aux))
|
||||
(if rest
|
||||
(mini-meval-params params global (acons `(,(car rest) . variable) params local) nil nil nil key other aux)
|
||||
;; TODO : finir d'implémenter &key &allow-other-keys &aux &rest (et relire CLTL).
|
||||
local))))
|
||||
(declaim (ftype function mini-meval)) ;; récursion mutuelle mini-meval-get-params-from-real -> mini-meval-params / mini-meval
|
||||
(defun mini-meval-params (params etat fixed optional rest key other aux)
|
||||
(let ((new-etat etat)
|
||||
(value nil)
|
||||
(svar nil)
|
||||
(current-key)
|
||||
(search-key)
|
||||
(seen-keys))
|
||||
(tagbody
|
||||
fixed
|
||||
(when (endp fixed) (go end-fixed))
|
||||
(when (endp params) (error "mini-meval-params : not enough parameters !"))
|
||||
(setq new-etat (push-local-or-special new-etat (car fixed) 'variable (car params) nil))
|
||||
;; (setq association (assoc-special (car fixed) 'variable etat))
|
||||
;; (if association
|
||||
;; (push (list association (mini-meval (car params) etat) (cdr association)) restore-special-fixed)
|
||||
;; (setq new-etat (push-local new-etat (car fixed) 'variable (car params))))
|
||||
(setq params (cdr params))
|
||||
(setq fixed (cdr fixed))
|
||||
(go fixed)
|
||||
end-fixed
|
||||
(affect-future-specials new-etat etat)
|
||||
;; (dolist (x restore-special-fixed) (setf (cdar x) (cadr x)))
|
||||
optional
|
||||
(when (endp optional) (go rest))
|
||||
(if (endp params)
|
||||
(setq value (mini-meval (cadar optional) new-etat)) ;; default value
|
||||
(setq value (car params)))
|
||||
(setq new-etat (push-local-or-special new-etat (caar optional) 'variable value t))
|
||||
;; (setq association (assoc-special (car optional) 'variable etat))
|
||||
;; (when association
|
||||
;; (push (cons association (cdr association)) restore-special-optional)
|
||||
;; (setf (cdr association) value))
|
||||
;; (unless association
|
||||
;; (setq new-etat (push-local new-etat (car optional) 'variable value)))
|
||||
(setq svar (caddar optional))
|
||||
(when svar
|
||||
(setq new-etat (push-local-or-special new-etat svar 'variable (endp params) t)))
|
||||
(setq params (cdr params))
|
||||
(setq optional (cdr optional))
|
||||
(go optional)
|
||||
rest
|
||||
(unless rest (go key))
|
||||
(setq new-etat (push-local new-etat (car rest) 'variable params))
|
||||
key
|
||||
(when (or (endp key) (endp params)) (go defaults-keys))
|
||||
(when (endp (cdr params)) (error "mini-meval-params : odd number of key parameters"))
|
||||
(setq search-key (keyword-to-symbol (car params)))
|
||||
(when (eq search-key (caar key))
|
||||
(setq current-key (car key))
|
||||
(push (car current-key) seen-keys)
|
||||
(setq key (cdr key))
|
||||
(go end-assoc-key-loop))
|
||||
assoc-key-loop
|
||||
(when (endp (cdr key))
|
||||
(go unknown-key))
|
||||
(when (eq search-key (caadr key))
|
||||
(setq current-key (cadr key))
|
||||
(push (car current-key) seen-keys)
|
||||
(setf (cdr key) (cddr key))
|
||||
(go end-assoc-key-loop))
|
||||
(go assoc-key-loop)
|
||||
end-assoc-key-loop
|
||||
(setq new-etat (push-local-or-special new-etat (second current-key) 'variable (second params) t))
|
||||
;; (setq association (assoc-special (second current-key) 'variable etat))
|
||||
;; (when association
|
||||
;; (push (cons association (cdr association)) restore-special-optional)
|
||||
;; (setf (cdr association) (cadr params)))
|
||||
;; (unless association
|
||||
;; (setq new-etat (push-local new-etat (car current-key) 'variable (cadr params))))
|
||||
(setq svar (fourth current-key))
|
||||
(when svar
|
||||
(setq new-etat (push-local-or-special new-etat svar 'variable t t)))
|
||||
(go after-unknown-key)
|
||||
unknown-key
|
||||
(unless (or other (member search-key seen-keys))
|
||||
(error "mini-meval-params : invalid key : ~w" (car params)))
|
||||
after-unknown-key
|
||||
(setq key (cdr key))
|
||||
(setq params (cddr params))
|
||||
defaults-keys
|
||||
(dolist (k key)
|
||||
(setq new-etat (push-local-or-special new-etat (second k) 'variable (mini-meval (third k) new-etat) t))
|
||||
(setq svar (fourth k))
|
||||
(when svar
|
||||
(setq new-etat (push-local-or-special new-etat svar 'variable nil t))))
|
||||
aux
|
||||
(when (endp aux) (go fin))
|
||||
(setq new-etat (push-local-or-special new-etat (caar aux) 'variable (mini-meval (cadar aux) new-etat) t))
|
||||
(setq aux (cdr aux))
|
||||
fin)
|
||||
new-etat))
|
||||
|
||||
;; (if fixed
|
||||
;; (if (endp params)
|
||||
;; (error "mini-meval-params : not enough parameters !")
|
||||
;; (mini-meval-params (cdr params) (push-local etat (car fixed) 'variable (car params)) (cdr fixed) optional rest key other aux))
|
||||
;; (if optional
|
||||
;; (let* ((var (caar optional))
|
||||
;; (value (if (endp params)
|
||||
;; (mini-meval (cadar optional) etat)
|
||||
;; (car params)))
|
||||
;; (svar (caddar optional))
|
||||
;; (new-etat (push-local etat var 'variable value)))
|
||||
;; (when svar (setq new-etat (push-local new-etat svar 'variable (endp params))))
|
||||
;; (mini-meval-params (cdr params) new-etat nil (cdr optional) rest key other aux))
|
||||
;; (if rest
|
||||
;; (mini-meval-params params (push-local etat (car rest) 'variable params) nil nil nil key other aux)
|
||||
;; ;; TODO : finir d'implémenter &key &allow-other-keys &aux &rest (et relire CLTL).
|
||||
;; etat))))
|
||||
; (if key
|
||||
; (let* ((keyword (first (car key)))
|
||||
; (var (second (car key)))
|
||||
|
|
@ -113,15 +299,15 @@
|
|||
; new-local)))
|
||||
; (mini-meval-params params global new-local-2 nil nil nil (cdr key) other aux)
|
||||
|
||||
(defun mini-meval-get-params-from-real (etat-global etat-local lambda-list effective-parameters)
|
||||
(defun mini-meval-get-params-from-real (etat lambda-list effective-parameters)
|
||||
"Lambda-list doit être déjà sliced."
|
||||
(funcall #'mini-meval-params effective-parameters etat-global etat-local
|
||||
(cdr (assoc 'fixed lambda-list))
|
||||
(cdr (assoc 'optional lambda-list))
|
||||
(cdr (assoc 'rest lambda-list))
|
||||
(cdr (assoc 'key lambda-list))
|
||||
(cdr (assoc 'other lambda-list))
|
||||
(cdr (assoc 'aux lambda-list))))
|
||||
(mini-meval-params effective-parameters etat
|
||||
(cdr (assoc 'fixed lambda-list)) ;; TODO : optimiser ça peut-être...
|
||||
(cdr (assoc 'optional lambda-list))
|
||||
(cdr (assoc 'rest lambda-list))
|
||||
(cdr (assoc 'key lambda-list))
|
||||
(cdr (assoc 'other lambda-list))
|
||||
(cdr (assoc 'aux lambda-list))))
|
||||
|
||||
(defun splice-up-tagbody-1 (todo-body body result)
|
||||
(if (endp todo-body)
|
||||
|
|
@ -137,12 +323,13 @@
|
|||
(defun splice-up-tagbody (body)
|
||||
(splice-up-tagbody-1 (reverse body) nil nil))
|
||||
|
||||
(defun mini-meval-error (expr etat-global etat-local &rest message)
|
||||
(error "~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w"
|
||||
(defun mini-meval-error (expr etat &rest message)
|
||||
(error "mini-meval : ~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w~&etat-special = ~w"
|
||||
(apply #'format nil message)
|
||||
expr
|
||||
etat-global
|
||||
etat-local))
|
||||
(etat-global etat)
|
||||
(etat-local etat)
|
||||
(etat-special etat)))
|
||||
|
||||
#|
|
||||
Mini-meval est un meval très simple destiné à évaluer les macros et les autres directives avec eval-when :compile-toplevel.
|
||||
|
|
@ -150,7 +337,7 @@ Mini-meval est un meval très simple destiné à évaluer les macros et les autr
|
|||
;; Fonctionnement de mini-meval
|
||||
Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il faut donc qu'il puisse maintenir son état entre les appels.
|
||||
|#
|
||||
(defun mini-meval (expr &optional (etat-global (cons nil nil)) etat-local)
|
||||
(defun mini-meval (expr &optional (etat (list nil nil nil)))
|
||||
#|
|
||||
L'algorithme d'évaluation est très simple et suit le schéma donné dans CLTL 5.1.3 :
|
||||
1) Si l'expression est une forme spéciale, on la traite de manière particulière
|
||||
|
|
@ -163,262 +350,307 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(cond-match
|
||||
expr
|
||||
((debug :id _?)
|
||||
(format t "~&debug :~& id = ~w~& global = ~w~& local = ~w" id etat-global etat-local))
|
||||
(format t "~&debug :~& id = ~w~& global = ~w~& local = ~w~&etat-special = ~w" id (etat-global etat) (etat-local etat) (etat-special etat)))
|
||||
#| 2) Cas des macros |#
|
||||
((:name $$ :params _*)
|
||||
(let ((definition (assoc* `(,name . macro) #'equal etat-local (cdr etat-global))))
|
||||
(let ((definition (assoc-etat name 'macro etat)))
|
||||
(if definition
|
||||
#| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |#
|
||||
(mini-meval (apply (cdr definition) params) etat-global etat-local)
|
||||
(mini-meval (apply (cdr definition) params) etat)
|
||||
(else))))
|
||||
#| 1) Cas des formes spéciales |#
|
||||
((eval-when :situations ($*) :body _*)
|
||||
(if (member :execute situations)
|
||||
(mini-meval body etat-global etat-local)
|
||||
(mini-meval body etat)
|
||||
nil))
|
||||
((flet ((:name $ :lambda-list @ :fbody _*)*) :body _*)
|
||||
(mini-meval `(progn ,@body)
|
||||
etat-global
|
||||
(reduce* etat-local (lambda (new-etat-local name lambda-list fbody)
|
||||
(acons `(,name . function)
|
||||
(mini-meval `(lambda ,lambda-list ,@fbody) etat-global etat-local)
|
||||
new-etat-local))
|
||||
name lambda-list fbody)))
|
||||
(reduce-on-local
|
||||
etat
|
||||
(lambda (ignore name lambda-list fbody) ignore
|
||||
(list name 'function (mini-meval `(lambda ,lambda-list ,@fbody) etat)))
|
||||
name lambda-list fbody)))
|
||||
((labels ((:name $ :lambda-list @ :fbody _*)*) :body _*)
|
||||
(let* ((new-bindings (reduce* nil (lambda (new-bindings name) `(((,name . function) . nil) . ,new-bindings))
|
||||
name))
|
||||
(new-etat-local (append new-bindings etat-local)))
|
||||
(mapcar (lambda (name lambda-list fbody)
|
||||
;; On fait un assoc / setf dans new-bindings, qui ne contient que les fonctions qu'on vient juste d'ajouter, pour éviter
|
||||
;; le risque inexistant de faire une mutation dans etat-local.
|
||||
;; TODO : vérifier que ça marche.
|
||||
(setf (cdr (assoc `(,name . function) new-bindings :test #'equal))
|
||||
(mini-meval `(lambda ,lambda-list ,@fbody) etat-global new-etat-local)))
|
||||
name lambda-list fbody)
|
||||
(mini-meval `(progn ,@body) etat-global new-etat-local)))
|
||||
(let* ((new-etat (reduce-on-local
|
||||
etat
|
||||
(lambda (ignore name) ignore (list name 'function nil))
|
||||
name))
|
||||
(new-etat-local (etat-local new-etat)))
|
||||
(dolist* ((name name) (lambda-list lambda-list) (fbody fbody))
|
||||
(setf (cdr (assoc `(,name . function) new-etat-local :test #'equal))
|
||||
(mini-meval `(lambda ,lambda-list ,@fbody) new-etat)))
|
||||
(mini-meval `(progn ,@body) new-etat)))
|
||||
((let ((:name $ :value _)*) :body _*)
|
||||
(mini-meval `(progn ,@body)
|
||||
etat-global
|
||||
(reduce* etat-local (lambda (new-etat-local name value)
|
||||
(acons `(,name . variable)
|
||||
(mini-meval value etat-global etat-local)
|
||||
new-etat-local))
|
||||
name value)))
|
||||
(let ((new-etat etat)
|
||||
(res nil))
|
||||
(dolist* ((name name) (value value))
|
||||
(setq new-etat (push-local-or-special new-etat name 'variable (mini-meval value etat) nil)))
|
||||
;; (new-etat (reduce-on-local
|
||||
;; etat
|
||||
;; (lambda (ignore name value) ignore
|
||||
;; (when (assoc-etat name 'constant etat) (error "mini-meval : Can't bind ~w : it is a constant." name))
|
||||
;; (setq association (assoc-special name 'variable etat))
|
||||
;; (when association
|
||||
;; (push (list association (mini-meval value etat) (cdr association)) restore-special))
|
||||
;; (unless association
|
||||
;; (list name 'variable (mini-meval value etat))))
|
||||
;; name value)))
|
||||
(affect-future-specials new-etat etat)
|
||||
;; (dolist (x restore-special) (setf (cdar x) (cadr x)))
|
||||
(setq res (mini-meval `(progn ,@body) new-etat))
|
||||
(pop-special-backups new-etat etat)
|
||||
res))
|
||||
;; (dolist (x restore-special) (setf (cdar x) (caddr x)))))
|
||||
(((? (eq x 'let*)) ((:name $ :value _)*) :body _*)
|
||||
(mini-meval `(progn ,@body)
|
||||
etat-global
|
||||
(reduce* etat-local (lambda (new-etat-local name value)
|
||||
(acons `(,name . variable)
|
||||
;; Comme let sauf new-etat-local au lieu de etat-local ici.
|
||||
(mini-meval value etat-global new-etat-local)
|
||||
new-etat-local))
|
||||
name value)))
|
||||
(let ((new-etat etat)
|
||||
(res nil))
|
||||
;; pour chaque variable
|
||||
(dolist* ((name name) (value value))
|
||||
(setq new-etat (push-local-or-special new-etat name 'variable (mini-meval value new-etat) t)))
|
||||
;; (new-etat (reduce-on-local
|
||||
;; etat
|
||||
;; (lambda (new-etat-local name value)
|
||||
;; (when (assoc-etat name 'constant etat) (error "mini-meval : Can't bind ~w : it is a constant." name))
|
||||
;; (setq association (assoc-special name 'variable etat))
|
||||
;; (when association
|
||||
;; (push (cons association (cdr association)) restore-special)
|
||||
;; (setf (cdr association) (mini-meval value (replace-local etat new-etat-local))))
|
||||
;; (unless association
|
||||
;; (list name 'variable (mini-meval value (replace-local etat new-etat-local)))))
|
||||
;; name value)))
|
||||
(setq res (mini-meval `(progn ,@body) new-etat))
|
||||
(pop-special-backups new-etat etat)
|
||||
res))
|
||||
;; (dolist (x restore-special) (setf (cdar x) (cdr x)))))
|
||||
((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*)
|
||||
(mini-meval `(progn ,@body)
|
||||
etat-global
|
||||
(reduce* etat-local (lambda (new-etat-local name lambda-list mbody)
|
||||
(acons `(,name . macro)
|
||||
;; comme le flet sauf nil au lieu de new-etat-local
|
||||
;; CLTL 7.5 :
|
||||
;; The precise rule is that the macro-expansion functions defined
|
||||
;; by macrolet are defined in the global environment; lexically
|
||||
;; scoped entities that would ordinarily be lexically apparent
|
||||
;; are not visible within the expansion functions.
|
||||
(mini-meval `(lambda ,lambda-list ,@mbody) etat-global nil)
|
||||
new-etat-local))
|
||||
name lambda-list mbody)))
|
||||
(let ((etat-sans-local (replace-local etat nil)))
|
||||
(reduce-on-local
|
||||
etat
|
||||
(lambda (ignore name lambda-list mbody) ignore
|
||||
;; comme le flet sauf nil au lieu de new-etat-local
|
||||
;; CLTL 7.5 :
|
||||
;; The precise rule is that the macro-expansion functions defined
|
||||
;; by macrolet are defined in the global environment; lexically
|
||||
;; scoped entities that would ordinarily be lexically apparent
|
||||
;; are not visible within the expansion functions.
|
||||
(list name 'macro
|
||||
(mini-meval `(lambda ,lambda-list ,@mbody) etat-sans-local)))
|
||||
name lambda-list mbody))))
|
||||
((progn :body _*)
|
||||
(car (last (mapcar (lambda (expr) (mini-meval expr etat-global etat-local))
|
||||
body))))
|
||||
(let ((res nil))
|
||||
(dolist (expr body res)
|
||||
(setq res (mini-meval expr etat)))))
|
||||
((if :condition _ :si-vrai _ :si-faux _?)
|
||||
(if (mini-meval condition etat-global etat-local)
|
||||
(mini-meval si-vrai etat-global etat-local)
|
||||
(if (mini-meval condition etat)
|
||||
(mini-meval si-vrai etat)
|
||||
(if si-faux
|
||||
(mini-meval (car si-faux) etat-global etat-local)
|
||||
(mini-meval (car si-faux) etat)
|
||||
nil)))
|
||||
((lambda :lambda-list @ :body _*)
|
||||
(let ((sliced-lambda-list (slice-up-lambda-list lambda-list)))
|
||||
(let ((sliced-lambda-list (slice-up-lambda-list lambda-list))
|
||||
(old-etat etat))
|
||||
(lambda (&rest effective-parameters)
|
||||
(mini-meval `(progn ,@body)
|
||||
etat-global
|
||||
(mini-meval-get-params-from-real etat-global etat-local sliced-lambda-list effective-parameters)))))
|
||||
(let* ((new-etat (mini-meval-get-params-from-real old-etat sliced-lambda-list effective-parameters))
|
||||
(res (mini-meval `(progn ,@body) new-etat)))
|
||||
(pop-special-backups new-etat etat)
|
||||
res))))
|
||||
((defun :name $ :lambda-list @ :body _*)
|
||||
(assoc-set `(,name . function)
|
||||
(mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local)
|
||||
(cdr etat-global)
|
||||
#'equal)
|
||||
(push-global! etat name 'function
|
||||
(mini-meval `(lambda ,lambda-list ,@body) etat))
|
||||
name)
|
||||
((defmacro :name $ :lambda-list @ :body _*)
|
||||
(assoc-set `(,name . macro)
|
||||
(mini-meval `(lambda ,lambda-list ,@body) etat-global etat-local)
|
||||
(cdr etat-global)
|
||||
#'equal)
|
||||
(push-global! etat name 'macro
|
||||
(mini-meval `(lambda ,lambda-list ,@body) etat))
|
||||
name)
|
||||
((defvar :name $ :value _)
|
||||
(assoc-set `(,name . variable)
|
||||
(mini-meval value etat-global etat-local)
|
||||
(cdr etat-global)
|
||||
#'equal)
|
||||
(when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't bind ~w : it is a constant." name))
|
||||
(let ((definition (assoc-etat name 'variable etat)))
|
||||
;; NOTE : if you do a "defvar" while in a "let" that binds the same variable, the result is gibberish and nonsensical.
|
||||
;; But that case is fairly rare and not worth the effort and run-time cost.
|
||||
(push-special! etat name 'variable
|
||||
(if definition
|
||||
(cdr definition)
|
||||
(mini-meval value etat))))
|
||||
name)
|
||||
((setq :name $ :value _)
|
||||
(let ((definition (assoc* `(,name . variable) #'equal etat-local (cdr etat-global))))
|
||||
(let ((definition (assoc-etat name 'variable etat))
|
||||
(real-value (mini-meval value etat))) ;; Faut-il vérifier que NAME n'est pas une constante *avant* de calculer la valeur ?
|
||||
(if definition
|
||||
(let ((real-value (mini-meval value etat-global etat-local)))
|
||||
(setf (cdr definition) real-value)
|
||||
real-value)
|
||||
(mini-meval `(defvar ,name ,value) etat-global etat-local))))
|
||||
(setf (cdr definition) real-value)
|
||||
(progn
|
||||
(when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't set ~w : it is a constant." name))
|
||||
(push-global! etat name 'variable (mini-meval value etat))))
|
||||
real-value))
|
||||
((function :name $$)
|
||||
(let ((definition (assoc* `(,name . function) #'equal etat-local (cdr etat-global))))
|
||||
(let ((definition (assoc-etat name 'function etat)))
|
||||
(if definition
|
||||
(cdr definition)
|
||||
(mini-meval-error expr etat-global etat-local "mini-meval : undefined function : ~w." name))))
|
||||
(mini-meval-error expr etat "Undefined function : ~w." name))))
|
||||
;; TODO : #'(lambda ...)
|
||||
((funcall :name _ :params _*)
|
||||
(apply (mini-meval name etat-global etat-local)
|
||||
(mapcar (lambda (x) (mini-meval x etat-global etat-local)) params)))
|
||||
(apply (mini-meval name etat)
|
||||
(mapcar (lambda (x) (mini-meval x etat)) params)))
|
||||
((apply :name _ :p1 _ :params _*)
|
||||
(let ((fun (mini-meval name etat-global etat-local))
|
||||
(args (mapcar (lambda (x) (mini-meval x etat-global etat-local)) (cons p1 params))))
|
||||
(let ((fun (mini-meval name etat))
|
||||
(args (mapcar (lambda (x) (mini-meval x etat)) (cons p1 params))))
|
||||
(apply fun (append (butlast args) (car (last args))))))
|
||||
((declaim _*)
|
||||
nil)
|
||||
((error :format _ :args _*)
|
||||
(error "mini-meval : fonction error appellée par le code, le message est :~&~w" (apply #'format nil format args)))
|
||||
((warn :format _ :args _*)
|
||||
(warn "mini-meval : fonction warn appellée par le code, le message est :~&~w" (apply #'format nil format args)))
|
||||
((go :target $$)
|
||||
(when (null target)
|
||||
(mini-meval-error expr etat-global etat-local "mini-meval : nil ne peut pas être une étiquette pour un return-from."))
|
||||
(let ((association (assoc* `(,target . tagbody-tag) #'equal etat-local etat-global)))
|
||||
(mini-meval-error expr etat "nil ne peut pas être une étiquette pour un go."))
|
||||
(let ((association (assoc `(,target . tagbody-tag) (etat-local etat) :test #'equal)))
|
||||
(if association
|
||||
(funcall (cdr association))
|
||||
(mini-meval-error expr etat-global etat-local "mini-meval : tentative de faire un go sur une étiquette qui n'existe pas ou plus : ~w.~&~w" target))))
|
||||
(mini-meval-error expr etat "tentative de faire un go sur une étiquette qui n'existe pas ou plus : ~w.~&~w" target))))
|
||||
((tagbody :body _*)
|
||||
(let ((spliced-body (splice-up-tagbody body))
|
||||
(next-tag nil)
|
||||
(new-etat-local nil))
|
||||
(new-etat nil))
|
||||
(tagbody
|
||||
init
|
||||
(setq new-etat-local
|
||||
(reduce* etat-local
|
||||
(lambda (new-etat-local tag)
|
||||
(acons `(,(car tag) . tagbody-tag)
|
||||
(lambda () (setq next-tag (car tag)) (go go-to-tag))
|
||||
new-etat-local))
|
||||
spliced-body))
|
||||
(setq new-etat
|
||||
(reduce-on-local
|
||||
etat
|
||||
(lambda (ignore tag) ignore
|
||||
(list (car tag) 'tagbody-tag
|
||||
(lambda () (setq next-tag (car tag)) (go go-to-tag))))
|
||||
spliced-body))
|
||||
go-to-tag
|
||||
(mini-meval `(progn ,@(cdr (assoc next-tag spliced-body)))
|
||||
etat-global
|
||||
new-etat-local))))
|
||||
(mini-meval `(progn ,@(cdr (assoc next-tag spliced-body)))
|
||||
new-etat))))
|
||||
((return-from :block-name $$ :value _)
|
||||
(let ((association (assoc* `(,block-name . block-name) #'equal etat-local etat-global)))
|
||||
(let ((association (assoc `(,block-name . block-name) (etat-local etat) :test #'equal)))
|
||||
(if association
|
||||
(funcall (cdr association) value)
|
||||
(mini-meval-error expr etat-global etat-local "mini-meval : tentative de faire un return-from pour un bloc qui n'existe pas ou plus : ~w." block-name))))
|
||||
(mini-meval-error expr etat "tentative de faire un return-from pour un bloc qui n'existe pas ou plus : ~w." block-name))))
|
||||
((block :block-name $$ :body _*)
|
||||
(block block-catcher
|
||||
(mini-meval `(progn ,@body) etat-global (acons `(,block-name . block-name)
|
||||
(lambda (x) (return-from block-catcher x))
|
||||
etat-local))))
|
||||
(mini-meval `(progn ,@body)
|
||||
(push-local etat block-name 'block-name (lambda (x) (return-from block-catcher x))))))
|
||||
((quote :val _)
|
||||
val)
|
||||
((function :fun (lambda _ . _))
|
||||
(mini-meval fun etat))
|
||||
#| Traitement des appels de fonction |#
|
||||
((:lambda (lambda @ _*) :params _*)
|
||||
#| - Si c'est une fonction anonyme, on l'exécute. |#
|
||||
(apply (mini-meval lambda etat-global etat-local) params))
|
||||
((:name $ :params _*)
|
||||
(let ((definition (assoc* `(,name . function) #'equal etat-local (cdr etat-global))))
|
||||
(apply (mini-meval lambda etat) params))
|
||||
(((function :fun (lambda _ . _)) :params . _)
|
||||
(mini-meval `(,fun ,@params) etat))
|
||||
((:name (function $$) :params _*)
|
||||
(apply (mini-meval name etat) params))
|
||||
((:name $$ :params _*)
|
||||
(let ((definition (assoc-etat name 'function etat)))
|
||||
(if definition
|
||||
#| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |#
|
||||
(apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat-global etat-local)) params))
|
||||
(mini-meval-error expr etat-global etat-local "mini-meval : undefined function : ~w." name))))
|
||||
(apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat)) params))
|
||||
(mini-meval-error expr etat "Undefined function : ~w." name))))
|
||||
((:num . (? numberp))
|
||||
num)
|
||||
((:str . (? stringp))
|
||||
str)
|
||||
(()
|
||||
(nil
|
||||
nil)
|
||||
((:name . $$)
|
||||
(let ((definition (assoc* `(,name . variable) #'equal etat-local (cdr etat-global))))
|
||||
(let ((definition (assoc-etat name 'variable etat)))
|
||||
(if definition
|
||||
(cdr definition)
|
||||
(mini-meval-error expr etat-global etat-local "mini-meval : undefined variable : ~w." name))))))
|
||||
(mini-meval-error expr etat "Undefined variable : ~w." name))))))
|
||||
|
||||
(defun push-functions (etat-global functions)
|
||||
(cons nil (mapcar-append (cdr etat-global) (lambda (x) `((,x . function) . ,(fdefinition x))) functions)))
|
||||
(defun push-functions (etat functions)
|
||||
(dolist (f functions)
|
||||
(push-global! etat f 'function (fdefinition f)))
|
||||
etat)
|
||||
|
||||
(defmacro etat-global-fn (&rest functions)
|
||||
`(push-functions '(nil) ',functions))
|
||||
(defmacro make-etat (&rest functions)
|
||||
`(push-functions (list nil nil nil) ',functions))
|
||||
|
||||
(load "test-unitaire")
|
||||
(require 'test-unitaire "test-unitaire")
|
||||
(erase-tests mini-meval)
|
||||
|
||||
(deftestvar mini-meval e-global (etat-global-fn list + - cons car cdr < > <= >= =))
|
||||
(deftestvar mini-meval etat (make-etat list + - cons car cdr < > <= >= =))
|
||||
|
||||
(deftest (mini-meval constante)
|
||||
(mini-meval 42 e-global nil)
|
||||
(mini-meval 42 etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval appel-fonction)
|
||||
(mini-meval '(+ 2 3) e-global nil)
|
||||
(mini-meval '(+ 2 3) etat)
|
||||
5)
|
||||
|
||||
(deftest (mini-meval appel-fonction)
|
||||
(mini-meval '(+ 2 (+ 3 4)) e-global nil)
|
||||
(mini-meval '(+ 2 (+ 3 4)) etat)
|
||||
9)
|
||||
|
||||
(deftest (mini-meval variable)
|
||||
(mini-meval 'x e-global (acons '(x . variable) 42 nil))
|
||||
(mini-meval 'x (push-local etat 'x 'variable 42))
|
||||
42)
|
||||
|
||||
(deftest (mini-meval appel-fonction-et-variable)
|
||||
(mini-meval '(+ x x 3) e-global (acons '(x . variable) 42 nil))
|
||||
(mini-meval '(+ x x 3) (push-local etat 'x 'variable 42))
|
||||
87)
|
||||
|
||||
(deftest (mini-meval appel-fonction-et-variable)
|
||||
(mini-meval '(+ x (+ 3 x)) e-global (acons '(x . variable) 42 nil))
|
||||
(mini-meval '(+ x (+ 3 x)) (push-local etat 'x 'variable 42))
|
||||
87)
|
||||
|
||||
(deftest (mini-meval lambda extérieur)
|
||||
(funcall (mini-meval '(lambda (x) x) e-global nil) 3)
|
||||
(funcall (mini-meval '(lambda (x) x) etat) 3)
|
||||
3)
|
||||
|
||||
(deftest (mini-meval lambda extérieur)
|
||||
(funcall (mini-meval '(lambda (x) (+ x 3)) e-global nil) 4)
|
||||
(funcall (mini-meval '(lambda (x) (+ x 3)) etat) 4)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval lambda immédiat)
|
||||
(mini-meval '((lambda (x) (+ x 3)) 4) e-global nil)
|
||||
(mini-meval '((lambda (x) (+ x 3)) 4) etat)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval let)
|
||||
(mini-meval '(let ((x 3) (y 4)) (+ x y)) e-global nil)
|
||||
(mini-meval '(let ((x 3) (y 4)) (+ x y)) etat)
|
||||
7)
|
||||
|
||||
(deftest (mini-meval let)
|
||||
(mini-meval '(let ((x 3) (y 4) (z 5)) (let ((z (+ x y)) (w z)) (list x y z w))) e-global nil)
|
||||
(mini-meval '(let ((x 3) (y 4) (z 5)) (let ((z (+ x y)) (w z)) (list x y z w))) etat)
|
||||
'(3 4 7 5))
|
||||
|
||||
(deftest (mini-meval let*)
|
||||
(mini-meval '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) e-global nil)
|
||||
(mini-meval '(let ((x 3) (y 4) (z 5)) (let* ((z (+ x y)) (w z)) (list x y z w))) etat)
|
||||
'(3 4 7 7))
|
||||
|
||||
(deftest (mini-meval progn)
|
||||
(mini-meval '(progn 1 2 3 4) e-global nil)
|
||||
(mini-meval '(progn 1 2 3 4) etat)
|
||||
4)
|
||||
|
||||
(deftest (mini-meval defvar)
|
||||
(mini-meval '(progn (defvar x 42) x) e-global nil)
|
||||
(mini-meval '(progn (defvar x 42) x) etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval defvar special)
|
||||
(mini-meval '(progn
|
||||
(defun foo1 () var)
|
||||
(defun foo2 () (let ((var 4)) (list var (foo1))))
|
||||
(defvar var 123)
|
||||
(list (foo1) (foo2)))
|
||||
etat)
|
||||
'(123 (4 4)))
|
||||
|
||||
(deftest (mini-meval defun)
|
||||
(mini-meval '(progn (defun double (x) (+ x x)) (double 3)) e-global nil)
|
||||
(mini-meval '(progn (defun double (x) (+ x x)) (double 3)) etat)
|
||||
6)
|
||||
|
||||
(deftest (mini-meval quote)
|
||||
(mini-meval ''x e-global nil)
|
||||
(mini-meval ''x etat)
|
||||
'x)
|
||||
|
||||
(deftest (mini-meval defmacro)
|
||||
(mini-meval '(progn (defmacro qlist (x y) (list 'list (list 'quote x) (list 'quote y))) (qlist a b)) e-global nil)
|
||||
(mini-meval '(progn (defmacro qlist (x y) (list 'list (list 'quote x) (list 'quote y))) (qlist a b)) etat)
|
||||
'(a b))
|
||||
|
||||
(deftest (mini-meval macrolet)
|
||||
|
|
@ -429,49 +661,61 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(macrolet ((qlist (x y) (list 'list (list 'quote x) (list 'quote y))))
|
||||
(qlist 'a 'b))
|
||||
(qlist 'a 'b)))
|
||||
e-global nil)
|
||||
etat)
|
||||
'((a b) ('a 'b) (a b)))
|
||||
|
||||
(deftest (mini-meval setf setq)
|
||||
(mini-meval '(list (defvar x 42) x (setq x 123) x) e-global nil)
|
||||
(mini-meval '(list (defvar x 42) x (setq x 123) x) etat)
|
||||
'(x 42 123 123))
|
||||
|
||||
(deftest (mini-meval funcall)
|
||||
(mini-meval '(funcall #'+ 1 2 3) e-global nil)
|
||||
(mini-meval '(funcall #'+ 1 2 3) etat)
|
||||
'6)
|
||||
|
||||
(deftest (mini-meval apply)
|
||||
(mini-meval '(apply #'+ 1 2 (list (+ 1 2) 4)) e-global nil)
|
||||
(mini-meval '(apply #'+ 1 2 (list (+ 1 2) 4)) etat)
|
||||
'10)
|
||||
|
||||
(deftest (mini-meval function external)
|
||||
(mini-meval '#'+ e-global nil)
|
||||
(mini-meval '#'+ etat)
|
||||
#'+)
|
||||
|
||||
(deftest (mini-meval function external)
|
||||
(mini-meval '(funcall #'+ 1 2 3) e-global nil)
|
||||
(mini-meval '(funcall #'+ 1 2 3) etat)
|
||||
'6)
|
||||
|
||||
(deftest (mini-meval call-function external)
|
||||
(mini-meval '(#'+ 2 3) etat)
|
||||
5)
|
||||
|
||||
(deftest (mini-meval function internal)
|
||||
(funcall (mini-meval '(progn (defun foo (x) (+ x 40)) #'foo) e-global nil) 2)
|
||||
(funcall (mini-meval '(progn (defun foo (x) (+ x 40)) #'foo) etat) 2)
|
||||
'42)
|
||||
|
||||
(deftest (mini-meval function internal)
|
||||
(mini-meval '(progn (defun foo (x) (+ x 40)) (funcall #'foo 2)) e-global nil)
|
||||
(mini-meval '(progn (defun foo (x) (+ x 40)) (funcall #'foo 2)) etat)
|
||||
'42)
|
||||
|
||||
(deftest (mini-meval function internal)
|
||||
(mini-meval '(progn (defvar bar (list (lambda (x) (+ x 40)) 1 2 3)) (funcall (car bar) 2)) e-global nil)
|
||||
(mini-meval '(progn (defvar bar (list (lambda (x) (+ x 40)) 1 2 3)) (funcall (car bar) 2)) etat)
|
||||
'42)
|
||||
|
||||
(deftest (mini-meval call-function internal)
|
||||
(mini-meval '(progn (defun foo (x) (+ x 40)) (#'foo 2)) etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval call-function lambda)
|
||||
(mini-meval '(#'(lambda (x) (+ x 40)) 2) etat)
|
||||
42)
|
||||
|
||||
(deftest (mini-meval lambda optional)
|
||||
(mini-meval '((lambda (x &optional (y 2)) (list x y)) 1) e-global nil)
|
||||
(mini-meval '((lambda (x &optional (y 2)) (list x y)) 1) etat)
|
||||
'(1 2))
|
||||
|
||||
(deftest (mini-meval lambda closure single-instance)
|
||||
(mini-meval '(progn
|
||||
(defvar foo (let ((y 1)) (cons (lambda (x) (list x y)) (lambda (z) (setq y (+ y z)) nil))))
|
||||
(list (funcall (car foo) 4) (funcall (cdr foo) 5) (funcall (car foo) 4))) e-global nil)
|
||||
(list (funcall (car foo) 4) (funcall (cdr foo) 5) (funcall (car foo) 4))) etat)
|
||||
'((4 1) nil (4 6)))
|
||||
|
||||
(deftest (mini-meval lambda closure multiple-instances)
|
||||
|
|
@ -492,7 +736,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(funcall (cdr foo0) 5) ;; add 0 (+ 5)
|
||||
(funcall (car foo42)) ;; show 42
|
||||
(funcall (car foo0)))) ;; show 0
|
||||
e-global nil)
|
||||
etat)
|
||||
'(0 42 nil 1 nil 43 1 43 nil nil 49 6))
|
||||
|
||||
(deftest (mini-meval labels)
|
||||
|
|
@ -501,7 +745,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(foo 3)
|
||||
(labels ((foo (x) (+ x 3)))
|
||||
(foo 3)))
|
||||
e-global nil)
|
||||
etat)
|
||||
'(foo 4 6))
|
||||
|
||||
(deftest (mini-meval flet)
|
||||
|
|
@ -510,11 +754,11 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(foo 3)
|
||||
(flet ((foo (x) (+ x 3)))
|
||||
(foo 3)))
|
||||
e-global nil)
|
||||
etat)
|
||||
'(foo 4 6))
|
||||
|
||||
(deftest (mini-meval labels)
|
||||
(mini-meval '(< 2 3) e-global nil)
|
||||
(mini-meval '(< 2 3) etat)
|
||||
t)
|
||||
|
||||
(deftest (mini-meval labels)
|
||||
|
|
@ -523,7 +767,7 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(fibo 5)
|
||||
(labels ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
|
||||
(fibo 5)))
|
||||
e-global nil)
|
||||
etat)
|
||||
'(fibo 8 5))
|
||||
|
||||
(deftest (mini-meval flet)
|
||||
|
|
@ -532,13 +776,13 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau
|
|||
(fibo 5)
|
||||
(flet ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ...
|
||||
(fibo 5)))
|
||||
e-global nil)
|
||||
etat)
|
||||
;; Le flet ne permet pas les définitions récursives, donc le fibo
|
||||
;; de l'extérieur est appellé après le 1er niveau de récursion.
|
||||
'(fibo 8 8))
|
||||
|
||||
(deftest-error (mini-meval error)
|
||||
(mini-meval '(error "Some user error message.") (cons nil nil) nil))
|
||||
(mini-meval '(error "Some user error message.")))
|
||||
|
||||
(deftest (mini-meval tagbody)
|
||||
(mini-meval '(let ((x 0)) (tagbody foo (setq x 1) (go baz) bar (setq x 2) baz) x))
|
||||
|
|
|
|||
24
util.lisp
24
util.lisp
|
|
@ -175,4 +175,28 @@
|
|||
(defun find-what-is-used (expr)
|
||||
(remove-duplicates (find-what-is-used-1 expr)))
|
||||
|
||||
(defmacro dolist* (spec &rest body)
|
||||
(let* ((vars (mapcar #'car spec))
|
||||
(listforms (mapcar #'cadr spec))
|
||||
(loopsym (make-symbol "loop"))
|
||||
(endsym (make-symbol "end"))
|
||||
(listsyms (mapcar (lambda (x) (cons x (make-symbol "list"))) vars)))
|
||||
`(let (,@(mapcar (lambda (var) `(,var nil)) vars)
|
||||
,@(mapcar (lambda (ls val) `(,(cdr ls) ,val)) listsyms listforms))
|
||||
(tagbody
|
||||
,loopsym
|
||||
,@(mapcar (lambda (ls)
|
||||
`(setq ,(car ls) (car ,(cdr ls))))
|
||||
listsyms)
|
||||
,@(mapcar (lambda (ls)
|
||||
`(when (endp ,(cdr ls))
|
||||
(go ,endsym)))
|
||||
listsyms)
|
||||
(progn ,@body)
|
||||
,@(mapcar (lambda (ls)
|
||||
`(setq ,(cdr ls) (cdr ,(cdr ls))))
|
||||
listsyms)
|
||||
(go ,loopsym)
|
||||
,endsym))))
|
||||
|
||||
(provide 'util)
|
||||
Loading…
Reference in New Issue
Block a user