(in-package :ccl)

#+:OPENMCL(defvar *nx1-target-inhibit* '())  ; This is probably not right

(let ( (*WARN-IF-REDEFINE-KERNEL* nil) )
  (defun nx1-combination (form env)
    (destructuring-bind (sym &rest args)
                        form
      (if (symbolp sym)
        (let* ((*nx-sfname* sym) special)
          (if (and (setq special (gethash sym *nx1-alphatizers*))
                   ;(not (nx-lexical-finfo sym env))
                   (not (memq sym *nx1-target-inhibit*))
                   (not (nx-declared-notinline-p sym *nx-lexical-environment*)))
            (funcall special form env) ; pass environment arg ...
            (progn
              (when (memq sym *nx1-target-inhibit*)
                (warn "Wrong platform for call to ~s in ~s ." sym form))
              (nx1-typed-call sym args))))
        (if (lambda-expression-p sym)
          (nx1-lambda-bind (%cadr sym) args (%cddr sym))
          (nx1-combination-hook form env))))))

; Traditional CL behavior
(defun nx1-combination-hook (form env)
  (declare (ignore env))
  (nx-error "~S is not a symbol or lambda expression in the form ~S ."
            (first form) form))

; ((...) ...) ==> (funcall (...) ...)
(defun nx1-combination-hook (form env)
  (nx1-combination (cons 'funcall form) env))


(let ( (*WARN-IF-REDEFINE-KERNEL* nil) )
(defun cheap-eval-in-environment (form env &aux sym)
  (declare (resident))
  (flet ((progn-in-env (body&decls parse-env base-env)
           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
             (while (cdr body)
               (cheap-eval-in-environment (pop body) base-env))
             (cheap-eval-in-environment (car body) base-env))))
    (if form
      (cond ((symbolp form) 
             (multiple-value-bind (expansion win) (macroexpand-1 form env)
               (if win 
                 (cheap-eval-in-environment expansion env) 
                 (let* ((defenv (definition-environment env))
                        (constant (if defenv (assq form (defenv.constants defenv))))
                        (constval (%cdr constant)))
                   (if constant
                     (if (neq (%unbound-marker-8) constval)
                       constval
                       (error "Can't determine value of constant symbol ~s" form))                     
                     (symbol-value form))))))
            ((atom form) form)
            ((eq (setq sym (%car form)) 'quote)
             (verify-arg-count form 1 1)
             (%cadr form))
            ((eq sym 'function)
             (verify-arg-count form 1 1)
             (cond ((symbolp (setq sym (%cadr form)))
                    (%function sym))
                   ((and (consp sym) (eq (%car sym) 'setf) (consp (%cdr sym)) (null (%cddr sym)))
                    (%function (setf-function-name (%cadr sym))))
                   (t (%make-function nil sym env))))
            ((eq sym 'nfunction)
             (verify-arg-count form 2 2)
             (%make-function (%cadr form) (%caddr form) env))
            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
            ((eq sym 'setq)
             (if (not (%ilogbitp 0 (list-length form)))
               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
             (let* ((sym nil)
                    (val nil))
               (while (setq form (%cdr form))
                 (setq sym (require-type (pop form) 'symbol))
                 (multiple-value-bind (expansion expanded)
                                      (macroexpand-1 sym env)
                   (if expanded
                     (setq val (cheap-eval-in-environment `(setf ,expansion ,(%car form)) env))
                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
               val))
            ((eq sym 'eval-when)
             (destructuring-bind (when . body) (%cdr form)
               (when (or (memq 'eval when) (memq :execute when)) (progn-in-env body env env))))
            ((eq sym 'if)
             (destructuring-bind (test true &optional false) (%cdr form)
               (cheap-eval-in-environment (if (cheap-eval-in-environment test env) true false) env)))
            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
            ((eq sym 'symbol-macrolet)
             (progn-in-env (cddr form) env (augment-environment env :symbol-macro (cadr form))))
            ((eq sym 'macrolet)
             (let ((temp-env (augment-environment env
                                                  :macro 
                                                  (mapcar #'(lambda (m)
                                                              (destructuring-bind (name arglist &body body) m
                                                                (list name (enclose (parse-macro name arglist body env)
                                                                                    env))))
                                                          (cadr form)))))
               (progn-in-env (cddr form) temp-env temp-env)))
            ((and (symbolp sym) 
                  (compiler-special-form-p sym)
                  (not (functionp (fboundp sym))))
             (if (eq sym 'unwind-protect)
               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
                 (unwind-protect
                   (cheap-eval-in-environment protected-form env)
                   (progn-in-env cleanup-forms env env)))
               (funcall (%make-function nil `(lambda () (progn ,form)) env))))
            ((and (symbolp sym) (macro-function sym env))
             (if (eq sym 'step)
               (let ((*compile-definitions* nil))
                     (cheap-eval-in-environment (macroexpand-1 form env) env))
               (cheap-eval-in-environment (macroexpand-1 form env) env)))
            ((or (symbolp sym)
                 (and (consp sym) (eq (%car sym) 'lambda)))
             (let ((args nil))
               (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args))
               (apply #'call-check-regs (if (symbolp sym) sym (%make-function nil sym env))
                      (nreverse args))))
            (t (cheap-eval-combination-hook form env))))))
)

; Traditional CL behavior
(defun cheap-eval-combination-hook (form env)
  (declare (ignore env))
  (signal-simple-condition 'simple-program-error
                           "Car of ~S is not a function name or lambda-expression." form))

; ((...) ...) ==> (funcall (...) ...)
(defun cheap-eval-combination-hook (form env)
  (cheap-eval-in-environment (cons 'funcall form) env))