;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   This file is part of Opensourced MCL.
;;;
;;;   Opensourced MCL is free software; you can redistribute it and/or
;;;   modify it under the terms of the GNU Lesser General Public
;;;   License as published by the Free Software Foundation; either
;;;   version 2.1 of the License, or (at your option) any later version.
;;;
;;;   Opensourced MCL is distributed in the hope that it will be useful,
;;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;   Lesser General Public License for more details.
;;;
;;;   You should have received a copy of the GNU Lesser General Public
;;;   License along with this library; if not, write to the Free Software
;;;   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
;;;


(eval-when (:compile-toplevel)
  (require 'nxenv)
  (require 'numbers)
  (require 'sequences)
  (require 'optimizers))

(eval-when (:load-toplevel :execute :compile-toplevel)
  (require 'numbers) ; just calls 'logcount' and 'integer-length'
  (require 'sort)    ; just calls '%sort-list-no-keys'
  (require 'hash))

(%include "ccl:compiler;nx-basic.lisp")

(eval-when (:load-toplevel :execute)
  (require "DEFSTRUCT"))

(defparameter *nx-start* (cons nil nil))


(defvar *host-backend*)
(defvar *target-backend*)

(defun find-backend (name)
  (find name *known-backends* :key #'backend-name))

(eval-when (:load-toplevel :execute :compile-toplevel)
  (require "DLL-NODE")
  #+ppc-target
  (require "PPC-ARCH")
  (require "VREG")
  #+ppc-target
  (require "PPC-ASM")
  (require "VINSN")
  (require "REG")
  (require "SUBPRIMS")
  #+ppc-target
  (require "PPC-LAP")
)
(%include "ccl:compiler;nx0.lisp")
(%include "ccl:compiler;nx1.lisp")

; put this in nx-basic too
;(defvar *lisp-compiler-version* 666 "I lost count.")

; At some point, COMPILE refused to compile things that were defined
; in a non-null lexical environment (or so I remember.)   That seems
; to have been broken when the change of 10/11/93 was made.
; It makes no sense to talk about compiling something that was defined
; in a lexical environment in which there are symbol or function bindings
; present;  I'd thought that the old code checked for this, though it
; may well have botched it.
(defun compile (spec &optional def &aux (macro-p nil))
  (unless def
    (setq def (fboundp spec))
    (when (and (symbolp spec) (not (lfunp def)))
      (setq def (setq macro-p (macro-function spec)))))
  (when (typep def 'interpreted-function)
    (let ((lambda (function-lambda-expression def)))
      (when lambda (setq def lambda))))
  (unless def
    (nx-error "Can't find compilable definition for ~S." spec))
  (multiple-value-bind (lfun warnings)
                       (if (functionp def)
                         def
                         (compile-named-function def spec nil nil *save-definitions* *save-local-symbols*))
    (let ((harsh nil) (some nil) (init t))
      (dolist (w warnings)
        (multiple-value-setq (harsh some) (signal-compiler-warning w init nil harsh some))
        (setq init nil))
      (values
       (if spec
         (progn
           (if macro-p
             (setf (macro-function spec) lfun)
             (setf (fdefinition spec) lfun))
           spec)
         lfun)
       some
       harsh))))

(defparameter *default-compiler-policy* (new-compiler-policy))

(defun current-compiler-policy () *default-compiler-policy*)

(defun set-current-compiler-policy (&optional new-policy)
  (setq *default-compiler-policy* 
        (if new-policy (require-type new-policy 'compiler-policy) (new-compiler-policy))))

(defun compile-user-function (def name &optional env)
  (multiple-value-bind (lfun warnings)
                       (compile-named-function def name nil
                                               env
                                               *save-definitions*
                                               *save-local-symbols*)
    (signal-or-defer-warnings warnings env)
    lfun))

(defun signal-or-defer-warnings (warnings env)
  (let* ((defenv (definition-environment env))
         (init t)
         (defer (and defenv (cdr (defenv.type defenv)) *outstanding-deferred-warnings*)))
    (dolist (w warnings)
      (if (and defer (typep w 'undefined-function-reference))
        (push w (deferred-warnings.warnings defer))
        (progn
          (signal-compiler-warning w init nil nil nil)
          (setq init nil))))))

(defparameter *load-time-eval-token* nil)




(eval-when (:compile-toplevel)
  (declaim (ftype (function (&rest ignore) t)  ppc-compile)))

(defun  compile-named-function
  (def &optional name lfun-maker env keep-lambda keep-symbols policy *load-time-eval-token* target)
  (setq 
   def
   (let ((env (new-lexical-environment env)))
     (setf (lexenv.variables env) 'barrier)
       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
              (afunc (nx1-compile-lambda 
                      name 
                      def 
                      (make-afunc) 
                      nil 
                      env 
                      (or policy *default-compiler-policy*)
                      *load-time-eval-token*)))
         (if (afunc-lfun afunc)
           afunc
           (funcall (backend-p2-compile *target-backend*)
            afunc
            ; will also bind *nx-lexical-environment*
            (or lfun-maker t)
            (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
            keep-symbols)))))
  (values (afunc-lfun def) (afunc-warnings def)))


  




(defparameter *compiler-whining-conditions*
  '((:undefined-function . undefined-function-reference)
    (:global-mismatch . invalid-arguments-global)
    (:lexical-mismatch . invalid-arguments)
    (:environment-mismatch . invalid-arguments)
    (:unused . style-warning)))







#+ppc-target
(require "PPC2")

(defparameter *nx-end* (cons nil nil))
(provide 'nx)

