www

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs

meval.lisp (9944B)

      1 (require 'match "match")
      2 
      3 (defun env-size (env)
      4   (if (or (equalp env #()) (eq env nil))
      5       0
      6     (+ 1 (env-size (aref env 0)))))
      7 
      8 (defun get-env-num-r (num env counter)
      9   (cond ((or (equalp env #()) (eq env nil))
     10          env)
     11         ((= num counter)
     12          env)
     13         (T
     14          (get-env-num-r num (aref env 0) (- counter 1)))))
     15 
     16 (defun get-env-num (num env)
     17   "Récupère l’environnement correspondant à celui souhaité."
     18   (get-env-num-r num env (- (env-size env) 1)))
     19 
     20 (defun current-env (env)
     21   (let ((env-size (- (env-size env) 1)))
     22     (defun current-env-r (env counter)
     23       (if (= counter env-size)
     24           env
     25         (current-env-r (aref env 0) (+ counter 1))))
     26     (current-env-r env 0)))
     27                           
     28 (defun get-lower-env (env)
     29   "Récupère l’environnement le plus bas"
     30   (if (or (= (array-total-size env) 0)
     31           (eq (aref env 0) nil))
     32       env
     33      (get-lower-env (aref env 0))))
     34 
     35 (defun make-rest-lower-env (lower-env pos values pos-rest)
     36   (cond ((= pos pos-rest)
     37          (setf (aref lower-env pos) values))
     38         (T
     39          (setf (aref lower-env pos) (car values))
     40          (make-rest-lower-env lower-env
     41                               (+ pos 1)
     42                               (cdr values)
     43                               pos-rest))))
     44 
     45 (defun make-rest (env values &optional (pos-rest 1))
     46   "Construit l'environnement en rajoutant tous les valeurs
     47 du &rest dans une cellule de l'env sous forme d'une liste"
     48   (let ((size (- (array-total-size env) 1)))
     49     (make-rest-lower-env env 1 values pos-rest))
     50   env)
     51 
     52 (defun make-env (size list-values env &optional pos-rest)
     53   "Construis l’environnement en appariant les paramètres aux valeurs
     54  correspondantes et signale une exception si paramètres et arguments
     55  ne concordent pas. Si l’environnement passe en paramètre n’est pas vide,
     56  le nouvel environnement y est inclus."
     57   (let ((new-env (copy-all env)))
     58     (cond ((and (not pos-rest)
     59                 (< size (length list-values)))
     60            (error "Too arguments"))
     61           ((> size (length list-values))
     62            (error "Too few arguments"))
     63           (T
     64            (if (= (array-total-size new-env) 0)
     65                (setf new-env (make-array (+ 1 size) :initial-element nil))
     66              (setf (aref (get-lower-env new-env) 0) (make-array (+ 1 size) :initial-element nil)))
     67            (let ((lower-env (get-lower-env new-env)))
     68              (if pos-rest
     69                  (make-rest lower-env
     70                             list-values
     71                             pos-rest)
     72                (loop
     73                 for value in list-values
     74                 for rank = 1 then (+ rank 1)
     75                 do (setf (aref lower-env rank) value)
     76                 )))
     77            new-env))))
     78 
     79 (declaim (ftype function meval)) ;; Récursion mutuelle meval / map-meval + meval-body + meval-args + meval-lambda + msetf
     80 
     81 (defun map-meval (list env)
     82   (mapcar (lambda (x) (meval x env)) list))
     83 
     84 (defun meval-body (list-expr env)
     85   "Évalue en séquence la liste des expressions et
     86 retourne la valeur retournée par la dernière"
     87   (if (endp list-expr)
     88       nil
     89     (if (endp (cdr list-expr))
     90         (meval (car list-expr) env)
     91       (progn
     92         (meval (car list-expr) env)
     93         (meval-body (cdr list-expr) env)))))
     94 
     95 (defun meval-args (list-expr env)
     96   "Évalue en séquence la liste des expressions et
     97 retourne la liste de leurs valeurs"
     98   (if (endp list-expr)
     99       nil
    100     (if (endp (cdr list-expr))
    101         `(,(meval (car list-expr) env))
    102       `(,(meval (car list-expr) env)
    103         ,@(meval-args (cdr list-expr) env)))))
    104 
    105 (defun meval-lambda (lclosure args env)
    106   "Applique une λ-fonction quelconque à des valeurs
    107 d’arguments dans un certain environnement."
    108   (match (:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*) lclosure
    109          (meval lclosure
    110                 (make-env size args env (car rest)))))
    111 
    112 (defun msetf (place val env)
    113   (let ((sub-env (get-env-num (first place) env)))
    114     (if sub-env
    115         (setf (aref sub-env (second place))
    116               (meval val env)))))
    117 
    118 (defun make-empty-list (size)
    119   (if (= size 0)
    120       nil
    121     (cons nil (make-empty-list (- size 1)))))
    122 
    123 (defun meval (expr &optional (env #()))
    124   "Interprète le langage intermédiaire passé en paramètre."
    125   (cond-match expr
    126               ((:nil :const :val . _) expr val)
    127               ((:nil :cvar :num-env (? integerp) :index (? integerp))
    128                (if (= num-env 0)
    129                    (aref (current-env env) index)
    130                  (let ((sub-env (get-env-num num-env env)))
    131                    (if sub-env
    132                        (aref sub-env index)
    133                      (error "The variable unbound : ~w" expr)))))
    134               ((:nil :if :predicat @. :expr1 @. :expr2 @.)
    135                (if (meval predicat env)
    136                    (meval expr1 env)
    137                  (meval expr2 env)))
    138               ((:nil :mcall set-defun :func-name @. :closure _*)
    139                (let ((name (meval func-name env)))
    140                  (setf (get name :defun) closure)
    141                  name))
    142               ((:nil :mcall set-defmacro :macro-name @. :closure _*)
    143                (let ((name (meval macro-name env)))
    144                  (setf (get name :defmacro) closure)
    145                  name))
    146               ((:nil :mcall :func-name (? $$ (get x :defun)) :params _*)
    147                (let ((values (meval-args params env)))
    148                  (meval-lambda (car (get func-name :defun))
    149                                values
    150                                (make-env (length values) values env))))
    151               ((:nil :mcall :macro-name (? $$ (get x :defmacro)) :params _*)
    152                (let ((values (meval-args params env)))
    153                  (meval (lisp2li (meval-lambda (car (get macro-name :defmacro))
    154                                params
    155                                (make-env (length values) values env))
    156                                  env)
    157                         env)))
    158               ((:nil :mcall :lambda (:nil :lclosure (? integerp) (? integerp)? _*) :args _*)
    159                (meval-lambda lambda (meval-args args env) env))
    160               ((:nil :call :func-name _ :body _*)
    161                (apply (symbol-function func-name) (meval-args body env)))
    162               ((:nil :progn :body _*)
    163                (meval-body body env))
    164               ((:nil :lclosure :size (? integerp) :rest (? integerp)? :body _*)
    165                (meval-body `(,body) env))
    166               ((:nil :set-var :place @. :value _)
    167                (msetf place value env))
    168               ((:nil :let :size (? integerp) :affectations (:nil :set-var :places @ :values _)* :body _*)
    169                (meval-body body (make-env size (meval-args values env) env)))
    170               ((:nil :unknown :call (:name $ :params _*) :environ _*)
    171                (lisp2li call environ))
    172               (_*
    173                (error "form special ~S not yet implemented" expr))))
    174 
    175 ;; Test unitaire
    176 (require 'test-unitaire "test-unitaire")
    177 (require 'lisp2li "lisp2li")
    178 (erase-tests meval)
    179 (deftest (meval :const)
    180   (meval (lisp2li 3 ()))
    181   3)
    182 
    183 (deftest (meval quote)
    184   (meval (lisp2li '3 ()))
    185   3)
    186 
    187 (deftest (meval quote)
    188   (meval (lisp2li ''3 ()))
    189   3)
    190 
    191 (deftest (meval quote)
    192   (meval (lisp2li '''3 ()))
    193   ''3)
    194 
    195 (deftest (meval :cvar)
    196   (meval (lisp2li 'x '((x 0 2))) #(() 4 5 6))
    197   5)
    198 
    199 (deftest (meval :cvar)
    200   (meval '(:cvar 1 2) #(#(() 7 8) 4 5 6)) 
    201   5)
    202 
    203 (deftest (meval :call)
    204   (meval '(:call + (:const . 3) (:cvar 0 1)) #(() 4 5 6))
    205   7)
    206 
    207 (deftest (meval :call)
    208   (meval '(:call list (:const . 3) (:const . 2)))
    209   '(3 2))
    210 
    211 (deftest (meval :if)
    212   (meval '(:if (:const . T)
    213                (:const . T)
    214                (:const . nil)))
    215   T)
    216 
    217 (deftest (meval :if)
    218   (meval '(:if (:call eq (:const . 1)
    219                       (:cvar 0 1))
    220                (:const . T)
    221                (:const . nil)) #(() 1 2 3))
    222   T)
    223 
    224 (deftestvar (meval make-env) empty-env #())
    225 (deftest (meval make-env)
    226   (make-env 2 '(1 2) empty-env)
    227   #(() 1 2)
    228   #'equalp)
    229 
    230 (deftestvar (meval make-env) env #(() 1 2))
    231 (deftest (meval make-env)
    232   (make-env 2 '(7 8) env)
    233   #(#(() 7 8) 1 2)
    234   #'equalp)
    235 
    236 (deftestvar (meval make-env make-rest) env #(() nil nil))
    237 (deftest (meval make-env make-rest)
    238   (make-rest env '(1 2 3 4) 2)
    239   #(() 1 (2 3 4))
    240   #'equalp)
    241 
    242 (deftestvar (meval make-env &rest) env #(() 1 2))
    243 (deftest (meval make-env &rest)
    244   (make-env 2 '(7 8 9) env 2)
    245   #(#(() 7 (8 9)) 1 2)
    246   #'equalp)
    247 
    248 (deftest (meval make-env &rest)
    249   (make-env 1 '(nil) env 1)
    250   #(#(() (nil)) 1 2)
    251   #'equalp)
    252 
    253 (deftest (meval meval-body)
    254   (meval-body '((:const . 3)) #())
    255   '3)
    256 
    257 (deftest (meval meval-body)
    258   (meval-body '((:const . 3) (:call cons (:const . 1) (:const . 2))) #())
    259   '(1 . 2))
    260 
    261 (deftest (meval meval-args)
    262   (meval-args '((:const . 3)) #())
    263   '(3))
    264 
    265 (deftest (meval meval-args)
    266   (meval-args '((:const . 3) (:const 1 2 3)) #())
    267   '(3 (1 2 3)))
    268 
    269 (deftest (meval meval-args)
    270   (meval-args '((:cvar 0 1) (:call cons (:cvar 0 3)
    271                                   (:cvar 0 2))) #(() 1 2 3))
    272   '(1 (3 . 2)))
    273 
    274 (deftest (meval meval-lambda)
    275   (meval-lambda '(:lclosure 2 :call cons
    276                             (:cvar 0 1)
    277                             (:cvar 0 2))
    278                 '(1 2) #())
    279   '(1 . 2))
    280 
    281 (deftest (meval :mcall :lclosure)
    282   (meval (lisp2li '((lambda (x y) (cons x y)) 1 2) ()))
    283   '(1 . 2))
    284 
    285 (deftest (meval :mcall :lclosure)
    286   (meval (lisp2li '((lambda (x &rest y) (cons x y)) 1 2 3 4) ()))
    287   '(1 2 3 4))
    288 
    289 (deftestvar (meval :set-var) env #(() 2))
    290 (deftest (meval :set-var)
    291   (progn
    292     (meval (lisp2li '(setf x 42) '((x 0 1))) env)
    293     env)
    294   #(() 42)
    295   ;; Pour une raison totalement inexplicable, ce test fail avec #'equalp sous sbcl
    296   ;; alors que les deux objets sont equalp en dehors du test (si on les met dans deux
    297   ;; variable globale pour tester après). Pour l'instant, cette fonction suffira.
    298   (lambda (x y)
    299     (every #'identity (map 'list (lambda (x y) (or (eq x y) (and (numberp x) (numberp y) (= x y)))) x y))))
    300 
    301 (provide 'meval)