eval.lisp 6.82 KB
Newer Older
1 2
;;;;------------------------------------------------------------------
;;;; 
3
;;;;    Copyright (C) 2000-2005,
4
;;;;    Department of Computer Science, University of Tromso, Norway
5 6 7 8 9 10 11
;;;; 
;;;; Filename:      eval.lisp
;;;; Description:   
;;;; Author:        Frode Vatvedt Fjeld <frodef@acm.org>
;;;; Created at:    Thu Nov  2 17:45:05 2000
;;;; Distribution:  See the accompanying file COPYING.
;;;;                
12
;;;; $Id: eval.lisp,v 1.12 2007/03/11 21:18:40 ffjeld Exp $
13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58
;;;;                
;;;;------------------------------------------------------------------

(in-package movitz)

(defun in-package-form-p (form)
  (and (consp form)
       (string= '#:in-package (car form))))

(defun require-form-p (form)
  (and (consp form)
       (string= '#:require (car form))))

(defun provide-form-p (form)
  (and (consp form)
       (string= '#:provide (car form))))

(defun movitz-module-path (require-form)
  "Given a require form, return the path of the file that is expected ~
   to provide that module."
  (let ((module (second require-form)))
    (concatenate 'string
      "losp/"
      (or (third require-form)
	  (concatenate 'string
	    (string-downcase (symbol-name module))
	    ".lisp")))))

(defun movitzify-package-name (name)
  (let ((name (string name)))
    (if (member name '("cl" "common-lisp" "mop")
		:test #'string-equal)
	(concatenate 'string (string '#:muerte.) name)
      name)))

(defmacro with-retries-until-true ((name format-control &rest format-arguments) &body body)
  `(do () (nil)
     (with-simple-restart (,name ,format-control ,@format-arguments)
       (return (progn ,@body)))))

(defun quote-form-p (x)
  (and (consp x)
       (or (eq 'cl:quote (first x))
	   (eq 'muerte.cl::quote (first x)))
       t))

59 60 61 62 63 64 65 66 67 68
(defun movitz-constantp (form &optional (env nil))
  (typecase form
    (keyword t)
    (symbol
     (let ((form (translate-program form :cl :muerte.cl)))
       (or (movitz-env-get form 'constantp nil env)
	   (typep (movitz-binding form env) 'constant-object-binding))))
    (cons
     (let* ((compiler-macro-function (movitz-compiler-macro-function (car form) env))
	    (compiler-macro-expansion (and compiler-macro-function
69 70 71 72 73
					   (handler-case
					       (funcall *movitz-macroexpand-hook*
							compiler-macro-function
							form env)
					     (error () form)))))
74 75 76 77 78
       (or (let ((form (translate-program form :cl :muerte.cl)))
	     (case (car form)
	       ((muerte.cl:quote) t)
	       ((muerte.cl:not)
		(movitz-constantp (second form)))
79
	       ((muerte.cl:+ muerte.cl:- muerte.cl:*)
80 81
		(every (lambda (sub-form)
			 (movitz-constantp sub-form env))
82 83 84 85 86 87 88 89
		       (cdr form)))
	       ((muerte.cl:coerce)
		(and (= 3 (length form))
		     (every (lambda (sub-form)
			      (movitz-constantp sub-form env))
			    (cdr form))
		     (not (member (movitz-eval (third form) env)
				  '(muerte.cl:function)))))))
90 91 92 93 94 95 96 97 98 99 100 101 102
	   (and compiler-macro-function
		(not (movitz-env-get (car form) 'notinline nil env))
		(not (eq form compiler-macro-expansion))
		(movitz-constantp compiler-macro-expansion env)))))
    (t t)))				; anything else is self-evaluating.


;;;(defun isconst (x)
;;;  (or (integerp x)
;;;      (stringp x)
;;;      (eq t x)
;;;      (eq nil x)
;;;      (quote-form-p x)))
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122

(defun eval-form (&rest args)
  (apply 'movitz-eval args))

(defun movitz-eval (form &optional env top-level-p)
  "3.1.2.1 Form Evaluation"
  (let ((form (translate-program form :cl :muerte.cl)))
    (typecase form
      (symbol (eval-symbol form env top-level-p))
      (cons   (eval-cons form env top-level-p))
      (t      (eval-self-evaluating form env top-level-p)))))

(defun eval-form-or-error (form env error-value)
  (handler-case (eval-form form env)
    (error () error-value)))

(defun eval-symbol (form env top-level-p)
  "3.1.2.1.1 Symbols as Forms"
  (declare (ignore top-level-p))
  (cond
123 124
   ((keywordp form)
    (eval-self-evaluating form env top-level-p))
125
   ((typep (movitz-binding form env) 'constant-object-binding)
126 127
    (translate-program (movitz-print (constant-object (movitz-binding form env)))
		       :cl :muerte.cl))
128 129 130 131 132 133 134 135 136 137 138 139 140
   ((movitz-constantp form env)
    (symbol-value form))
;;;   ((movitz-lexical-binding form env)
;;;    (eval-lexical-variable form env top-level-p))
   (t (error "Don't know how to eval symbol-form ~S" form))))

(defun eval-self-evaluating (form env top-level-p)
  "3.1.2.1.3 Self-Evaluating Objects"
  (declare (ignore env top-level-p))
  form)

(defun eval-cons (form env top-level-p)
  "3.1.2.1.2 Conses as Forms"
141 142 143 144 145 146
  (let* ((operator (car form))
	 (compiler-macro-function (movitz-compiler-macro-function operator env))
	 (compiler-macro-expansion (and compiler-macro-function
					(funcall *movitz-macroexpand-hook*
						 compiler-macro-function
						 form env))))
147
    (cond
148 149 150 151 152 153 154 155 156 157 158
;;;     ((movitz-constantp form env)
;;;      (eval-constant-compound form env top-level-p))
     ((member operator '(cl:quote muerte.cl::quote))
      (eval-self-evaluating (second form) env top-level-p))
     ((member operator '(muerte.cl::not))
      (not (eval-form (second form) env nil)))
     ((member operator '(muerte.cl:+ muerte.cl:- muerte.cl:*))
      (apply (translate-program (car form) :muerte.cl :cl)
	     (mapcar (lambda (sub-form)
		       (movitz-eval sub-form env nil))
		     (cdr form))))
159 160 161 162
     ((member operator '(muerte.cl:coerce muerte.cl:make-hash-table))
      (apply (translate-program operator :muerte.cl :cl)
	     (mapcar (lambda (arg)
                       (translate-program (movitz-eval arg env nil) :muerte.cl :cl))
163 164 165 166 167
		     (cdr form))))
     ((and compiler-macro-function
	   (not (movitz-env-get (car form) 'notinline nil env))
	   (not (eq form compiler-macro-expansion)))
      (movitz-eval compiler-macro-expansion env top-level-p))
168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
;;;     ((lambda-form-p form)
;;;      (eval-lambda-form form env top-level-p))
;;;     ((symbolp operator)
;;;      (cond
;;;       ((movitz-special-operator-p operator)
;;;	(eval-special-operator form env top-level-p))
;;;       ((movitz-macro-function operator env)
;;;	(eval-macro-form form env top-level-p))
;;;       (t (eval-apply-symbol form env top-level-p))))
     (t (case (car form)
	  (muerte.cl::function
	   (if (symbolp (second form))
	       (movitz-env-symbol-function (second form) env)
	     (error "Don't know how to eval function form ~A." form)))
	  (t (error "Don't know how to eval compound form ~A" form)))))))

(defun eval-constant-compound (form env top-level-p)
  (case (car form)
   ((cl:quote muerte.cl::quote)
    (eval-self-evaluating (second form) env top-level-p))
   (muerte.cl::not
    (not (eval-form (second form) env nil)))
190 191 192 193 194
   ((muerte.cl:+ muerte.cl:- muerte.cl:*)
    (apply (translate-program (car form) :muerte.cl :cl)
	   (mapcar (lambda (sub-form)
		     (movitz-eval sub-form env nil))
		   (cdr form))))
195 196 197 198
   ((muerte.cl:coerce)
    (apply #'coerce
	   (mapcar (lambda (arg) (movitz-eval arg env nil))
		   (cdr form))))
199
   (t (error "Don't know how to compile constant compound form ~A" form))))