squash-lisp-2.lisp (8005B)
1 (require 'mini-meval "mini-meval") ;; slice-up-lambda-list 2 (require 'match "match") 3 (require 'util "match") ;; derived-symbol, assoc-or, assoc-or-push 4 5 (defun squash-lisp-2 (expr &optional env-var env-fun (globals (cons nil nil))) 6 (cond-match 7 expr 8 ((progn :body _*) 9 `(progn ,@(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) body))) 10 ((if :condition _ :si-vrai _ :si-faux _) 11 `(if ,(squash-lisp-2 condition env-var env-fun globals) 12 ,(squash-lisp-2 si-vrai env-var env-fun globals) 13 ,(squash-lisp-2 si-faux env-var env-fun globals))) 14 ((unwind-protect :body _ :cleanup _) 15 `(unwind-protect ,(squash-lisp-2 body env-var env-fun globals) 16 ,(squash-lisp-2 cleanup env-var env-fun globals))) 17 ((:type (? (member x '(unwind-catch tagbody-unwind-catch))) :object _ :body _ :catch-code _) 18 `(,type ,(squash-lisp-2 object env-var env-fun globals) 19 ,(squash-lisp-2 body env-var env-fun globals) 20 ,(squash-lisp-2 catch-code env-var env-fun globals))) 21 ((unwind :object _) 22 `(unwind ,(squash-lisp-2 object env-var env-fun globals))) 23 ((unwind-for-tagbody :object _ :post-unwind-code _) 24 `(unwind-for-tagbody ,(squash-lisp-2 object env-var env-fun globals) 25 ,(squash-lisp-2 post-unwind-code env-var env-fun globals))) 26 ((jump-label :name $$) 27 expr) 28 ((jump :dest $$) 29 expr) 30 ((super-let :name ($$*) :stuff _*) 31 (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) 32 (labels ((transform-super-let (expr) 33 `(progn 34 ,@(loop 35 for (type . clause) in stuff 36 when (eq type 'set) 37 collect `(setq ,(cdr (assoc (car clause) name)) (squash-lisp-2 (cadr clause) env-var env-fun globals)) 38 when (eq type 'use-var) 39 do (push (assoc (car clause) name) env-var) 40 when (eq type 'use-fun) 41 do (push (assoc (car clause) name) env-fun) 42 when (eq type 'if) 43 do `(if ,(squash-lisp-2 (car clause) env-var env-fun globals) 44 (progn ,(mapcar #'transform-super-let (cadr clause))) 45 (progn ,(mapcar #'transform-super-let (caddr clause)))) 46 when (eq type 'progn) 47 collect `(progn ,(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) clause)))))) 48 `(let ,(mapcar #'cdr name) 49 ,(transform-super-let expr)))) 50 ((let ((:name $$ :value _)*) :body _) 51 (squash-lisp-2 52 `(super-let ,name 53 ,@(mapcar (lambda (n v) `(set ,n ,v)) name value) 54 ,@(mapcar (lambda (n) `(use-var ,n)) name) 55 (progn ,body)) 56 env-var env-fun globals)) 57 (((? (eq x 'let*)) ((:name $$ :value _)*) :body _) 58 (squash-lisp-2 59 `(super-let ,name 60 ,@(loop 61 for n in name 62 for v in value 63 collect `(set ,n ,v) 64 collect `(use-var ,n)) 65 (progn ,body)) 66 env-var env-fun globals)) 67 ((simple-flet ((:name $$ :value _)*) :body _) 68 (squash-lisp-2 69 `(super-let ,name 70 ,@(mapcar (lambda (n v) `(set ,n ,v)) name value) 71 ,@(mapcar (lambda (n) `(use-fun ,n)) name) 72 (progn ,body)) 73 env-var env-fun globals)) 74 ((simple-labels ((:name $$ :value _)*) :body _) 75 (squash-lisp-2 76 `(super-let ,name 77 ,@(mapcar (lambda (n) `(use-fun ,n)) name) 78 ,@(mapcar (lambda (n v) `(set ,n ,v)) name value) 79 (progn ,body)) 80 env-var env-fun globals)) 81 ;; ((let ((:name $$ :value _)*) :body _) 82 ;; (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) 83 ;; (let ((new-env-var (append name env-var))) 84 ;; `(let ,(mapcar #'cdr name) 85 ;; (progn ,@(mapcar (lambda (n v) 86 ;; `(setq ,(cdr n) ,(squash-lisp-2 v env-var env-fun globals))) 87 ;; name value) 88 ;; ,(squash-lisp-2 body new-env-var env-fun globals))))) 89 ;; (((? (eq x 'let*)) ((:name $$ :value _)*) :body _) 90 ;; (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) 91 ;; (let ((new-env-var env-var)) ;; old = ((new-env-var (append name env-var))) 92 ;; `(let ,(mapcar #'cdr name) 93 ;; (progn ,@(mapcar (lambda (n v) 94 ;; (push (cons n v) new-env-var) ;; Ajouté 95 ;; `(setq ,(cdr n) ,(squash-lisp-2 v new-env-var env-fun globals))) ;; env-var -> new-env-var !!! 96 ;; name value) 97 ;; ,(squash-lisp-2 body new-env-var env-fun globals))))) 98 ;; ((simple-flet ((:name $$ :value _)*) :body _) 99 ;; (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) 100 ;; (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun + env-var -> env-fun 101 ;; `(let ,(mapcar #'cdr name) 102 ;; (progn ,@(mapcar (lambda (n v) 103 ;; `(setq ,(cdr n) ,(squash-lisp-2 v env-var env-fun globals))) 104 ;; name value) 105 ;; ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun 106 ;; ((simple-labels ((:name $$ :value _)*) :body _) 107 ;; (setq name (mapcar (lambda (x) (cons x (derived-symbol x))) name)) 108 ;; (let ((new-env-fun (append name env-fun))) ;; new-env-var -> new-env-fun + env-var -> env-fun 109 ;; `(let ,(mapcar #'cdr name) 110 ;; (progn ,@(mapcar (lambda (n v) 111 ;; `(setq ,(cdr n) ,(squash-lisp-2 v env-var new-env-fun globals))) ;; env-fun -> new-env-fun 112 ;; name value) 113 ;; ,(squash-lisp-2 body env-var new-env-fun globals))))) ;; env-var -> env-fun 114 ;; TODO 115 ((lambda :params @ :body _) 116 ;; TODO : simplifier la lambda-list 117 (squash-lisp-1-check body)) 118 ;; TODO 119 ((function :fun $$) 120 (assoc-or fun env-fun 121 (assoc-or-push fun (derived-symbol (string fun)) (cdr globals)))) 122 ((funcall :fun _ :params _*) 123 `(funcall ,(squash-lisp-2 fun env-var env-fun globals) 124 ,@(mapcar (lambda (x) (squash-lisp-2 x env-var env-fun globals)) params))) 125 ((quote _) 126 expr) 127 ((get-var :var $$) 128 (assoc-or var env-var 129 (assoc-or-push var (derived-symbol var) (car globals)))) 130 ((setq :name $$ :value _) 131 `(setq ,(assoc-or name env-var 132 (assoc-or-push name (derived-symbol name) (car globals))) 133 ,(squash-lisp-2 value env-var env-fun globals))) 134 (_ 135 (error "squash-lisp-2: Assertion failed ! This should not be here : ~a" expr)))) 136 137 ;; TODO : test uniraire 138 ;; (squash-lisp-2 '(let ((x (quote 123))) (let* ((x (quote 1)) (y (get-var x))) (funcall (function +) (get-var x) (get-var y) (quote 1))))) 139 140 141 (defvar *ll* '(a b &optional u &rest c &key ((:foo bar)) :quux (:baz 'glop) &aux (x 1) (y (+ x 2)))) 142 143 ;; TODO : faire cette transformation dans squash-lisp-1 144 ;; TODO : faire la transformation des let/let*/flet/labels en super-let dans squash-lisp-1 145 ;; TODO : raison : transformer les appels de fonction en funcall, etc. 146 147 148 ;; nil à la fin 149 150 (slice-up-lambda-list '(a b &optional (u 3 v) &rest c &key ((:foo bar)) :quux (:baz 'glop) &allow-other-keys &aux (x 1) (y (+ x 2)))) 151 152 (let (a b u v c foo quux baz x y) 153 (set a (car ,whole-sym)) 154 (use a) 155 (progn (setq ,whole-sym (cdr ,whole-sym))) 156 (set b (car ,whole-sym)) 157 (use b) 158 (progn (setq ,whole-sym (cdr ,whole-sym))) 159 (set u (if ,whole-sym (car whole-sym)) ...) 160 (set v (if ,whole-sym t nil)) 161 (use u) 162 (use v) 163 (progn (setq ,whole-sym (cdr ,whole-sym)))) 164 165 ((FIXED A B) (OPTIONAL (U NIL NIL)) (REST C) (REST2) 166 (KEY (FOO BAR NIL NIL) (QUUX QUUX NIL NIL) (BAZ BAZ 'GLOP NIL)) (OTHER) 167 (AUX (X 1) (Y (+ X 2))) (REJECT)) 168 169 (provide 'squash-lisp-2)