tmm.lisp (48288B)
1 (progn 2 (defvar t 't) 3 (defmacro when (condition &rest body) 4 `(if ,condition 5 (progn ,@body) 6 nil)) 7 (defmacro unless (condition &rest body) 8 `(if ,condition 9 nil 10 (progn ,@body))) 11 (defmacro cond (&rest exprs) 12 (if (endp exprs) 13 nil 14 `(if ,(caar exprs) 15 ,(cadar exprs) 16 (cond ,@(cdr exprs))))) 17 (defmacro and (&rest exprs) 18 (if (endp exprs) 19 t 20 `(if ,(car exprs) 21 (and ,@(cdr exprs)) 22 nil))) 23 (defmacro or (&rest exprs) 24 (if (endp exprs) 25 nil 26 `(if ,(car exprs) 27 t 28 (or ,@(cdr exprs))))) 29 (defun n-consp (n l) 30 "Détermine s'il y a au moins n cellules dans la liste l." 31 (if (<= n 0) 32 t 33 (and (consp l) 34 (n-consp (- n 1) (cdr l))))) 35 36 (defun reverse-alist (alist) 37 (mapcar (lambda (x) (cons (car x) (reverse (cdr x)))) 38 alist)) 39 40 (defun group-1 (lst &optional result) 41 "Groupe les éléments d'une lste en fonction de leur premier élément, et renvoie une lste associative" 42 (if (endp lst) 43 result 44 (let ((association (assoc (caar lst) result))) 45 (if association 46 (push (cdar lst) (cdr association)) 47 (push (cons (caar lst) (list (cdar lst))) result)) 48 (group-1 (cdr lst) result)))) 49 50 (defun group (lst) 51 (reverse-alist (group-1 lst))) 52 53 (defmacro dolist* (spec &rest body) 54 (let* ((vars (mapcar #'car spec)) 55 (listforms (mapcar #'cadr spec)) 56 (loopsym (make-symbol "loop")) 57 (endsym (make-symbol "end")) 58 (listsyms (mapcar (lambda (x) (cons x (make-symbol "list"))) vars))) 59 `(let (,@(mapcar (lambda (var) `(,var nil)) vars) 60 ,@(mapcar (lambda (ls val) `(,(cdr ls) ,val)) listsyms listforms)) 61 (tagbody 62 ,loopsym 63 ,@(mapcar (lambda (ls) 64 `(setq ,(car ls) (car ,(cdr ls)))) 65 listsyms) 66 ,@(mapcar (lambda (ls) 67 `(when (endp ,(cdr ls)) 68 (go ,endsym))) 69 listsyms) 70 (progn ,@body) 71 ,@(mapcar (lambda (ls) 72 `(setq ,(cdr ls) (cdr ,(cdr ls)))) 73 listsyms) 74 (go ,loopsym) 75 ,endsym)))) 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 (declaim (ftype function assembly-place-p)) ;; définie dans compilation.lisp 103 (declaim (ftype function immutable-assembly-place-p)) ;; définie dans compilation.lisp 104 (declaim (ftype function mutable-assembly-place-p)) ;; définie dans compilation.lisp 105 106 (defun pattern-match-do-lambdas-transform (pattern) 107 (mapcar (lambda (pred) 108 (cond ((atom pred) (list 'function pred)) 109 ((eq (car pred) 'function) pred) 110 ((eq (car pred) 'lambda) pred) 111 (t 112 `(lambda (x) x ,pred)))) 113 pattern)) 114 115 (defun pattern-match-do-lambdas-1 (pattern) 116 (if (atom pattern) 117 `',pattern 118 `(list ',(first pattern) 119 ',(second pattern) 120 ,(if (second pattern) 121 (let ((?-clause (cdr (third pattern))) 122 (type '_)) 123 (when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ $$ $k $n $ap $iap $map $& @ @.))) 124 (setq type (car ?-clause)) 125 (setq ?-clause (cdr ?-clause))) 126 ;; TODO : (? or foo (? _ and bar baz) (? $ and quux)) 127 (cond ((atom ?-clause) `(list ',type 'and #'identity)) 128 ((eq 'and (first ?-clause)) `(list ',type 'and ,@(pattern-match-do-lambdas-transform (cdr ?-clause)))) 129 ((eq 'or (first ?-clause)) `(list ',type 'or ,@(pattern-match-do-lambdas-transform (cdr ?-clause)))) 130 (t `(list ',type 'and ,@(pattern-match-do-lambdas-transform ?-clause))))) 131 (pattern-match-do-lambdas-1 (third pattern))) 132 ',(fourth pattern) 133 ,(pattern-match-do-lambdas-1 (fifth pattern))))) 134 135 (defmacro pattern-match-do-lambdas (pattern) 136 "Transforme les (? (<code>)) et (? (lambda ...)) en vrais lambdas." 137 (pattern-match-do-lambdas-1 pattern)) 138 139 (defun transform-symbol-to-multi (pat) 140 (let ((str-sym (string pat))) 141 (if (< (length str-sym) 2) 142 pat 143 (let* ((sym (map 'list #'identity str-sym)) 144 (lsym (car (last sym)))) 145 (if (or (char= lsym #\*) 146 (char= lsym #\+) 147 (char= lsym #\?)) 148 (list (intern (format nil "~{~a~}" (butlast sym))) 149 (intern (string lsym))) 150 pat))))) 151 152 (defun pattern-match-preprocess-multi (pattern) 153 "Transforme les symbol*, symbol+ et symbol? 154 en symbol *, symbol + et symbol ?" 155 (cond ((and (consp pattern) (eq '? (first pattern))) 156 pattern) ;; On ne touche pas les (? ...) 157 ((consp pattern) 158 (labels ((transform-symbol-to-multi (pat) 159 (let ((str-sym (string pat))) 160 (if (< (length str-sym) 2) 161 pat 162 (let* ((sym (map 'list #'identity str-sym)) 163 (lsym (car (last sym)))) 164 (if (or (char= lsym #\*) 165 (char= lsym #\+) 166 (char= lsym #\?)) 167 (list (intern (format nil "~{~a~}" (butlast sym))) 168 (intern (string lsym))) 169 pat))))) 170 (recurse (pat) 171 (cond 172 ((null pat) nil) 173 ((symbolp pat) (transform-symbol-to-multi pat)) 174 ((atom pat) pat) 175 ((keywordp (car pat)) ;; TODO : non testé !!! 176 `(,(car pat) 177 ,@(recurse (cdr pat)))) 178 ((symbolp (car pat)) 179 (let ((transf (transform-symbol-to-multi (car pat)))) 180 (if (consp transf) 181 `(,@transf ,@(recurse (cdr pat))) 182 `(,transf ,@(recurse (cdr pat)))))) 183 (t (cons (pattern-match-preprocess-multi (car pat)) 184 (recurse (cdr pat))))))) 185 (recurse pattern))) 186 ((symbolp pattern) 187 (transform-symbol-to-multi pattern)) 188 (t 189 pattern))) 190 191 (defun keyword-to-symbol (keyword) 192 (intern (format nil "~a" keyword))) 193 194 (defun pattern-match-preprocess-capture (pattern &optional capture-name) 195 "Transforme pattern en un arbre (capture-name is-predicate pattern multi rest)." 196 (if (and (consp pattern) (keywordp (car pattern))) 197 ;; capture-name 198 (if (and (n-consp 2 (cdr pattern)) (member (caddr pattern) '(* + ?))) 199 ;; avec capture-name, avec multi 200 (list (keyword-to-symbol capture-name) 201 nil 202 (pattern-match-preprocess-capture (second pattern) (first pattern)) 203 (third pattern) 204 (pattern-match-preprocess-capture (cdddr pattern))) 205 ;; avec capture-name, sans multi 206 (cond 207 ;; (:x . a) 208 ((atom (cdr pattern)) 209 (list (keyword-to-symbol (car pattern)) 210 nil 211 (cdr pattern) 212 nil 213 nil)) 214 ;; (:x . (? ...)) 215 ((and (consp pattern) (eq '? (cadr pattern))) 216 (list (keyword-to-symbol (car pattern)) 217 t 218 (cdr pattern) 219 nil 220 nil)) ;; TODO 221 ;; (:x cadr-pattern . cddr-pattern) 222 (t 223 (list (keyword-to-symbol capture-name) 224 nil 225 (pattern-match-preprocess-capture (cadr pattern) (car pattern)) 226 nil 227 (pattern-match-preprocess-capture (cddr pattern)))))) 228 ;; pas de capture-name 229 (if (and (n-consp 2 pattern) (member (cadr pattern) '(* + ?))) 230 ;; sans capture-name, avec multi 231 (list (keyword-to-symbol capture-name) 232 nil 233 (pattern-match-preprocess-capture (first pattern)) 234 (second pattern) 235 (pattern-match-preprocess-capture (cddr pattern))) 236 ;; sans capture-name, sans multi 237 (cond 238 ;; a 239 ((atom pattern) 240 (list (keyword-to-symbol capture-name) 241 nil 242 pattern 243 nil 244 nil)) 245 ;; (? ...) 246 ((and (consp pattern) (eq '? (car pattern))) 247 (list (keyword-to-symbol capture-name) 248 t 249 pattern 250 nil 251 nil)) 252 ;; (car-pattern . cdr-pattern) 253 (t 254 (list (keyword-to-symbol capture-name) 255 nil 256 (pattern-match-preprocess-capture (car pattern)) 257 nil 258 (pattern-match-preprocess-capture (cdr pattern)))))))) 259 260 (defun append-captures-1 (captures-1 captures-2) 261 (if (endp captures-1) 262 nil 263 (if (caar captures-1) ;; ignorer les captures nommées nil 264 (cons (cons (caar captures-1) ;; nom de capture 265 (cons (cdar captures-1) ;; nouvelle capture 266 (cdr (assoc (caar captures-1) captures-2)))) 267 (append-captures-1 (cdr captures-1) captures-2)) 268 (append-captures-1 (cdr captures-1) captures-2)))) 269 270 (defun append-captures (captures-1 captures-2) 271 "captures-1 et 2 sont des alist nom-capture . arbre-capture 272 Renvoie une alist nom-capture . (append arbre-c1 arbre-c2)" 273 (cons (append-captures-1 captures-1 (car captures-2)) 274 (cdr captures-2))) 275 276 (defun make-empty-matches-1 (pattern result) 277 (if (atom pattern) 278 result 279 (let ((here (if (first pattern) ;; pas les captures nommées nil 280 (acons (first pattern) nil result) 281 result))) 282 (if (second pattern) ;; ne pas descendre dans les les (? ...) 283 here 284 (make-empty-matches-1 (fifth pattern) 285 (make-empty-matches-1 (third pattern) here)))))) 286 287 (defun make-empty-matches (pattern) 288 (reverse (make-empty-matches-1 pattern '()))) 289 290 (defun acons-capture (capture-name value captures) 291 (if (or capture-name (not captures)) 292 (acons capture-name value captures) 293 captures)) 294 295 (defun append-car-cdr-not-nil (c) 296 (if (or (car c) (cdr c)) 297 (append (car c) (cdr c)) 298 (acons nil nil nil))) 299 300 (defun append-not-nil-1 (a b) 301 (if (endp a) 302 b 303 (if (caar a) 304 (cons (car a) (append-not-nil-1 (cdr a) b)) 305 (append-not-nil-1 (cdr a) b)))) 306 307 (defun append-not-nil (a b) 308 (or (append-not-nil-1 a b) 309 (acons nil nil nil))) 310 311 (declaim (ftype function pattern-match)) ;; récursion mutuelle recursive-backtrack / pattern-match 312 (defun recursive-backtrack (pattern rest expr capture-name) 313 (or 314 ;; match greedy (on avance dans le *) 315 (and (consp expr) 316 (let ((greedy-left (pattern-match pattern (car expr)))) 317 (when greedy-left 318 (let ((greedy-right (recursive-backtrack pattern rest (cdr expr) capture-name))) 319 (when greedy-right 320 (append-captures (acons-capture capture-name (car expr) greedy-left) 321 greedy-right)))))) 322 ;; match non-greedy (on match avec le rest) 323 (let ((non-greedy (pattern-match rest expr))) 324 (when non-greedy 325 (cons (acons-capture capture-name expr (make-empty-matches pattern)) 326 non-greedy))))) 327 328 (defun pattern-match (pat expr) 329 (let ((capture-name (first pat)) 330 (is-predicate (second pat)) 331 (pattern (third pat)) 332 (multi (fourth pat)) 333 (rest (fifth pat))) 334 (if multi 335 (if (not (listp expr)) 336 nil 337 (cond 338 ;; (pattern * ...) 339 ((eq multi '*) 340 (let ((match (recursive-backtrack pattern rest expr capture-name))) 341 (when match 342 (append-car-cdr-not-nil match)))) 343 ;; (pattern + ...) 344 ((eq multi '+) 345 (let ((first-match (and (consp expr) (pattern-match pattern (car expr))))) 346 (when first-match 347 (let ((match (recursive-backtrack pattern rest (cdr expr) capture-name))) 348 (when match 349 (let ((result (append-captures first-match match))) 350 (append-car-cdr-not-nil result))))))) 351 ;; (pattern ? ...) 352 ((eq multi '?) 353 (let ((match (and (consp expr) (pattern-match pattern (car expr))))) 354 (or (when match 355 (let ((match-rest (pattern-match rest (cdr expr)))) 356 (when match-rest 357 ;; Attention, les trois lignes suivantes ont été modifiées sans que je comprenne vraiement les manipulations... 358 (append-car-cdr-not-nil 359 (append-captures match (cons (acons-capture capture-name expr (make-empty-matches pattern)) 360 match-rest)))))) 361 (let ((match-only-rest (pattern-match rest expr))) 362 (when match-only-rest 363 (append (acons-capture capture-name expr (make-empty-matches pattern)) 364 match-only-rest)))))))) 365 (if rest 366 ;; (pattern . rest) 367 (and (consp expr) 368 (let ((left (pattern-match pattern (car expr)))) 369 (when left 370 (let ((right (pattern-match rest (cdr expr)))) 371 (when right 372 (acons-capture capture-name expr (append-not-nil left right))))))) 373 ;; pattern est un atom 374 (cond 375 ;; (? <prédicat(s)>) 376 (is-predicate 377 (when (and (pattern-match `(nil nil ,(car pattern) nil nil) expr) 378 (cond 379 ;; (? _ and symbole-1 ... symbole-n) 380 ((eq 'and (second pattern)) 381 (every (lambda (predicat) (funcall predicat expr)) (cddr pattern))) 382 ;; (? _ or symbole-1 ... symbole-n) 383 ((eq 'or (second pattern)) 384 (some (lambda (predicat) (funcall predicat expr)) (cddr pattern))))) 385 (acons-capture capture-name expr nil))) 386 ;; () 387 ((null pattern) 388 (when (null expr) 389 (acons-capture capture-name expr nil))) 390 ;; $ 391 ((eq '$ pattern) 392 (when (and (atom expr) 393 (not (null expr))) 394 (acons-capture capture-name expr nil))) 395 ;; $$ 396 ((eq '$$ pattern) 397 (when (symbolp expr) 398 (acons-capture capture-name expr nil))) 399 ;; $k 400 ((eq '$k pattern) 401 (when (keywordp expr) 402 (acons-capture capture-name expr nil))) 403 ;; $ap 404 ((eq '$ap pattern) 405 (when (assembly-place-p expr) 406 (acons-capture capture-name expr nil))) 407 ;; $iap 408 ((eq '$iap pattern) 409 (when (immutable-assembly-place-p expr) 410 (acons-capture capture-name expr nil))) 411 ;; $ap 412 ((eq '$map pattern) 413 (when (mutable-assembly-place-p expr) 414 (acons-capture capture-name expr nil))) 415 ;; $n 416 ((eq '$n pattern) 417 (when (numberp expr) 418 (acons-capture capture-name expr nil))) 419 ;; $& 420 ((eq '$& pattern) 421 (when (and (symbolp expr) (member expr '(&optional &rest &key &allow-other-keys &aux))) 422 (acons-capture capture-name expr nil))) 423 ;; @ 424 ((eq '@ pattern) 425 (when (propper-list-p expr) 426 (acons-capture capture-name expr nil))) 427 ;; @. 428 ((eq '@. pattern) 429 (when (consp expr) 430 (acons-capture capture-name expr nil))) 431 ;; _ 432 ((eq '_ pattern) 433 (acons-capture capture-name expr nil)) 434 ;; Autres valeurs (symbole, nombre, etc.) 435 (t 436 (when (equal pattern expr) 437 (acons-capture capture-name expr nil)))))))) 438 439 (defmacro pattern-match-preprocess (pattern) 440 "Tous les preprocess de pattern-match en un seul appel." 441 `(pattern-match-do-lambdas 442 ,(pattern-match-preprocess-capture 443 (pattern-match-preprocess-multi 444 pattern)))) 445 446 (defmacro real-match (pattern expr body &optional else-clause) 447 (let* ((result-sym (make-symbol "RESULT")) 448 (result-of-if-sym (make-symbol "RESULT-OF-IF")) 449 (pattern-sym (make-symbol "PATTERN")) 450 (else-sym (make-symbol "ELSE")) 451 (pattern-preproc (pattern-match-preprocess-capture 452 (pattern-match-preprocess-multi 453 pattern))) 454 (capture-names (mapcar #'car (make-empty-matches pattern-preproc)))) 455 `(let* ((,pattern-sym (pattern-match-do-lambdas ,pattern-preproc)) 456 (,result-sym (pattern-match ,pattern-sym ,expr)) 457 (,result-of-if-sym 458 (if ,result-sym 459 ;; Si le match a été effectué avec succès 460 ,@(if body 461 ;; Si on a un body 462 ;; On bind les variables correspondant aux noms de capture 463 `((let ,(mapcar (lambda (x) `(,x (cdr (assoc ',x ,result-sym)))) 464 capture-names) 465 ;; "utilisation" des variables pour éviter les warning unused variable. 466 ,@capture-names 467 ;; On définit la fonction "else" qui produit le "code secret" permettant d'exécuter le else. 468 (labels ((else () ',else-sym)) 469 ;; On exécute le body 470 ,@body))) 471 ;; S'il n'y a pas de body, on renvoie l'alist des captures s'il y en a ou T sinon. 472 (if capture-names 473 `((remove nil ,result-sym :key #'car)) 474 `(t))) 475 ;; Si on ne match pas, on renvoie le "code secret" permettant d'exécuter le else. 476 ',else-sym))) 477 ;; Si le résultat est le "code secret" du else, on fait le else, sinon on renvoie le résultat 478 (if (eq ,result-of-if-sym ',else-sym) 479 ,else-clause 480 ,result-of-if-sym)))) 481 482 (defmacro match (pattern expr &rest body) 483 (if (keywordp pattern) 484 `(real-match (,pattern . ,expr) ,(car body) ,(cdr body)) 485 `(real-match ,pattern ,expr ,body))) 486 487 (defmacro cond-match-1 (expr cond-clauses) 488 (if (endp cond-clauses) 489 'nil 490 (if (keywordp (caar cond-clauses)) 491 `(real-match (,(caar cond-clauses) . ,(cadar cond-clauses)) 492 ,expr 493 ,(cddar cond-clauses) 494 (cond-match-1 ,expr ,(cdr cond-clauses))) 495 `(real-match ,(caar cond-clauses) 496 ,expr 497 ,(cdar cond-clauses) 498 (cond-match-1 ,expr ,(cdr cond-clauses)))))) 499 500 (defmacro cond-match (expr &rest cond-clauses) 501 (let ((expr-sym (make-symbol "expr"))) 502 `(let ((,expr-sym ,expr)) 503 (cond-match-1 ,expr-sym ,cond-clauses)))) 504 505 (defun match--transitions-to-progns (transitions) 506 ;; On remet to, pattern et code bout à bout (c'est tout du code) 507 (mapcar (lambda (x) `(progn ,(car x) ,@(cadr x) ,@(caddr x))) 508 transitions)) 509 510 (defmacro match-automaton (expr initial-state &rest rules) 511 (match ((:from $$ :to _ :pattern _? :code _*) *) rules 512 (let ((storage (mapcar (lambda (s) (cons s (make-symbol (format nil "STORAGE-~a" (string s))))) (remove-duplicates from))) 513 (expr-sym (make-symbol "EXPR")) 514 (block-sym (make-symbol "BLOCK")) 515 (grouped-transitions (group (mapcar #'list from to pattern code))) 516 (last-state-sym (make-symbol "LAST-STATE")) 517 (last-element-sym (make-symbol "LAST-ELEMENT"))) 518 `(let (,@(mapcar (lambda (s) `(,(cdr s) nil)) storage) 519 (,expr-sym ,expr) 520 (,last-state-sym 'initial) 521 (,last-element-sym nil)) 522 (block ,block-sym 523 (tagbody 524 initial 525 (progn ,(match--transitions-to-progns (cdr (assoc 'initial grouped-transitions)))) 526 (go ,initial-state) 527 accept 528 (let ((return-value (list ,@(mapcar (lambda (s) `(cons ',(car s) (reverse ,(cdr s)))) storage)))) 529 return-value 530 (return-from ,block-sym 531 (progn return-value 532 ,@(match--transitions-to-progns (cdr (assoc 'accept grouped-transitions)))))) 533 reject 534 (return-from ,block-sym 535 (let ((last-element ,last-element-sym) 536 (last-state ,last-state-sym)) 537 last-element 538 last-state 539 (progn nil 540 ,@(match--transitions-to-progns (cdr (assoc 'reject grouped-transitions)))))) 541 ,@(loop 542 for (from . transitions) in grouped-transitions 543 and temp-do = nil 544 and temp-collect = nil 545 ;; syntaxe (stateX code) => exécute le code à chaque fois qu'on rentre dans stateX. 546 for jump = (member nil (reverse transitions) :key #'second) 547 unless (member from '(initial accept reject)) 548 collect from 549 and collect `(setq ,last-state-sym ',from) 550 and collect `(setq ,last-element-sym (car ,expr-sym)) 551 and if jump 552 ;; va à l'état désigné par la dernière transition "finale". 553 collect `(when (endp ,expr-sym) (go ,(caar jump))) 554 else 555 collect `(when (endp ,expr-sym) (go reject)) 556 end 557 and do (setq temp-do (remove nil (mapcar (lambda (x) (when (eq 'do (car x)) `(progn ,@(cadr x) ,@(caddr x)))) transitions))) 558 and do (setq temp-collect (remove nil (mapcar (lambda (x) (when (eq 'collect (car x)) `(progn ,@(cadr x) ,@(caddr x)))) transitions))) 559 and when (or temp-do temp-collect) 560 collect `(let ((last-element ,last-element-sym) 561 (last-state ,last-state-sym)) 562 last-element 563 last-state 564 ,@(if temp-do `((progn ,@temp-do)) nil) 565 ,@(if temp-collect `((push (progn ,@temp-collect) ,(cdr (assoc from storage)))) nil)) 566 end 567 and collect `(cond-match (car ,expr-sym) 568 ,@(loop 569 for (to pattern code) in transitions 570 unless (or (not pattern) (eq to 'do) (eq to 'collect)) 571 if code 572 collect `(,@pattern 573 (push (progn ,@code) ,(cdr (assoc from storage))) 574 (setq ,expr-sym (cdr ,expr-sym)) 575 (go ,to)) 576 else 577 collect `(,@pattern 578 (setq ,expr-sym (cdr ,expr-sym)) 579 (go ,to))) 580 (_ ,(if jump `(go ,(caar jump)) '(go reject))))))))))) 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 (defmacro etat-local (etat) 633 `(car ,etat)) 634 635 (defmacro etat-global (etat) 636 `(cadr ,etat)) 637 638 (defmacro etat-special (etat) 639 ;; Variables spéciales et constantes. (ou devrait-on mettre les constantes dans etat-global ?) 640 ;; 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). 641 `(caddr ,etat)) 642 643 (defun assoc-etat (var type etat) 644 (let ((search (cons var type))) 645 (or (assoc search (etat-special etat) :test #'equal) 646 (assoc search (etat-local etat) :test #'equal) 647 (assoc search (etat-global etat) :test #'equal)))) 648 649 (defun assoc-special (var type etat) 650 (assoc (cons var type) (etat-special etat) :test #'equal)) 651 652 (defun replace-local (etat new-etat-local) 653 (cons new-etat-local (cdr etat))) 654 655 (defun push-local (etat var type value) 656 (when (and (eq type 'variable) (assoc-etat var 'constant etat)) 657 (error "mini-meval : Can't bind ~w : it is a constant." var)) 658 (replace-local etat (acons (cons var type) value (etat-local etat)))) 659 660 (defun push-local-or-special (etat var type value immediate) 661 (let ((association (assoc-special var type etat)) 662 (new-etat nil)) 663 (if association 664 (progn 665 (setq new-etat (push-local etat var 'special-bakcup (cons association (cdr association)))) 666 (if immediate 667 (progn (setf (cdr association) value) 668 new-etat) 669 (push-local new-etat var 'special-future-phantom (cons association value)))) 670 (push-local etat var 'variable value)))) 671 672 (defun affect-future-specials (new-etat etat) 673 (setq new-etat (etat-local new-etat)) 674 (setq etat (etat-local etat)) 675 (tagbody 676 loop 677 (when (eq new-etat etat) (go fin)) 678 (when (eq (cdaar new-etat) 'special-future-phantom) 679 (setf (cdr (cadar new-etat)) (cddar new-etat))) 680 (setq new-etat (cdr new-etat)) 681 (go loop) 682 fin)) 683 684 (defun pop-special-backups (new-etat etat) 685 (setq new-etat (etat-local new-etat)) 686 (setq etat (etat-local etat)) 687 (tagbody 688 loop 689 (when (eq new-etat etat) (go fin)) 690 (when (eq (cdaar new-etat) 'special-bakcup) 691 (setf (cdr (cadar new-etat)) (cddar new-etat))) 692 (setq new-etat (cdr new-etat)) 693 (go loop) 694 fin)) 695 696 (defun push-global! (etat name type value) 697 (setf (etat-global etat) (acons (cons name type) value (etat-global etat))) 698 etat) 699 700 (defun push-special! (etat name type value) 701 (setf (etat-special etat) (acons (cons name type) value (etat-special etat))) 702 etat) 703 704 (defun reduce-on-local-1 (new-etat-local callback lists) 705 (let ((res nil)) 706 (tagbody 707 loop 708 (when (member nil lists) (go fin)) 709 (setq res (apply callback new-etat-local (mapcar #'car lists))) 710 (setq new-etat-local (acons (cons (car res) (cadr res)) 711 (caddr res) 712 new-etat-local)) 713 (setq lists (mapcar #'cdr lists)) 714 (go loop) 715 fin) 716 new-etat-local)) 717 718 (defun reduce-on-local (etat callback &rest lists) 719 (if (null lists) 720 etat 721 (replace-local etat (reduce-on-local-1 (etat-local etat) callback lists)))) 722 723 ;; DONE 724 ;; - loop 725 ;; - dolist / dotimes 726 ;; - match-automaton(tagbody+block) 727 728 ;; HALF-DONE (TODO) 729 ;; - read 730 ;; - warn 731 ;; - ` (quasiquote) 732 733 ;; TODO (dans mini-meval et/ou compilateur) : 734 ;; - syntaxe courte du let 735 ;; - declaim 736 ;; - format 737 ;; - setf (écrire la macro) 738 ;; - fdefinition, funcctionp, … 739 ;; - symbolp, keywordp, keywords non mutables + nil et t, intern, make-symbol 740 ;; - car / cdr, replaca replacad, cons, list (fonction), listp, consp, atom, null (ou eq nil), … 741 ;; - and / or (macros => if) 742 ;; - &rest 743 ;; - eq (vérifier qu'on préserve bien l'égalité de pointeurs là où il faut) / = / eql / equal / equalp 744 ;; - load / open / close 745 ;; - defvar [done mini-meval] (gestion correcte des variables spéciales) 746 ;; - array support (array-total-size, row-major-aref, copy-seq) 747 ;; - string support (char=, map, string (symbol => string), format, print) 748 ;; - coder un reverse rapide. 749 ;; - transformation de la récursion terminale. 750 751 ;; - vérifier qu'on a pas transformé certaines fonctions en formes spéciales (il faut qu'on puisse toujours les récupérer avec #'). 752 ;; - sortir le defun du mini-meval ? 753 754 ;; cell (un seul pointeur, transparent (y compris pour le type), 755 ;; avec trois fonctions spéciales pour le get / set / tester le type), 756 ;; sera utilisé pour les closures et les variables spéciales. 757 758 ;; TODO : bug : pourquoi les keyword-to-symbol ??? on devrait garder le keyword tel quel. 759 (defun slice-up-lambda-list (lambda-list) 760 (match-automaton lambda-list fixed 761 (fixed accept) 762 (fixed optional &optional) 763 (fixed rest &rest) 764 (fixed key &key) 765 (fixed aux &aux) 766 (fixed reject $&) 767 (fixed fixed (:var . $$) var) 768 (optional accept) 769 (optional rest &rest) 770 (optional key &key) 771 (optional aux &aux) 772 (optional reject $&) 773 (optional optional (:var . $$) `(,var nil nil)) 774 (optional optional (:var $$ :default _? :svar $$?) `(,var ,(car default) ,(car svar))) 775 (rest reject $&) 776 (rest rest2 (:var . $$) var) 777 (rest2 accept) 778 (rest2 key &key) 779 (rest2 aux &aux) 780 (rest2 reject $&) 781 (key accept) 782 (key other &allow-other-keys) 783 (key aux &aux) 784 (key reject $&) 785 (key key (:keyword . $k) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) nil nil)) ;; Not in the standard ! 786 (key key (:var . $$) `(,var ,var nil nil)) 787 (key key (:keyword $$ :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,(keyword-to-symbol keyword) ,(car default) ,(car svar))) ;; Not in the standard ! 788 (key key (:var $$ :default _? :svar $$?) `(,var ,var ,(car default) ,(car svar))) 789 (key key ((:keyword $k :var $$) :default _? :svar $$?) `(,(keyword-to-symbol keyword) ,var ,(car default) ,(car svar))) 790 (other collect t) 791 (other accept) 792 (other aux &aux) 793 (other reject $&) 794 (aux accept) 795 (aux reject $&) 796 (aux aux (:var . $$) `(,var nil)) 797 (aux aux (:var $$ :default _?) `(,var ,(car default))) 798 (reject (error "slice-up-lambda-list : ~w ne peut être ici." last-element)))) 799 800 (declaim (ftype function mini-meval)) ;; récursion mutuelle mini-meval-get-params-from-real -> mini-meval-params / mini-meval 801 (defun mini-meval-params (params etat fixed optional rest key other aux) 802 (let ((new-etat etat) 803 (value nil) 804 (svar nil) 805 (current-key) 806 (search-key) 807 (seen-keys)) 808 (tagbody 809 fixed 810 (when (endp fixed) (go end-fixed)) 811 (when (endp params) (error "mini-meval-params : not enough parameters !")) 812 (setq new-etat (push-local-or-special new-etat (car fixed) 'variable (car params) nil)) 813 (setq params (cdr params)) 814 (setq fixed (cdr fixed)) 815 (go fixed) 816 end-fixed 817 (affect-future-specials new-etat etat) 818 optional 819 (when (endp optional) (go rest)) 820 (if (endp params) 821 (setq value (mini-meval (cadar optional) new-etat)) ;; default value 822 (setq value (car params))) 823 (setq new-etat (push-local-or-special new-etat (caar optional) 'variable value t)) 824 (setq svar (caddar optional)) 825 (when svar 826 (setq new-etat (push-local-or-special new-etat svar 'variable (endp params) t))) 827 (setq params (cdr params)) 828 (setq optional (cdr optional)) 829 (go optional) 830 rest 831 (unless rest (go key)) 832 (setq new-etat (push-local new-etat (car rest) 'variable params)) 833 key 834 (when (or (endp key) (endp params)) (go defaults-keys)) 835 (when (endp (cdr params)) (error "mini-meval-params : odd number of key parameters")) 836 (setq search-key (keyword-to-symbol (car params))) 837 (when (eq search-key (caar key)) 838 (setq current-key (car key)) 839 (push (car current-key) seen-keys) 840 (setq key (cdr key)) 841 (go end-assoc-key-loop)) 842 assoc-key-loop 843 (when (endp (cdr key)) 844 (go unknown-key)) 845 (when (eq search-key (caadr key)) 846 (setq current-key (cadr key)) 847 (push (car current-key) seen-keys) 848 (setf (cdr key) (cddr key)) 849 (go end-assoc-key-loop)) 850 (go assoc-key-loop) 851 end-assoc-key-loop 852 (setq new-etat (push-local-or-special new-etat (second current-key) 'variable (second params) t)) 853 (setq svar (fourth current-key)) 854 (when svar 855 (setq new-etat (push-local-or-special new-etat svar 'variable t t))) 856 (go after-unknown-key) 857 unknown-key 858 (unless (or other (member search-key seen-keys)) 859 (error "mini-meval-params : invalid key : ~w" (car params))) 860 after-unknown-key 861 (setq key (cdr key)) 862 (setq params (cddr params)) 863 defaults-keys 864 (dolist (k key) 865 (setq new-etat (push-local-or-special new-etat (second k) 'variable (mini-meval (third k) new-etat) t)) 866 (setq svar (fourth k)) 867 (when svar 868 (setq new-etat (push-local-or-special new-etat svar 'variable nil t)))) 869 aux 870 (when (endp aux) (go fin)) 871 (setq new-etat (push-local-or-special new-etat (caar aux) 'variable (mini-meval (cadar aux) new-etat) t)) 872 (setq aux (cdr aux)) 873 fin) 874 new-etat)) 875 876 (defun mini-meval-get-params-from-real (etat lambda-list effective-parameters) 877 "Lambda-list doit être déjà sliced." 878 (mini-meval-params effective-parameters etat 879 (cdr (assoc 'fixed lambda-list)) ;; TODO : optimiser ça peut-être... 880 (cdr (assoc 'optional lambda-list)) 881 (cdr (assoc 'rest lambda-list)) 882 (cdr (assoc 'key lambda-list)) 883 (cdr (assoc 'other lambda-list)) 884 (cdr (assoc 'aux lambda-list)))) 885 886 (defun splice-up-tagbody-1 (remaining-body body result) 887 (if (endp remaining-body) 888 (acons nil body result) 889 (if (or (symbolp (car remaining-body)) (numberp (car remaining-body))) 890 (splice-up-tagbody-1 (cdr remaining-body) 891 body 892 (acons (car remaining-body) body result)) 893 (splice-up-tagbody-1 (cdr remaining-body) 894 (cons (car remaining-body) body) 895 result)))) 896 897 (defun splice-up-tagbody (body) 898 (splice-up-tagbody-1 (reverse body) nil nil)) 899 900 (defun mini-meval-error (expr etat &rest message) 901 (error "mini-meval (inner) : ~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w~&etat-special = ~w" 902 (apply #'format nil message) 903 expr 904 (etat-global etat) 905 (etat-local etat) 906 (etat-special etat))) 907 908 (defun transform-quasiquote (expr) 909 (cond 910 ;; a 911 ((atom expr) 912 `',expr) 913 ;; (a) 914 ((atom (car expr)) 915 `(cons ',(car expr) 916 ,(transform-quasiquote (cdr expr)))) 917 ;; (,a) 918 ((eq 'unquote (caar expr)) 919 `(cons ,(cadar expr) 920 ,(transform-quasiquote (cdr expr)))) 921 ;; (,@a) 922 ((eq 'unquote-splice (caar expr)) 923 (if (endp (cdr expr)) 924 (cadar expr) 925 `(append ,(cadar expr) 926 ,(transform-quasiquote (cdr expr))))) 927 ;; ((a ...) ...) 928 (T 929 `(cons ,(transform-quasiquote (car expr)) 930 ,(transform-quasiquote (cdr expr)))))) 931 932 (defun mini-meval (expr &optional (etat (list nil nil nil))) 933 (cond-match 934 expr 935 ((quasiquote :val . _) 936 (mini-meval (transform-quasiquote val) etat)) 937 ((:name $$ :params _*) 938 (let ((definition (assoc-etat name 'macro etat))) 939 (if definition 940 (mini-meval (apply (cdr definition) params) etat) 941 (else)))) 942 ((eval-when :situations ($*) :body _*) 943 (if (member :execute situations) 944 (mini-meval `(progn ,@body) etat) 945 nil)) 946 ((flet ((:name $ :lambda-list @ :fbody _*)*) :body _*) 947 (mini-meval `(progn ,@body) 948 (reduce-on-local 949 etat 950 (lambda (ignore name lambda-list fbody) ignore 951 (list name 'function (mini-meval `(lambda ,lambda-list ,@fbody) etat))) 952 name lambda-list fbody))) 953 ((labels ((:name $ :lambda-list @ :fbody _*)*) :body _*) 954 (let* ((new-etat (reduce-on-local 955 etat 956 (lambda (ignore name) ignore (list name 'function nil)) 957 name)) 958 (new-etat-local (etat-local new-etat))) 959 (dolist* ((name name) (lambda-list lambda-list) (fbody fbody)) 960 (setf (cdr (assoc `(,name . function) new-etat-local :test #'equal)) 961 (mini-meval `(lambda ,lambda-list ,@fbody) new-etat))) 962 (mini-meval `(progn ,@body) new-etat))) 963 ((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _) 964 (mini-meval `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body))) 965 ((let ((:name $ :value _)*) :body _*) 966 (let ((new-etat etat) 967 (res nil)) 968 (dolist* ((name name) (value value)) 969 (setq new-etat (push-local-or-special new-etat name 'variable (mini-meval value etat) nil))) 970 (affect-future-specials new-etat etat) 971 (setq res (mini-meval `(progn ,@body) new-etat)) 972 (pop-special-backups new-etat etat) 973 res)) 974 (((? (eq x 'let*)) ((:name $ :value _)*) :body _*) 975 (let ((new-etat etat) 976 (res nil)) 977 ;; pour chaque variable 978 (dolist* ((name name) (value value)) 979 (setq new-etat (push-local-or-special new-etat name 'variable (mini-meval value new-etat) t))) 980 (setq res (mini-meval `(progn ,@body) new-etat)) 981 (pop-special-backups new-etat etat) 982 res)) 983 ((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*) 984 (let ((new-etat 985 (reduce-on-local 986 etat 987 (lambda (ignore name lambda-list mbody) ignore 988 ;; comme le flet sauf nil au lieu de new-etat-local 989 ;; CLTL 7.5 : 990 ;; The precise rule is that the macro-expansion functions defined 991 ;; by macrolet are defined in the global environment; lexically 992 ;; scoped entities that would ordinarily be lexically apparent 993 ;; are not visible within the expansion functions. 994 (list name 'macro 995 (mini-meval `(lambda ,lambda-list ,@mbody) (replace-local etat nil)))) 996 name lambda-list mbody)) 997 (get-etat (assoc-etat 'trapdoor 'squash-trapdoor etat))) 998 (if (and get-etat (eq (car body) (cdr get-etat))) 999 new-etat ;; Trapdoor pour récupérer l'etat avec les définitions du macrolet. 1000 (mini-meval `(progn ,@body) new-etat)))) 1001 ((progn :body _*) 1002 (let ((res nil)) 1003 (dolist (expr body res) 1004 (setq res (mini-meval expr etat))))) 1005 ((if :condition _ :si-vrai _ :si-faux _?) 1006 (if (mini-meval condition etat) 1007 (mini-meval si-vrai etat) 1008 (if si-faux 1009 (mini-meval (car si-faux) etat) 1010 nil))) 1011 ((lambda :lambda-list @ :body _*) 1012 (let ((sliced-lambda-list (slice-up-lambda-list lambda-list)) 1013 (old-etat etat)) 1014 (lambda (&rest effective-parameters) 1015 (let* ((new-etat (mini-meval-get-params-from-real old-etat sliced-lambda-list effective-parameters)) 1016 (res (mini-meval `(progn ,@body) new-etat))) 1017 (pop-special-backups new-etat etat) 1018 res)))) 1019 ;; Lorsqu'une fonction "littérale" est présente dans le code, on la renvoie telle qu'elle. 1020 ((? functionp) 1021 expr) 1022 ((defun :name $ :lambda-list @ :body _*) 1023 (push-global! etat name 'function 1024 (mini-meval `(lambda ,lambda-list ,@body) etat)) 1025 name) 1026 ((defmacro :name $ :lambda-list @ :body _*) 1027 (push-global! etat name 'macro 1028 (mini-meval `(lambda ,lambda-list ,@body) etat)) 1029 name) 1030 ((defvar :name $ :value _) 1031 (when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't bind ~w : it is a constant." name)) 1032 (let ((definition (assoc-etat name 'variable etat))) 1033 ;; NOTE : if you do a "defvar" while in a "let" that binds the same variable, the result is gibberish and nonsensical. 1034 ;; But that case is fairly rare and not worth the effort and run-time cost. 1035 (push-special! etat name 'variable 1036 (if definition 1037 (cdr definition) 1038 (mini-meval value etat)))) 1039 name) 1040 ((setq :name $ :value _) 1041 (let ((definition (assoc-etat name 'variable etat)) 1042 (real-value (mini-meval value etat))) ;; Faut-il vérifier que NAME n'est pas une constante *avant* de calculer la valeur ? 1043 (if definition 1044 (setf (cdr definition) real-value) 1045 (progn 1046 (when (assoc-etat name 'constant etat) (mini-meval-error expr etat "Can't set ~w : it is a constant." name)) 1047 (push-global! etat name 'variable (mini-meval value etat)))) 1048 real-value)) 1049 ((declaim _*) 1050 nil) 1051 ((error :format _ :args _*) 1052 (error "mini-meval : fonction error appellée par le code, le message est :~&~w" (apply #'format nil format args))) 1053 ((warn :format _ :args _*) 1054 (warn "mini-meval : fonction warn appellée par le code, le message est :~&~w" (apply #'format nil format args))) 1055 ((go :target (? or symbolp numberp)) 1056 (when (null target) 1057 (mini-meval-error expr etat "nil ne peut pas être une étiquette pour un go.")) 1058 (let ((association (assoc `(,target . tagbody-tag) (etat-local etat) :test #'equal))) 1059 (if association 1060 (funcall (cdr association)) 1061 (mini-meval-error expr etat "tentative de faire un go sur une étiquette qui n'existe pas ou plus : ~w.~&~w" target)))) 1062 ((tagbody :body _*) 1063 (let ((spliced-body (splice-up-tagbody body)) 1064 (next-tag nil) 1065 (new-etat nil)) 1066 (tagbody 1067 init 1068 (setq new-etat 1069 (reduce-on-local 1070 etat 1071 (lambda (ignore tag) ignore 1072 (list (car tag) 'tagbody-tag 1073 (lambda () (setq next-tag (car tag)) (go go-to-tag)))) 1074 spliced-body)) 1075 go-to-tag 1076 (mini-meval `(progn ,@(cdr (assoc next-tag spliced-body))) 1077 new-etat)))) 1078 ((return-from :block-name $$ :value _) 1079 (let ((association (assoc `(,block-name . block-name) (etat-local etat) :test #'equal))) 1080 (if association 1081 (funcall (cdr association) value) 1082 (mini-meval-error expr etat "tentative de faire un return-from pour un bloc qui n'existe pas ou plus : ~w." block-name)))) 1083 ((block :block-name $$ :body _*) 1084 (block block-catcher 1085 (mini-meval `(progn ,@body) 1086 (push-local etat block-name 'block-name (lambda (x) (return-from block-catcher x)))))) 1087 ((quote :val _) 1088 val) 1089 ((function :name $$) 1090 (let ((definition (assoc-etat name 'function etat))) 1091 (if definition 1092 (cdr definition) 1093 (mini-meval-error expr etat "Undefined function : ~w." name)))) 1094 ((function :fun (lambda _ . _)) 1095 (mini-meval fun etat)) 1096 ((funcall :name _ :params _*) 1097 (apply (mini-meval name etat) 1098 (mapcar (lambda (x) (mini-meval x etat)) params))) 1099 ((apply :name _ :p1 _ :params _*) 1100 (let ((fun (mini-meval name etat)) 1101 (args (mapcar (lambda (x) (mini-meval x etat)) (cons p1 params)))) 1102 (apply fun (append (butlast args) (car (last args)))))) 1103 ((:lambda (lambda @ _*) :params _*) 1104 (apply (mini-meval lambda etat) (mapcar (lambda (x) (mini-meval x etat)) params))) 1105 (((function :fun (lambda _ . _)) :params . _) 1106 (mini-meval `(,fun ,@params) etat)) 1107 ((:name (function $$) :params _*) 1108 (apply (mini-meval name etat) params)) 1109 ((:name $$ :params _*) 1110 (let ((definition (assoc-etat name 'function etat))) 1111 (if definition 1112 (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat)) params)) 1113 (mini-meval-error expr etat "Undefined function : ~w." name)))) 1114 ((? or numberp stringp) 1115 expr) 1116 ;; TODO : nil et t devraient être des defconst 1117 (nil 1118 nil) 1119 ($$ 1120 (let ((definition (assoc-etat expr 'variable etat))) 1121 (if definition 1122 (cdr definition) 1123 (mini-meval-error expr etat "Undefined variable : ~w." expr)))))) 1124 1125 (defun push-functions (etat functions) 1126 (dolist (f functions) 1127 (push-global! etat f 'function (fdefinition f))) 1128 etat) 1129 1130 (defmacro make-etat (&rest functions) 1131 `(push-functions (list nil nil nil) ',functions)) 1132 1133 (defun etat-exemple () 1134 (make-etat list + - cons car cdr < > <= >= =)) 1135 (mini-meval '(+ 2 3)) 1136 )