diff --git a/bootstrap/1.2.7-read.lisp b/bootstrap/1.2.7-read.lisp index 3e0a25d..565d10a 100644 --- a/bootstrap/1.2.7-read.lisp +++ b/bootstrap/1.2.7-read.lisp @@ -1,6 +1,6 @@ ;; TODO : ne gère pas les échappements "foo\"bar" etc. ni les #... -(defun mread (input-stream) +(defun my-read (input-stream) (let ((result-stack '()) (result nil) (char nil) @@ -20,17 +20,13 @@ (setq char (read-char input-stream nil nil)))) (tagbody start - (print 'start) (get-char) (push 'end stack) (go read-any) read-any - (print 'read-any) (push 'end-read-any stack) read-any-loop - (print 'read-any-loop) - (print char) (cond ((not char) (go end-of-file)) ((char= char #\() (go read-list)) @@ -38,6 +34,7 @@ ((char= char #\') (go read-quote)) ((char= char #\;) (push 'read-any-loop stack) (go read-comment)) ((char= char #\") (go read-string)) + ((member char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :test #'char=) (go read-number)) ((char= char #\#) (go read-sharp)) ((char= char #\`) (go read-backquote)) ((char= char #\,) (go read-unquote)) @@ -45,35 +42,29 @@ ((char= char #\newline) (get-char) (go read-any-loop)) (t (go read-symbol))) ;; \ and | and : fall into this. end-read-any - (print 'end-read-any) (go return) read-list - (print 'read-list) (push-result) (get-char) read-list-loop - (print 'read-list-loop) - (print char) - (print result) + (when (or (char= char #\ ) (char= char #\newline)) + (get-char) + (go read-list-loop)) (when (or (not char) (char= char #\))) (go end-read-list-loop)) - (print char) (push 'read-list-loop stack) (go read-any) end-read-list-loop - (print 'end-read-list-loop) (when (not char) (error "EOF while reading a list")) (get-char) - (format t "~&::~a" result) (push (reverse result) (car result-stack)) (pop-result) ;(get-char) (go return) read-quote - (print 'read-quote) (push-result) (push-val 'quote) (get-char) @@ -89,7 +80,6 @@ read-comment read-comment-loop - (print 'read-cpmment-loop) (get-char) (unless (or (not char) (char= char #\newline)) (go read-comment-loop)) @@ -98,7 +88,6 @@ (go return) read-string - (print 'read-symbol) (get-char) (push-result) (go read-string-loop-start) @@ -114,29 +103,44 @@ (push (format nil "~{~a~}" (reverse result)) (car result-stack)) (pop-result) (go return) + + read-number + (push 'end-read-number stack) + (go read-symbol) + end-read-number + (setf (car result) (parse-integer (string (car result)))) + (go return) read-sharp (get-char) (cond ((char= char #\') (go read-quote-function)) + ((char= char #\\) (go read-sharp-char)) (t (error "bootstrap : read : niy : syntax #~a not implemented yet." char))) read-quote-function - (print 'read-quote-syntax) (push-result) (push-val 'function) (get-char) (go read-quotes-content) + + read-sharp-char + (get-char) + (push 'end-read-sharp-char stack) + (go read-symbol) + end-read-sharp-char + (case (car result) + (newline (setf (car result) #\newline)) + (otherwise (setf (car result) (char (string (car result)) 0)))) + (go return) read-backquote - (print 'read-quote) (push-result) (push-val 'quasiquote) (get-char) (go read-quotes-content) read-unquote - (print 'read-quote) (push-result) (get-char) (cond ((char= char #\@) @@ -150,10 +154,8 @@ (go read-quotes-content) read-symbol - (print 'read-symbol) (push-result) read-symbol-loop - (print 'read-symbol-loop) (push-val char) (get-char) ;; Pas le # : '(a#(1 2)) => '(|a#| (1 2)), pas '(a #(1 2)) @@ -161,11 +163,10 @@ (go read-symbol-loop)) (push (intern (format nil "~:@(~{~a~}~)" (reverse result))) (car result-stack)) (pop-result) - (format t "stack : ~a" stack) (go return) end-of-file - (print 'eof) + (error "End of file not expected here !") return (setq top-stack (car stack)) @@ -177,16 +178,16 @@ (end-read-any (go end-read-any)) (read-list (go read-list)) (read-list-loop (go read-list-loop)) - (read-list-loop-2 (go read-list-loop-2)) (read-quote (go read-quote)) (end-read-quotes (go end-read-quotes)) + (end-read-sharp-char (go end-read-sharp-char)) + (end-read-number (go end-read-number)) (read-symbol (go read-symbol)) (read-symbol-loop (go read-symbol-loop)) (end-of-file (go end-of-file)) (end (go end)) (otherwise (error "bootstrap : read : Invalid return point on the stack : ~w" top-stack))) - end - (print 'end))) + end)) (car result))) ;; (my-read (make-string-input-stream "foo")) @@ -204,3 +205,8 @@ ;; (my-read (make-string-input-stream "'(foo bar;;quux aa ;; baz \"buz\" 'moo)")) + +;; (my-read (make-string-input-stream "'(foo bar;;quux aa +;; (baz #\\y \"buz\") 'moo)")) + +(my-read (make-string-input-stream "(list '(+ 2 3))")) \ No newline at end of file diff --git a/lisp/mini-meval.lisp b/lisp/mini-meval.lisp index 68bcf97..f0b07af 100644 --- a/lisp/mini-meval.lisp +++ b/lisp/mini-meval.lisp @@ -280,13 +280,37 @@ (splice-up-tagbody-1 (reverse body) nil nil)) (defun mini-meval-error (expr etat &rest message) - (error "mini-meval : ~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w~&etat-special = ~w" + (error "mini-meval (outer) : ~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w~&etat-special = ~w" (apply #'format nil message) expr (etat-global etat) (etat-local etat) (etat-special etat))) +(defun transform-quasiquote (expr) + (cond + ;; a + ((atom expr) + `',expr) + ;; (a) + ((atom (car expr)) + `(cons ',(car expr) + ,(transform-quasiquote (cdr expr)))) + ;; (,a) + ((eq 'unquote (caar expr)) + `(cons ,(cadar expr) + ,(transform-quasiquote (cdr expr)))) + ;; (,@a) + ((eq 'unquote-splice (caar expr)) + (if (endp (cdr expr)) + (cadar expr) + `(append ,(cadar expr) + ,(transform-quasiquote (cdr expr))))) + ;; ((a ...) ...) + (T + `(cons ,(transform-quasiquote (car expr)) + ,(transform-quasiquote (cdr expr)))))) + #| Mini-meval est un meval très simple destiné à évaluer les macros et les autres directives avec eval-when :compile-toplevel. @@ -305,6 +329,8 @@ Mini-meval sera appellé sur des morceaux spécifiques du fichier source. Il fau (cond-match expr + ((quasiquote :val . _) + (mini-meval (transform-quasiquote val) etat)) #| 2) Cas des macros |# ((:name $$ :params _*) (let ((definition (assoc-etat name 'macro etat))) diff --git a/lisp/read.lisp b/lisp/read.lisp new file mode 120000 index 0000000..cce1c66 --- /dev/null +++ b/lisp/read.lisp @@ -0,0 +1 @@ +../bootstrap/1.2.7-read.lisp \ No newline at end of file diff --git a/lisp/t.lisp b/lisp/t.lisp new file mode 100644 index 0000000..eb3d952 --- /dev/null +++ b/lisp/t.lisp @@ -0,0 +1,8 @@ +(load "../bootstrap/1.2.7-read.lisp") +(load "mini-meval") + +(defvar tmm nil) +(setq tmm (my-read (open "tmm.lisp"))) + +(defvar e-tmm nil) +(setq e-tmm (make-etat list + - cons car cdr < > <= >= = make-symbol)) diff --git a/lisp/tmm.lisp b/lisp/tmm.lisp new file mode 100644 index 0000000..f0c1523 --- /dev/null +++ b/lisp/tmm.lisp @@ -0,0 +1,1110 @@ +(progn + (defun n-consp (n l) + "Détermine s'il y a au moins n cellules dans la liste l." + (if (<= n 0) + t + (and (consp l) + (n-consp (- n 1) (cdr l))))) + + (defun reverse-alist (alist) + (mapcar (lambda (x) (cons (car x) (reverse (cdr x)))) + alist)) + + (defun group-1 (lst &optional result) + "Groupe les éléments d'une lste en fonction de leur premier élément, et renvoie une lste associative" + (if (endp lst) + result + (let ((association (assoc (caar lst) result))) + (if association + (push (cdar lst) (cdr association)) + (push (cons (caar lst) (list (cdar lst))) result)) + (group-1 (cdr lst) result)))) + + (defun group (lst) + (reverse-alist (group-1 lst))) + + (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)))) + + + + + + + + + + + + + + + + + + + + + + + + + + + (declaim (ftype function assembly-place-p)) ;; définie dans compilation.lisp + (declaim (ftype function immutable-assembly-place-p)) ;; définie dans compilation.lisp + (declaim (ftype function mutable-assembly-place-p)) ;; définie dans compilation.lisp + + (defun pattern-match-do-lambdas-transform (pattern) + (mapcar (lambda (pred) + (cond ((atom pred) (list 'function pred)) + ((eq (car pred) 'function) pred) + ((eq (car pred) 'lambda) pred) + (t + `(lambda (x) x ,pred)))) + pattern)) + + (defun pattern-match-do-lambdas-1 (pattern) + (if (atom pattern) + `',pattern + `(list ',(first pattern) + ',(second pattern) + ,(if (second pattern) + (let ((?-clause (cdr (third pattern))) + (type '_)) + (when (and (consp ?-clause) (member (car ?-clause) '(nil _ $ $$ $k $n $ap $iap $map $& @ @.))) + (setq type (car ?-clause)) + (setq ?-clause (cdr ?-clause))) + ;; TODO : (? or foo (? _ and bar baz) (? $ and quux)) + (cond ((atom ?-clause) `(list ',type 'and #'identity)) + ((eq 'and (first ?-clause)) `(list ',type 'and ,@(pattern-match-do-lambdas-transform (cdr ?-clause)))) + ((eq 'or (first ?-clause)) `(list ',type 'or ,@(pattern-match-do-lambdas-transform (cdr ?-clause)))) + (t `(list ',type 'and ,@(pattern-match-do-lambdas-transform ?-clause))))) + (pattern-match-do-lambdas-1 (third pattern))) + ',(fourth pattern) + ,(pattern-match-do-lambdas-1 (fifth pattern))))) + + (defmacro pattern-match-do-lambdas (pattern) + "Transforme les (? ()) et (? (lambda ...)) en vrais lambdas." + (pattern-match-do-lambdas-1 pattern)) + + (defun transform-symbol-to-multi (pat) + (let ((str-sym (string pat))) + (if (< (length str-sym) 2) + pat + (let* ((sym (map 'list #'identity str-sym)) + (lsym (car (last sym)))) + (if (or (char= lsym #\*) + (char= lsym #\+) + (char= lsym #\?)) + (list (intern (format nil "~{~a~}" (butlast sym))) + (intern (string lsym))) + pat))))) + + (defun pattern-match-preprocess-multi (pattern) + "Transforme les symbol*, symbol+ et symbol? + en symbol *, symbol + et symbol ?" + (cond ((and (consp pattern) (eq '? (first pattern))) + pattern) ;; On ne touche pas les (? ...) + ((consp pattern) + (labels ((transform-symbol-to-multi (pat) + (let ((str-sym (string pat))) + (if (< (length str-sym) 2) + pat + (let* ((sym (map 'list #'identity str-sym)) + (lsym (car (last sym)))) + (if (or (char= lsym #\*) + (char= lsym #\+) + (char= lsym #\?)) + (list (intern (format nil "~{~a~}" (butlast sym))) + (intern (string lsym))) + pat))))) + (recurse (pat) + (cond + ((null pat) nil) + ((symbolp pat) (transform-symbol-to-multi pat)) + ((atom pat) pat) + ((keywordp (car pat)) ;; TODO : non testé !!! + `(,(car pat) + ,@(recurse (cdr pat)))) + ((symbolp (car pat)) + (let ((transf (transform-symbol-to-multi (car pat)))) + (if (consp transf) + `(,@transf ,@(recurse (cdr pat))) + `(,transf ,@(recurse (cdr pat)))))) + (t (cons (pattern-match-preprocess-multi (car pat)) + (recurse (cdr pat))))))) + (recurse pattern))) + ((symbolp pattern) + (transform-symbol-to-multi pattern)) + (t + pattern))) + + (defun keyword-to-symbol (keyword) + (intern (format nil "~a" keyword))) + + (defun pattern-match-preprocess-capture (pattern &optional capture-name) + "Transforme pattern en un arbre (capture-name is-predicate pattern multi rest)." + (if (and (consp pattern) (keywordp (car pattern))) + ;; capture-name + (if (and (n-consp 2 (cdr pattern)) (member (caddr pattern) '(* + ?))) + ;; avec capture-name, avec multi + (list (keyword-to-symbol capture-name) + nil + (pattern-match-preprocess-capture (second pattern) (first pattern)) + (third pattern) + (pattern-match-preprocess-capture (cdddr pattern))) + ;; avec capture-name, sans multi + (cond + ;; (:x . a) + ((atom (cdr pattern)) + (list (keyword-to-symbol (car pattern)) + nil + (cdr pattern) + nil + nil)) + ;; (:x . (? ...)) + ((and (consp pattern) (eq '? (cadr pattern))) + (list (keyword-to-symbol (car pattern)) + t + (cdr pattern) + nil + nil)) ;; TODO + ;; (:x cadr-pattern . cddr-pattern) + (t + (list (keyword-to-symbol capture-name) + nil + (pattern-match-preprocess-capture (cadr pattern) (car pattern)) + nil + (pattern-match-preprocess-capture (cddr pattern)))))) + ;; pas de capture-name + (if (and (n-consp 2 pattern) (member (cadr pattern) '(* + ?))) + ;; sans capture-name, avec multi + (list (keyword-to-symbol capture-name) + nil + (pattern-match-preprocess-capture (first pattern)) + (second pattern) + (pattern-match-preprocess-capture (cddr pattern))) + ;; sans capture-name, sans multi + (cond + ;; a + ((atom pattern) + (list (keyword-to-symbol capture-name) + nil + pattern + nil + nil)) + ;; (? ...) + ((and (consp pattern) (eq '? (car pattern))) + (list (keyword-to-symbol capture-name) + t + pattern + nil + nil)) + ;; (car-pattern . cdr-pattern) + (t + (list (keyword-to-symbol capture-name) + nil + (pattern-match-preprocess-capture (car pattern)) + nil + (pattern-match-preprocess-capture (cdr pattern)))))))) + + (defun append-captures-1 (captures-1 captures-2) + (if (endp captures-1) + nil + (if (caar captures-1) ;; ignorer les captures nommées nil + (cons (cons (caar captures-1) ;; nom de capture + (cons (cdar captures-1) ;; nouvelle capture + (cdr (assoc (caar captures-1) captures-2)))) + (append-captures-1 (cdr captures-1) captures-2)) + (append-captures-1 (cdr captures-1) captures-2)))) + + (defun append-captures (captures-1 captures-2) + "captures-1 et 2 sont des alist nom-capture . arbre-capture + Renvoie une alist nom-capture . (append arbre-c1 arbre-c2)" + (cons (append-captures-1 captures-1 (car captures-2)) + (cdr captures-2))) + + (defun make-empty-matches-1 (pattern result) + (if (atom pattern) + result + (let ((here (if (first pattern) ;; pas les captures nommées nil + (acons (first pattern) nil result) + result))) + (if (second pattern) ;; ne pas descendre dans les les (? ...) + here + (make-empty-matches-1 (fifth pattern) + (make-empty-matches-1 (third pattern) here)))))) + + (defun make-empty-matches (pattern) + (reverse (make-empty-matches-1 pattern '()))) + + (defun acons-capture (capture-name value captures) + (if (or capture-name (not captures)) + (acons capture-name value captures) + captures)) + + (defun append-car-cdr-not-nil (c) + (if (or (car c) (cdr c)) + (append (car c) (cdr c)) + (acons nil nil nil))) + + (defun append-not-nil-1 (a b) + (if (endp a) + b + (if (caar a) + (cons (car a) (append-not-nil-1 (cdr a) b)) + (append-not-nil-1 (cdr a) b)))) + + (defun append-not-nil (a b) + (or (append-not-nil-1 a b) + (acons nil nil nil))) + + (declaim (ftype function pattern-match)) ;; récursion mutuelle recursive-backtrack / pattern-match + (defun recursive-backtrack (pattern rest expr capture-name) + (or + ;; match greedy (on avance dans le *) + (and (consp expr) + (let ((greedy-left (pattern-match pattern (car expr)))) + (when greedy-left + (let ((greedy-right (recursive-backtrack pattern rest (cdr expr) capture-name))) + (when greedy-right + (append-captures (acons-capture capture-name (car expr) greedy-left) + greedy-right)))))) + ;; match non-greedy (on match avec le rest) + (let ((non-greedy (pattern-match rest expr))) + (when non-greedy + (cons (acons-capture capture-name expr (make-empty-matches pattern)) + non-greedy))))) + + (defun pattern-match (pat expr) + (let ((capture-name (first pat)) + (is-predicate (second pat)) + (pattern (third pat)) + (multi (fourth pat)) + (rest (fifth pat))) + (if multi + (if (not (listp expr)) + nil + (cond + ;; (pattern * ...) + ((eq multi '*) + (let ((match (recursive-backtrack pattern rest expr capture-name))) + (when match + (append-car-cdr-not-nil match)))) + ;; (pattern + ...) + ((eq multi '+) + (let ((first-match (and (consp expr) (pattern-match pattern (car expr))))) + (when first-match + (let ((match (recursive-backtrack pattern rest (cdr expr) capture-name))) + (when match + (let ((result (append-captures first-match match))) + (append-car-cdr-not-nil result))))))) + ;; (pattern ? ...) + ((eq multi '?) + (let ((match (and (consp expr) (pattern-match pattern (car expr))))) + (or (when match + (let ((match-rest (pattern-match rest (cdr expr)))) + (when match-rest + ;; Attention, les trois lignes suivantes ont été modifiées sans que je comprenne vraiement les manipulations... + (append-car-cdr-not-nil + (append-captures match (cons (acons-capture capture-name expr (make-empty-matches pattern)) + match-rest)))))) + (let ((match-only-rest (pattern-match rest expr))) + (when match-only-rest + (append (acons-capture capture-name expr (make-empty-matches pattern)) + match-only-rest)))))))) + (if rest + ;; (pattern . rest) + (and (consp expr) + (let ((left (pattern-match pattern (car expr)))) + (when left + (let ((right (pattern-match rest (cdr expr)))) + (when right + (acons-capture capture-name expr (append-not-nil left right))))))) + ;; pattern est un atom + (cond + ;; (? ) + (is-predicate + (when (and (pattern-match `(nil nil ,(car pattern) nil nil) expr) + (cond + ;; (? _ and symbole-1 ... symbole-n) + ((eq 'and (second pattern)) + (every (lambda (predicat) (funcall predicat expr)) (cddr pattern))) + ;; (? _ or symbole-1 ... symbole-n) + ((eq 'or (second pattern)) + (some (lambda (predicat) (funcall predicat expr)) (cddr pattern))))) + (acons-capture capture-name expr nil))) + ;; () + ((null pattern) + (when (null expr) + (acons-capture capture-name expr nil))) + ;; $ + ((eq '$ pattern) + (when (and (atom expr) + (not (null expr))) + (acons-capture capture-name expr nil))) + ;; $$ + ((eq '$$ pattern) + (when (symbolp expr) + (acons-capture capture-name expr nil))) + ;; $k + ((eq '$k pattern) + (when (keywordp expr) + (acons-capture capture-name expr nil))) + ;; $ap + ((eq '$ap pattern) + (when (assembly-place-p expr) + (acons-capture capture-name expr nil))) + ;; $iap + ((eq '$iap pattern) + (when (immutable-assembly-place-p expr) + (acons-capture capture-name expr nil))) + ;; $ap + ((eq '$map pattern) + (when (mutable-assembly-place-p expr) + (acons-capture capture-name expr nil))) + ;; $n + ((eq '$n pattern) + (when (numberp expr) + (acons-capture capture-name expr nil))) + ;; $& + ((eq '$& pattern) + (when (and (symbolp expr) (member expr '(&optional &rest &key &allow-other-keys &aux))) + (acons-capture capture-name expr nil))) + ;; @ + ((eq '@ pattern) + (when (propper-list-p expr) + (acons-capture capture-name expr nil))) + ;; @. + ((eq '@. pattern) + (when (consp expr) + (acons-capture capture-name expr nil))) + ;; _ + ((eq '_ pattern) + (acons-capture capture-name expr nil)) + ;; Autres valeurs (symbole, nombre, etc.) + (t + (when (equal pattern expr) + (acons-capture capture-name expr nil)))))))) + + (defmacro pattern-match-preprocess (pattern) + "Tous les preprocess de pattern-match en un seul appel." + `(pattern-match-do-lambdas + ,(pattern-match-preprocess-capture + (pattern-match-preprocess-multi + pattern)))) + + (defmacro real-match (pattern expr body &optional else-clause) + (let* ((result-sym (make-symbol "RESULT")) + (result-of-if-sym (make-symbol "RESULT-OF-IF")) + (pattern-sym (make-symbol "PATTERN")) + (else-sym (make-symbol "ELSE")) + (pattern-preproc (pattern-match-preprocess-capture + (pattern-match-preprocess-multi + pattern))) + (capture-names (mapcar #'car (make-empty-matches pattern-preproc)))) + `(let* ((,pattern-sym (pattern-match-do-lambdas ,pattern-preproc)) + (,result-sym (pattern-match ,pattern-sym ,expr)) + (,result-of-if-sym + (if ,result-sym + ;; Si le match a été effectué avec succès + ,@(if body + ;; Si on a un body + ;; On bind les variables correspondant aux noms de capture + `((let ,(mapcar (lambda (x) `(,x (cdr (assoc ',x ,result-sym)))) + capture-names) + ;; "utilisation" des variables pour éviter les warning unused variable. + ,@capture-names + ;; On définit la fonction "else" qui produit le "code secret" permettant d'exécuter le else. + (labels ((else () ',else-sym)) + ;; On exécute le body + ,@body))) + ;; S'il n'y a pas de body, on renvoie l'alist des captures s'il y en a ou T sinon. + (if capture-names + `((remove nil ,result-sym :key #'car)) + `(t))) + ;; Si on ne match pas, on renvoie le "code secret" permettant d'exécuter le else. + ',else-sym))) + ;; Si le résultat est le "code secret" du else, on fait le else, sinon on renvoie le résultat + (if (eq ,result-of-if-sym ',else-sym) + ,else-clause + ,result-of-if-sym)))) + + (defmacro match (pattern expr &rest body) + (if (keywordp pattern) + `(real-match (,pattern . ,expr) ,(car body) ,(cdr body)) + `(real-match ,pattern ,expr ,body))) + + (defmacro cond-match-1 (expr cond-clauses) + (if (endp cond-clauses) + 'nil + (if (keywordp (caar cond-clauses)) + `(real-match (,(caar cond-clauses) . ,(cadar cond-clauses)) + ,expr + ,(cddar cond-clauses) + (cond-match-1 ,expr ,(cdr cond-clauses))) + `(real-match ,(caar cond-clauses) + ,expr + ,(cdar cond-clauses) + (cond-match-1 ,expr ,(cdr cond-clauses)))))) + + (defmacro cond-match (expr &rest cond-clauses) + (let ((expr-sym (make-symbol "expr"))) + `(let ((,expr-sym ,expr)) + (cond-match-1 ,expr-sym ,cond-clauses)))) + + (defun match--transitions-to-progns (transitions) + ;; On remet to, pattern et code bout à bout (c'est tout du code) + (mapcar (lambda (x) `(progn ,(car x) ,@(cadr x) ,@(caddr x))) + transitions)) + + (defmacro match-automaton (expr initial-state &rest rules) + (match ((:from $$ :to _ :pattern _? :code _*) *) rules + (let ((storage (mapcar (lambda (s) (cons s (make-symbol (format nil "STORAGE-~a" (string s))))) (remove-duplicates from))) + (expr-sym (make-symbol "EXPR")) + (block-sym (make-symbol "BLOCK")) + (grouped-transitions (group (mapcar #'list from to pattern code))) + (last-state-sym (make-symbol "LAST-STATE")) + (last-element-sym (make-symbol "LAST-ELEMENT"))) + `(let (,@(mapcar (lambda (s) `(,(cdr s) nil)) storage) + (,expr-sym ,expr) + (,last-state-sym 'initial) + (,last-element-sym nil)) + (block ,block-sym + (tagbody + initial + (progn ,(match--transitions-to-progns (cdr (assoc 'initial grouped-transitions)))) + (go ,initial-state) + accept + (let ((return-value (list ,@(mapcar (lambda (s) `(cons ',(car s) (reverse ,(cdr s)))) storage)))) + return-value + (return-from ,block-sym + (progn return-value + ,@(match--transitions-to-progns (cdr (assoc 'accept grouped-transitions)))))) + reject + (return-from ,block-sym + (let ((last-element ,last-element-sym) + (last-state ,last-state-sym)) + last-element + last-state + (progn nil + ,@(match--transitions-to-progns (cdr (assoc 'reject grouped-transitions)))))) + ,@(loop + for (from . transitions) in grouped-transitions + and temp-do = nil + and temp-collect = nil + ;; syntaxe (stateX code) => exécute le code à chaque fois qu'on rentre dans stateX. + for jump = (member nil (reverse transitions) :key #'second) + unless (member from '(initial accept reject)) + collect from + and collect `(setq ,last-state-sym ',from) + and collect `(setq ,last-element-sym (car ,expr-sym)) + and if jump + ;; va à l'état désigné par la dernière transition "finale". + collect `(when (endp ,expr-sym) (go ,(caar jump))) + else + collect `(when (endp ,expr-sym) (go reject)) + end + and do (setq temp-do (remove nil (mapcar (lambda (x) (when (eq 'do (car x)) `(progn ,@(cadr x) ,@(caddr x)))) transitions))) + and do (setq temp-collect (remove nil (mapcar (lambda (x) (when (eq 'collect (car x)) `(progn ,@(cadr x) ,@(caddr x)))) transitions))) + and when (or temp-do temp-collect) + collect `(let ((last-element ,last-element-sym) + (last-state ,last-state-sym)) + last-element + last-state + ,@(if temp-do `((progn ,@temp-do)) nil) + ,@(if temp-collect `((push (progn ,@temp-collect) ,(cdr (assoc from storage)))) nil)) + end + and collect `(cond-match (car ,expr-sym) + ,@(loop + for (to pattern code) in transitions + unless (or (not pattern) (eq to 'do) (eq to 'collect)) + if code + collect `(,@pattern + (push (progn ,@code) ,(cdr (assoc from storage))) + (setq ,expr-sym (cdr ,expr-sym)) + (go ,to)) + else + collect `(,@pattern + (setq ,expr-sym (cdr ,expr-sym)) + (go ,to))) + (_ ,(if jump `(go ,(caar jump)) '(go reject))))))))))) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + (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 atomique (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 + ;; - setf (écrire la macro) + ;; - fdefinition, funcctionp, … + ;; - symbolp, keywordp, keywords non mutables + nil et t, intern, make-symbol + ;; - car / cdr, replaca replacad, cons, list (fonction), listp, consp, atom, null (ou eq nil), … + ;; - 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 / close + ;; - defvar [done mini-meval] (gestion correcte des variables spéciales) + ;; - array support (array-total-size, row-major-aref, copy-seq) + ;; - string support (char=, map, string (symbol => string), format, print) + ;; - coder un reverse rapide. + ;; - transformation de la récursion terminale. + + ;; - vérifier qu'on a pas transformé certaines fonctions en formes spéciales (il faut qu'on puisse toujours les récupérer avec #'). + ;; - sortir le defun du mini-meval ? + + ;; cell (un seul pointeur, transparent (y compris pour le type), + ;; avec trois fonctions spéciales pour le get / set / tester le type), + ;; sera utilisé pour les closures et les variables spéciales. + + ;; TODO : bug : pourquoi les keyword-to-symbol ??? on devrait garder le keyword tel quel. + (defun slice-up-lambda-list (lambda-list) + (match-automaton lambda-list fixed + (fixed accept) + (fixed optional &optional) + (fixed rest &rest) + (fixed key &key) + (fixed aux &aux) + (fixed reject $&) + (fixed fixed (:var . $$) var) + (optional accept) + (optional rest &rest) + (optional key &key) + (optional aux &aux) + (optional reject $&) + (optional optional (:var . $$) `(,var nil nil)) + (optional optional (:var $$ :default _? :svar $$?) `(,var ,(car default) ,(car svar))) + (rest reject $&) + (rest rest2 (:var . $$) var) + (rest2 accept) + (rest2 key &key) + (rest2 aux &aux) + (rest2 reject $&) + (key accept) + (key other &allow-other-keys) + (key aux &aux) + (key reject $&) + (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-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-to-symbol keyword) ,var ,(car default) ,(car svar))) + (other collect t) + (other accept) + (other aux &aux) + (other reject $&) + (aux accept) + (aux reject $&) + (aux aux (:var . $$) `(,var nil)) + (aux aux (:var $$ :default _?) `(,var ,(car default))) + (reject (error "slice-up-lambda-list : ~w ne peut être ici." last-element)))) + + (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 params (cdr params)) + (setq fixed (cdr fixed)) + (go fixed) + end-fixed + (affect-future-specials new-etat etat) + 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 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 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)) + + (defun mini-meval-get-params-from-real (etat lambda-list effective-parameters) + "Lambda-list doit être déjà sliced." + (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 (remaining-body body result) + (if (endp remaining-body) + (acons nil body result) + (if (or (symbolp (car remaining-body)) (numberp (car remaining-body))) + (splice-up-tagbody-1 (cdr remaining-body) + body + (acons (car remaining-body) body result)) + (splice-up-tagbody-1 (cdr remaining-body) + (cons (car remaining-body) body) + result)))) + + (defun splice-up-tagbody (body) + (splice-up-tagbody-1 (reverse body) nil nil)) + + (defun mini-meval-error (expr etat &rest message) + (error "mini-meval (inner) : ~w~&expression = ~w~&etat-global = ~w~&etat-local = ~w~&etat-special = ~w" + (apply #'format nil message) + expr + (etat-global etat) + (etat-local etat) + (etat-special etat))) + + (defun transform-quasiquote (expr) + (cond + ;; a + ((atom expr) + `',expr) + ;; (a) + ((atom (car expr)) + `(cons ',(car expr) + ,(transform-quasiquote (cdr expr)))) + ;; (,a) + ((eq 'unquote (caar expr)) + `(cons ,(cadar expr) + ,(transform-quasiquote (cdr expr)))) + ;; (,@a) + ((eq 'unquote-splice (caar expr)) + (if (endp (cdr expr)) + (cadar expr) + `(append ,(cadar expr) + ,(transform-quasiquote (cdr expr))))) + ;; ((a ...) ...) + (T + `(cons ,(transform-quasiquote (car expr)) + ,(transform-quasiquote (cdr expr)))))) + + (defun mini-meval (expr &optional (etat (list nil nil nil))) + + (cond-match + expr + ((quasiquote :val . _) + (mini-meval (transform-quasiquote val) etat)) + ((:name $$ :params _*) + (let ((definition (assoc-etat name 'macro etat))) + (if definition + (mini-meval (apply (cdr definition) params) etat) + (else)))) + ((eval-when :situations ($*) :body _*) + (if (member :execute situations) + (mini-meval `(progn ,@body) etat) + nil)) + ((flet ((:name $ :lambda-list @ :fbody _*)*) :body _*) + (mini-meval `(progn ,@body) + (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-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))) + ((:type (? or (eq x 'let) (eq x 'let*)) :bindings (? and consp (find-if #'symbolp x)) :body . _) + (mini-meval `(,type ,(mapcar (lambda (b) (if (consp b) b `(b nil))) bindings) ,@body))) + ((let ((:name $ :value _)*) :body _*) + (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))) + (affect-future-specials new-etat etat) + (setq res (mini-meval `(progn ,@body) new-etat)) + (pop-special-backups new-etat etat) + res)) + (((? (eq x 'let*)) ((:name $ :value _)*) :body _*) + (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))) + (setq res (mini-meval `(progn ,@body) new-etat)) + (pop-special-backups new-etat etat) + res)) + ((macrolet ((:name $ :lambda-list @ :mbody _*)*) :body _*) + (let ((new-etat + (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) (replace-local etat nil)))) + name lambda-list mbody)) + (get-etat (assoc-etat 'trapdoor 'squash-trapdoor etat))) + (if (and get-etat (eq (car body) (cdr get-etat))) + new-etat ;; Trapdoor pour récupérer l'etat avec les définitions du macrolet. + (mini-meval `(progn ,@body) new-etat)))) + ((progn :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) + (mini-meval si-vrai etat) + (if si-faux + (mini-meval (car si-faux) etat) + nil))) + ((lambda :lambda-list @ :body _*) + (let ((sliced-lambda-list (slice-up-lambda-list lambda-list)) + (old-etat etat)) + (lambda (&rest 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)))) + ;; Lorsqu'une fonction "littérale" est présente dans le code, on la renvoie telle qu'elle. + ((? functionp) + expr) + ((defun :name $ :lambda-list @ :body _*) + (push-global! etat name 'function + (mini-meval `(lambda ,lambda-list ,@body) etat)) + name) + ((defmacro :name $ :lambda-list @ :body _*) + (push-global! etat name 'macro + (mini-meval `(lambda ,lambda-list ,@body) etat)) + name) + ((defvar :name $ :value _) + (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-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 + (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)) + ((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 (? or symbolp numberp)) + (when (null target) + (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 "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 nil)) + (tagbody + init + (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))) + new-etat)))) + ((return-from :block-name $$ :value _) + (let ((association (assoc `(,block-name . block-name) (etat-local etat) :test #'equal))) + (if association + (funcall (cdr association) value) + (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) + (push-local etat block-name 'block-name (lambda (x) (return-from block-catcher x)))))) + ((quote :val _) + val) + ((function :name $$) + (let ((definition (assoc-etat name 'function etat))) + (if definition + (cdr definition) + (mini-meval-error expr etat "Undefined function : ~w." name)))) + ((function :fun (lambda _ . _)) + (mini-meval fun etat)) + ((funcall :name _ :params _*) + (apply (mini-meval name etat) + (mapcar (lambda (x) (mini-meval x etat)) params))) + ((apply :name _ :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)))))) + ((:lambda (lambda @ _*) :params _*) + (apply (mini-meval lambda etat) (mapcar (lambda (x) (mini-meval x 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 + (apply (cdr definition) (mapcar (lambda (x) (mini-meval x etat)) params)) + (mini-meval-error expr etat "Undefined function : ~w." name)))) + ((? or numberp stringp) + expr) + ;; TODO : nil et t devraient être des defconst + (nil + nil) + ($$ + (let ((definition (assoc-etat expr 'variable etat))) + (if definition + (cdr definition) + (mini-meval-error expr etat "Undefined variable : ~w." expr)))))) + + (defun push-functions (etat functions) + (dolist (f functions) + (push-global! etat f 'function (fdefinition f))) + etat) + + (defmacro make-etat (&rest functions) + `(push-functions (list nil nil nil) ',functions)) + + (defun etat-exemple () + (make-etat list + - cons car cdr < > <= >= =)) + (mini-meval '(+ 2 3)) +)