mini-meval.lisp (29000B)
1 (require 'match "match") 2 (require 'util "util") 3 4 ;; TODO : Quand l'ancienne valeur d'une variable spéciale est sauvegardée par un let, si il y a un throw pendant ce temps-là, elle n'est pas restaurée. 5 ;; CLTL 7.11 : Intervening dynamic bindings of special variables and catch tags are undone. 6 ;; TODO : Les variables spéciales ne sont probablement pas correctement capturées par un lambda. 7 8 (defmacro etat-local (etat) 9 `(car ,etat)) 10 11 (defmacro etat-global (etat) 12 `(cadr ,etat)) 13 14 (defmacro etat-special (etat) 15 ;; Variables spéciales et constantes. (ou devrait-on mettre les constantes dans etat-global ?) 16 ;; Note sur les constantes : On ne protège pas contre la modification de parties d'une constante non atomique (mais clisp non plus, donc ça va). 17 `(caddr ,etat)) 18 19 (defun assoc-etat (var type etat) 20 (let ((search (cons var type))) 21 (or (assoc search (etat-special etat) :test #'equal) 22 (assoc search (etat-local etat) :test #'equal) 23 (assoc search (etat-global etat) :test #'equal)))) 24 25 (defun assoc-special (var type etat) 26 (assoc (cons var type) (etat-special etat) :test #'equal)) 27 28 (defun replace-local (etat new-etat-local) 29 (cons new-etat-local (cdr etat))) 30 31 (defun push-local (etat var type value) 32 (when (and (eq type 'variable) (assoc-etat var 'constant etat)) 33 (error "mini-meval : Can't bind ~w : it is a constant." var)) 34 (replace-local etat (acons (cons var type) value (etat-local etat)))) 35 36 (defun push-local-or-special (etat var type value immediate) 37 (let ((association (assoc-special var type etat)) 38 (new-etat nil)) 39 (if association 40 (progn 41 (setq new-etat (push-local etat var 'special-bakcup (cons association (cdr association)))) 42 (if immediate 43 (progn (setf (cdr association) value) 44 new-etat) 45 (push-local new-etat var 'special-future-phantom (cons association value)))) 46 (push-local etat var 'variable value)))) 47 48 (defun affect-future-specials (new-etat etat) 49 (setq new-etat (etat-local new-etat)) 50 (setq etat (etat-local etat)) 51 (tagbody 52 loop 53 (when (eq new-etat etat) (go fin)) 54 (when (eq (cdaar new-etat) 'special-future-phantom) 55 (setf (cdr (cadar new-etat)) (cddar new-etat))) 56 (setq new-etat (cdr new-etat)) 57 (go loop) 58 fin)) 59 60 (defun pop-special-backups (new-etat etat) 61 (setq new-etat (etat-local new-etat)) 62 (setq etat (etat-local etat)) 63 (tagbody 64 loop 65 (when (eq new-etat etat) (go fin)) 66 (when (eq (cdaar new-etat) 'special-bakcup) 67 (setf (cdr (cadar new-etat)) (cddar new-etat))) 68 (setq new-etat (cdr new-etat)) 69 (go loop) 70 fin)) 71 72 (defun push-global! (etat name type value) 73 (setf (etat-global etat) (acons (cons name type) value (etat-global etat))) 74 etat) 75 76 (defun push-special! (etat name type value) 77 (setf (etat-special etat) (acons (cons name type) value (etat-special etat))) 78 etat) 79 80 (defun reduce-on-local-1 (new-etat-local callback lists) 81 (let ((res nil)) 82 (tagbody 83 loop 84 (when (member nil lists) (go fin)) 85 (setq res (apply callback new-etat-local (mapcar #'car lists))) 86 (setq new-etat-local (acons (cons (car res) (cadr res)) 87 (caddr res) 88 new-etat-local)) 89 (setq lists (mapcar #'cdr lists)) 90 (go loop) 91 fin) 92 new-etat-local)) 93 94 (defun reduce-on-local (etat callback &rest lists) 95 (if (null lists) 96 etat 97 (replace-local etat (reduce-on-local-1 (etat-local etat) callback lists)))) 98 99 ;; DONE 100 ;; - loop 101 ;; - dolist / dotimes 102 ;; - match-automaton(tagbody+block) 103 104 ;; HALF-DONE (TODO) 105 ;; - read 106 ;; - warn 107 ;; - ` (quasiquote) 108 109 ;; TODO (dans mini-meval et/ou compilateur) : 110 ;; - syntaxe courte du let 111 ;; - declaim 112 ;; - format 113 ;; - setf (écrire la macro) 114 ;; - fdefinition, funcctionp, … 115 ;; - symbolp, keywordp, keywords non mutables + nil et t, intern, make-symbol 116 ;; - car / cdr, replaca replacad, cons, list (fonction), listp, consp, atom, null (ou eq nil), … 117 ;; - and / or (macros => if) 118 ;; - &rest 119 ;; - eq (vérifier qu'on préserve bien l'égalité de pointeurs là où il faut) / = / eql / equal / equalp 120 ;; - load / open / close 121 ;; - defvar [done mini-meval] (gestion correcte des variables spéciales) 122 ;; - array support (array-total-size, row-major-aref, copy-seq) 123 ;; - string support (char=, map, string (symbol => string), format, print) 124 ;; - coder un reverse rapide. 125 ;; - transformation de la récursion terminale. 126 127 ;; - vérifier qu'on a pas transformé certaines fonctions en formes spéciales (il faut qu'on puisse toujours les récupérer avec #'). 128 ;; - sortir le defun du mini-meval ? 129 130 ;; cell (un seul pointeur, transparent (y compris pour le type), 131 ;; avec trois fonctions spéciales pour le get / set / tester le type), 132 ;; sera utilisé pour les closures et les variables spéciales. 133 134 ;; TODO : bug : pourquoi les keyword-to-symbol ??? on devrait garder le keyword tel quel. 135 (defun slice-up-lambda-list (lambda-list) 136 (match-automaton lambda-list fixed 137 (fixed accept) 138 (fixed optional &optional) 139 (fixed rest &rest) 140 (fixed key &key) 141 (fixed aux &aux) 142 (fixed reject $&) 143 (fixed fixed (:var . $$) var) 144 (optional accept) 145 (optional rest &rest) 146 (optional key &key) 147 (optional aux &aux) 148 (optional reject $&) 149 (optional optional (:var . $$) `(,var nil nil)) 150 (optional optional (:var $$ :default _? :svar $$?) `(,var ,(car default) ,(car svar))) 151 (rest reject $&) 152 (rest rest2 (:var . $$) var) 153 (rest2 accept) 154 (rest2 key &key) 155 (rest2 aux &aux) 156 (rest2 reject $&) 157 (key accept) 158 (key other &allow-other-keys) 159 (key aux &aux) 160 (key reject $&) 161 (key key (:keyword . $k) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) nil nil)) ;; Not in the standard ! 162 (key key (:var . $$) `(,var ,var nil nil)) 163 (key key (:keyword $$ :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) ,(car default) ,(car svar))) ;; Not in the standard ! 164 (key key (:var $$ :default _? :svar $$?) `(,var ,var ,(car default) ,(car svar))) 165 (key key ((:keyword $k :var $$) :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,var ,(car default) ,(car svar))) 166 (other collect t) 167 (other accept) 168 (other aux &aux) 169 (other reject $&) 170 (aux accept) 171 (aux reject $&) 172 (aux aux (:var . $$) `(,var nil)) 173 (aux aux (:var $$ :default _?) `(,var ,(car default))) 174 (reject (error "slice-up-lambda-list : ~w ne peut être ici." last-element)))) 175 176 ;; Exemples : 177 ;; TODO : en faire des tests unitaires. 178 ;; (slice-up-lambda-list '(a b &optional u &rest c &key ((:foo bar)) :quux (:baz 'glop) &aux (x 1) (y (+ x 2)))) 179 ;; (slice-up-lambda-list '(a b &rest)) 180 ;; (slice-up-lambda-list '(a b)) 181 182 (declaim (ftype function mini-meval)) ;; récursion mutuelle mini-meval-get-params-from-real -> mini-meval-params / mini-meval 183 (defun mini-meval-params (params etat fixed optional rest key other aux) 184 (let ((new-etat etat) 185 (value nil) 186 (svar nil) 187 (current-key) 188 (search-key) 189 (seen-keys)) 190 (tagbody 191 fixed 192 (when (endp fixed) (go end-fixed)) 193 (when (endp params) (error "mini-meval-params : not enough parameters !")) 194 (setq new-etat (push-local-or-special new-etat (car fixed) 'variable (car params) nil)) 195 (setq params (cdr params)) 196 (setq fixed (cdr fixed)) 197 (go fixed) 198 end-fixed 199 (affect-future-specials new-etat etat) 200 optional 201 (when (endp optional) (go rest)) 202 (if (endp params) 203 (setq value (mini-meval (cadar optional) new-etat)) ;; default value 204 (setq value (car params))) 205 (setq new-etat (push-local-or-special new-etat (caar optional) 'variable value t)) 206 (setq svar (caddar optional)) 207 (when svar 208 (setq new-etat (push-local-or-special new-etat svar 'variable (endp params) t))) 209 (setq params (cdr params)) 210 (setq optional (cdr optional)) 211 (go optional) 212 rest 213 (unless rest (go key)) 214 (setq new-etat (push-local new-etat (car rest) 'variable params)) 215 key 216 (when (or (endp key) (endp params)) (go defaults-keys)) 217 (when (endp (cdr params)) (error "mini-meval-params : odd number of key parameters")) 218 (setq search-key (keyword-to-symbol (car params))) 219 (when (eq search-key (caar key)) 220 (setq current-key (car key)) 221 (push (car current-key) seen-keys) 222 (setq key (cdr key)) 223 (go end-assoc-key-loop)) 224 assoc-key-loop 225 (when (endp (cdr key)) 226 (go unknown-key)) 227 (when (eq search-key (caadr key)) 228 (setq current-key (cadr key)) 229 (push (car current-key) seen-keys) 230 (setf (cdr key) (cddr key)) 231 (go end-assoc-key-loop)) 232 (go assoc-key-loop) 233 end-assoc-key-loop 234 (setq new-etat (push-local-or-special new-etat (second current-key) 'variable (second params) t)) 235 (setq svar (fourth current-key)) 236 (when svar 237 (setq new-etat (push-local-or-special new-etat svar 'variable t t))) 238 (go after-unknown-key) 239 unknown-key 240 (unless (or other (member search-key seen-keys)) 241 (error "mini-meval-params : invalid key : ~w" (car params))) 242 after-unknown-key 243 (setq key (cdr key)) 244 (setq params (cddr params)) 245 defaults-keys 246 (dolist (k key) 247 (setq new-etat (push-local-or-special new-etat (second k) 'variable (mini-meval (third k) new-etat) t)) 248 (setq svar (fourth k)) 249 (when svar 250 (setq new-etat (push-local-or-special new-etat svar 'variable nil t)))) 251 aux 252 (when (endp aux) (go fin)) 253 (setq new-etat (push-local-or-special new-etat (caar aux) 'variable (mini-meval (cadar aux) new-etat) t)) 254 (setq aux (cdr aux)) 255 fin) 256 new-etat)) 257 258 (defun mini-meval-get-params-from-real (etat lambda-list effective-parameters) 259 "Lambda-list doit être déjà sliced." 260 (mini-meval-params effective-parameters etat 261 (cdr (assoc 'fixed lambda-list)) ;; TODO : optimiser ça peut-être... 262 (cdr (assoc 'optional lambda-list)) 263 (cdr (assoc 'rest lambda-list)) 264 (cdr (assoc 'key lambda-list)) 265 (cdr (assoc 'other lambda-list)) 266 (cdr (assoc 'aux lambda-list)))) 267 268 (defun splice-up-tagbody-1 (remaining-body body result) 269 (if (endp remaining-body) 270 (acons nil body result) 271 (if (or (symbolp (car remaining-body)) (numberp (car remaining-body))) 272 (splice-up-tagbody-1 (cdr remaining-body) 273 body 274 (acons (car remaining-body) body result)) 275 (splice-up-tagbody-1 (cdr remaining-body) 276 (cons (car remaining-body) body) 277 result)))) 278 279 (defun splice-up-tagbody (body) 280 (splice-up-tagbody-1 (reverse body) nil nil)) 281 282 (defun mini-meval-error (expr etat &rest message) 283 (error "mini-meval (outer) : ~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w~&etat-special = ~w" 284 (apply #'format nil message) 285 expr 286 nil nil nil)) 287 ; (etat-global etat) 288 ; (etat-local etat) 289 ; (etat-special etat))) 290 291 ;; ` 292 (defvar my-quasiquote (car '`(,a))) 293 294 ;; , 295 (defvar my-unquote (caaadr '`(,a))) 296 297 ;; ,@ 298 (defvar my-unquote-splice (caaadr '`(,@a))) 299 300 (defun transform-quasiquote (expr) 301 (cond 302 ;; a 303 ((atom expr) 304 `',expr) 305 ;; (a) 306 ((atom (car expr)) 307 `(cons ',(car expr) 308 ,(transform-quasiquote (cdr expr)))) 309 ;; (,a) 310 ((eq my-unquote (caar expr)) 311 `(cons ,(cadar expr) 312 ,(transform-quasiquote (cdr expr)))) 313 ;; (,@a) 314 ((eq my-unquote-splice (caar expr)) 315 (if (endp (cdr expr)) 316 (cadar expr) 317 `(append ,(cadar expr) 318 ,(transform-quasiquote (cdr expr))))) 319 ;; ((a ...) ...) 320 (T 321 `(cons ,(transform-quasiquote (car expr)) 322 ,(transform-quasiquote (cdr expr)))))) 323 324 325 #| 326 Mini-meval est un meval très simple destiné à évaluer les macros et les autres directives avec eval-when :compile-toplevel. 327 328 ;; Fonctionnement de mini-meval 329 Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il faut donc qu'il puisse maintenir son état entre les appels. 330 |# 331 (defun mini-meval (expr &optional (etat (list nil nil nil))) 332 #| 333 L'algorithme d'évaluation est très simple et suit le schéma donné dans CLTL 5.1.3 : 334 1) Si l'expression est une forme spéciale, on la traite de manière particulière 335 2) Si l'expression est un appel de macro, on évalue le corps de la macro avec les paramètres tels quels (non évalués), 336 puis on remplace l'appel par son résutlat, et on évalue ce résultat. 337 3) Sinon, c'est un appel de fonction. 338 Pour permettre au code de bas niveau de redéfinir les formes spéciales, on fera d'abord la macro-expansion (étape 2). 339 |# 340 ;(print 341 (cond-match 342 expr 343 (((? (eq x my-quasiquote)) :val _) 344 (mini-meval (transform-quasiquote val) etat)) 345 #| 2) Cas des macros |# 346 ((:name $$ :params _*) 347 (let ((definition (assoc-etat name 'macro etat))) 348 (if definition 349 (mini-meval (apply (cdr definition) params) etat) 350 (else)))) 351 #| 1) Cas des formes spéciales |# 352 ((eval-when :situations ($*) :body _*) 353 (if (member :execute situations) 354 (mini-meval `(progn ,@body) etat) 355 nil)) 356 ((flet ((:name $ :lambda-list @ :fbody _*)*) :body _*) 357 (mini-meval `(progn ,@body) 358 (reduce-on-local 359 etat 360 (lambda (ignore name lambda-list fbody) ignore 361 (list name 'function (mini-meval `(lambda ,lambda-list ,@fbody) etat))) 362 name lambda-list fbody))) 363 ((labels ((:name $ :lambda-list @ :fbody _*)*) :body _*) 364 (let* ((new-etat (reduce-on-local 365 etat 366 (lambda (ignore name) ignore (list name 'function nil)) 367 name)) 368 (new-etat-local (etat-local new-etat))) 369 (dolist* ((name name) (lambda-list lambda-list) (fbody fbody)) 370 (setf (cdr (assoc `(,name . function) new-etat-local :test #'equal)) 371 (mini-meval `(lambda ,lambda-list ,@fbody) new-etat))) 372 (mini-meval `(progn ,@body) new-etat))) 373 ;; Transformation des (let[*] (var1 var2 var3) …) en (let[*] ((var1 nil) (var2 nil) (var3 nil)) …) 374 ((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _) 375 (mini-meval `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body))) 376 ((let ((:name $ :value _)*) :body _*) 377 (let ((new-etat etat) 378 (res nil)) 379 (dolist* ((name name) (value value)) 380 (setq new-etat (push-local-or-special new-etat name 'variable (mini-meval value etat) nil))) 381 (affect-future-specials new-etat etat) 382 (setq res (mini-meval `(progn ,@body) new-etat)) 383 (pop-special-backups new-etat etat) 384 res)) 385 (((? (eq x 'let*)) ((:name $ :value _)*) :body _*) 386 (let ((new-etat etat) 387 (res nil)) 388 ;; pour chaque variable 389 (dolist* ((name name) (value value)) 390 (setq new-etat (push-local-or-special new-etat name 'variable (mini-meval value new-etat) t))) 391 (setq res (mini-meval `(progn ,@body) new-etat)) 392 (pop-special-backups new-etat etat) 393 res)) 394 ((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*) 395 (let ((new-etat 396 (reduce-on-local 397 etat 398 (lambda (ignore name lambda-list mbody) ignore 399 ;; comme le flet sauf nil au lieu de new-etat-local 400 ;; CLTL 7.5 : 401 ;; The precise rule is that the macro-expansion functions defined 402 ;; by macrolet are defined in the global environment; lexically 403 ;; scoped entities that would ordinarily be lexically apparent 404 ;; are not visible within the expansion functions. 405 (list name 'macro 406 (mini-meval `(lambda ,lambda-list ,@mbody) (replace-local etat nil)))) 407 name lambda-list mbody)) 408 (get-etat (assoc-etat 'trapdoor 'squash-trapdoor etat))) 409 (if (and get-etat (eq (car body) (cdr get-etat))) 410 new-etat ;; Trapdoor pour récupérer l'etat avec les définitions du macrolet. 411 (mini-meval `(progn ,@body) new-etat)))) 412 ((progn :body _*) 413 (let ((res nil)) 414 (dolist (expr body res) 415 (setq res (mini-meval expr etat))))) 416 ((if :condition _ :si-vrai _ :si-faux _?) 417 (if (mini-meval condition etat) 418 (mini-meval si-vrai etat) 419 (if si-faux 420 (mini-meval (car si-faux) etat) 421 nil))) 422 ((lambda :lambda-list @ :body _*) 423 (let ((sliced-lambda-list (slice-up-lambda-list lambda-list)) 424 (old-etat etat)) 425 (lambda (&rest effective-parameters) 426 (let* ((new-etat (mini-meval-get-params-from-real old-etat sliced-lambda-list effective-parameters)) 427 (res (mini-meval `(progn ,@body) new-etat))) 428 (pop-special-backups new-etat etat) 429 res)))) 430 ;; Lorsqu'une fonction "littérale" est présente dans le code, on la renvoie telle qu'elle. 431 ((? functionp) 432 expr) 433 ((defun :name $ :lambda-list @ :body _*) 434 (push-global! etat name 'function 435 (mini-meval `(lambda ,lambda-list ,@body) etat)) 436 name) 437 ((defmacro :name $ :lambda-list @ :body _*) 438 (push-global! etat name 'macro 439 (mini-meval `(lambda ,lambda-list ,@body) etat)) 440 name) 441 ((defvar :name $ :value _) 442 (when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't bind ~w : it is a constant." name)) 443 (let ((definition (assoc-etat name 'variable etat))) 444 ;; NOTE : if you do a "defvar" while in a "let" that binds the same variable, the result is gibberish and nonsensical. 445 ;; But that case is fairly rare and not worth the effort and run-time cost. 446 (push-special! etat name 'variable 447 (if definition 448 (cdr definition) 449 (mini-meval value etat)))) 450 name) 451 ((setq :name $ :value _) 452 (let ((definition (assoc-etat name 'variable etat)) 453 (real-value (mini-meval value etat))) ;; Faut-il vérifier que NAME n'est pas une constante *avant* de calculer la valeur ? 454 (if definition 455 (setf (cdr definition) real-value) 456 (progn 457 (when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't set ~w : it is a constant." name)) 458 (push-global! etat name 'variable (mini-meval value etat)))) 459 real-value)) 460 ((declaim _*) 461 nil) 462 ((error :format _ :args _*) 463 (error "mini-meval : fonction error appellée par le code, le message est :~&~w" (apply #'format nil format args))) 464 ((warn :format _ :args _*) 465 (warn "mini-meval : fonction warn appellée par le code, le message est :~&~w" (apply #'format nil format args))) 466 ((go :target (? or symbolp numberp)) 467 (when (null target) 468 (mini-meval-error expr etat "nil ne peut pas être une étiquette pour un go.")) 469 (let ((association (assoc `(,target . tagbody-tag) (etat-local etat) :test #'equal))) 470 (if association 471 (funcall (cdr association)) 472 (mini-meval-error expr etat "tentative de faire un go sur une étiquette qui n'existe pas ou plus : ~w.~&~w" target)))) 473 ((tagbody :body _*) 474 (let ((spliced-body (splice-up-tagbody body)) 475 (next-tag nil) 476 (new-etat nil)) 477 (tagbody 478 init 479 (setq new-etat 480 (reduce-on-local 481 etat 482 (lambda (ignore tag) ignore 483 (list (car tag) 'tagbody-tag 484 (lambda () (setq next-tag (car tag)) (go go-to-tag)))) 485 spliced-body)) 486 go-to-tag 487 (mini-meval `(progn ,@(cdr (assoc next-tag spliced-body))) 488 new-etat)))) 489 ((return-from :block-name $$ :value _) 490 (let ((association (assoc `(,block-name . block-name) (etat-local etat) :test #'equal))) 491 (if association 492 (funcall (cdr association) value) 493 (mini-meval-error expr etat "tentative de faire un return-from pour un bloc qui n'existe pas ou plus : ~w." block-name)))) 494 ((block :block-name $$ :body _*) 495 (block block-catcher 496 (mini-meval `(progn ,@body) 497 (push-local etat block-name 'block-name (lambda (x) (return-from block-catcher x)))))) 498 ((quote :val _) 499 val) 500 ((function :name $$) 501 (let ((definition (assoc-etat name 'function etat))) 502 (if definition 503 (cdr definition) 504 (mini-meval-error expr etat "Undefined function : ~w." name)))) 505 ((function :fun (lambda _ . _)) 506 (mini-meval fun etat)) 507 ((funcall :name _ :params _*) 508 (apply (mini-meval name etat) 509 (mapcar (lambda (x) (mini-meval x etat)) params))) 510 ((apply :name _ :p1 _ :params _*) 511 (let ((fun (mini-meval name etat)) 512 (args (mapcar (lambda (x) (mini-meval x etat)) (cons p1 params)))) 513 (apply fun (append (butlast args) (car (last args)))))) 514 #| Traitement des appels de fonction |# 515 ((:lambda (lambda @ _*) :params _*) 516 #| - Si c'est une fonction anonyme, on l'exécute. |# 517 (apply (mini-meval lambda etat) (mapcar (lambda (x) (mini-meval x etat)) params))) 518 (((function :fun (lambda _ . _)) :params . _) 519 (mini-meval `(,fun ,@params) etat)) 520 ((:name (function $$) :params _*) 521 (apply (mini-meval name etat) params)) 522 ((:name $$ :params _*) 523 (let ((definition (assoc-etat name 'function etat))) 524 (if definition 525 #| - Si on a une fonction de ce nom dans l'état-local ou dans l'etat-global, on l'exécute. |# 526 (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat)) params)) 527 (mini-meval-error expr etat "Undefined function : ~w." name)))) 528 ((? or numberp stringp characterp) 529 expr) 530 ;; TODO : nil et t devraient être des defconst 531 (nil 532 nil) 533 ($$ 534 (let ((definition (assoc-etat expr 'variable etat))) 535 (if definition 536 (cdr definition) 537 (mini-meval-error expr etat "Undefined variable : ~w." expr)))) 538 (_ 539 (print expr) 540 (error "mini-meval : this is unsupported : ~w ." expr)))) 541 ;) 542 543 (defun push-functions (etat functions) 544 (dolist (f functions) 545 (push-global! etat f 'function (fdefinition f))) 546 etat) 547 548 (defmacro make-etat (&rest functions) 549 `(push-functions (list nil nil nil) ',functions)) 550 551 (defun etat-exemple () 552 (make-etat list + - cons car cdr < > <= >= =)) 553 554 (require 'test-unitaire "test-unitaire") 555 (erase-tests mini-meval) 556 557 (deftestvar mini-meval etat (make-etat list + - cons car cdr < > <= >= =)) 558 559 ;; La plupart des tests sont dans eqiv-tests.lisp 560 561 (deftest (mini-meval lambda extérieur) 562 (funcall (mini-meval '(lambda (x) x) etat) 3) 563 3) 564 565 (deftest (mini-meval lambda extérieur) 566 (funcall (mini-meval '(lambda (x) (+ x 3)) etat) 4) 567 7) 568 569 (deftest (mini-meval defvar) 570 (mini-meval '(progn (defvar *test-var-x* 42) *test-var-x*) etat) 571 42) 572 573 ;; Syntaxe supplémentaire non reconnue par le standard : (#'fun param*) 574 (deftest (mini-meval call-function extérieur) 575 (mini-meval '(#'+ 2 3) etat) 576 5) 577 578 ;; Syntaxe supplémentaire non reconnue par le standard : (#'(lambda ...) param*) 579 (deftest (mini-meval call-function lambda) 580 (mini-meval '(#'(lambda (x) (+ x 40)) 2) etat) 581 42) 582 583 (deftest (mini-meval defvar special) 584 (mini-meval '(progn 585 (defun foo1 () *test-var-y*) 586 (defun foo2 () (let ((*test-var-y* 4)) (list *test-var-y* (foo1)))) 587 (defvar *test-var-y* 123) 588 (list (foo1) (foo2))) 589 etat) 590 '(123 (4 4))) 591 592 (deftest (mini-meval defun) 593 (mini-meval '(progn (defun double (x) (+ x x)) (double 3)) etat) 594 6) 595 596 (deftest (mini-meval defmacro) 597 (mini-meval '(progn (defmacro qlist (x y) (list 'list (list 'quote x) (list 'quote y))) (qlist a b)) etat) 598 '(a b)) 599 600 (deftest (mini-meval macrolet) 601 (mini-meval '(progn 602 (defun qlist (a b) (list a b)) 603 (list 604 (qlist 'a 'b) 605 (macrolet ((qlist (x y) (list 'list (list 'quote x) (list 'quote y)))) 606 (qlist 'a 'b)) 607 (qlist 'a 'b))) 608 etat) 609 '((a b) ('a 'b) (a b))) 610 611 (deftest (mini-meval setf setq) 612 (mini-meval '(list (defvar *test-var-z* 42) *test-var-z* (setq *test-var-z* 123) *test-var-z*) etat) 613 '(*test-var-z* 42 123 123)) 614 615 ;; TODO : tests setf 616 617 (deftest (mini-meval function internal) 618 (funcall (mini-meval '(progn (defun foo (x) (+ x 40)) #'foo) etat) 2) 619 '42) 620 621 (deftest (mini-meval function internal) 622 (mini-meval '(progn (defun foo (x) (+ x 40)) (funcall #'foo 2)) etat) 623 '42) 624 625 (deftest (mini-meval function internal) 626 (mini-meval '(progn (defvar *test-var-bar* (list (lambda (x) (+ x 40)) 1 2 3)) (funcall (car *test-var-bar*) 2)) etat) 627 '42) 628 629 (deftest (mini-meval call-function internal) 630 (mini-meval '(progn (defun foo (x) (+ x 40)) (#'foo 2)) etat) 631 42) 632 633 (deftest (mini-meval lambda closure single-instance) 634 (mini-meval '(progn 635 (defvar *test-var-foo* (let ((y 1)) (cons (lambda (x) (list x y)) (lambda (z) (setq y (+ y z)) nil)))) 636 (list (funcall (car *test-var-foo*) 4) (funcall (cdr *test-var-foo*) 5) (funcall (car *test-var-foo*) 4))) etat) 637 '((4 1) nil (4 6))) 638 639 (deftest (mini-meval lambda closure multiple-instances) 640 (mini-meval '(progn 641 (defun counter (&optional (ctr 0)) (cons (lambda () ctr) (lambda (&optional (x 1)) (setq ctr (+ ctr x)) nil))) 642 (defvar *test-var-foo0* (counter)) 643 (defvar *test-var-foo42* (counter 42)) 644 (list 645 (funcall (car *test-var-foo0*)) ;; show 0 646 (funcall (car *test-var-foo42*)) ;; show 42 647 (funcall (cdr *test-var-foo0*)) ;; add 0 648 (funcall (car *test-var-foo0*)) ;; show 0 649 (funcall (cdr *test-var-foo42*)) ;; add 42 650 (funcall (car *test-var-foo42*)) ;; show 42 651 (funcall (car *test-var-foo0*)) ;; shwo 0 652 (funcall (car *test-var-foo42*)) ;; show 42 653 (funcall (cdr *test-var-foo42*) 6) ;; add 42 (+ 6) 654 (funcall (cdr *test-var-foo0*) 5) ;; add 0 (+ 5) 655 (funcall (car *test-var-foo42*)) ;; show 42 656 (funcall (car *test-var-foo0*)))) ;; show 0 657 etat) 658 '(0 42 nil 1 nil 43 1 43 nil nil 49 6)) 659 660 (deftest (mini-meval labels) 661 (mini-meval '(list 662 (defun foo (x) (+ x 1)) 663 (foo 3) 664 (labels ((foo (x) (+ x 3))) 665 (foo 3))) 666 etat) 667 '(foo 4 6)) 668 669 (deftest (mini-meval flet) 670 (mini-meval '(list 671 (defun foo (x) (+ x 1)) 672 (foo 3) 673 (flet ((foo (x) (+ x 3))) 674 (foo 3))) 675 etat) 676 '(foo 4 6)) 677 678 (deftest (mini-meval labels) 679 (mini-meval '(list 680 (defun fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ... 681 (fibo 5) 682 (labels ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ... 683 (fibo 5))) 684 etat) 685 '(fibo 8 5)) 686 687 (deftest (mini-meval flet) 688 (mini-meval '(list 689 (defun fibo (n) (if (< n 2) 1 (+ (fibo (- n 1)) (fibo (- n 2))))) ;; fibo 0 -> 1; 1 -> 1; 2 -> 2 ... 690 (fibo 5) 691 (flet ((fibo (n) (if (< n 3) 1 (+ (fibo (- n 1)) (fibo (- n 2)))))) ;; fibo 1 -> 1; 2 -> 1; 3 -> 2 ... 692 (fibo 5))) 693 etat) 694 ;; Le flet ne permet pas les définitions récursives, donc le fibo 695 ;; de l'extérieur est appellé après le 1er niveau de récursion. 696 '(fibo 8 8)) 697 698 (deftest-error (mini-meval error) 699 (mini-meval '(error "Some user error message."))) 700 701 (provide 'mini-meval)