(make-package "COMPILER" :use '("LISP"))
(make-package "SLOOP" :use '("LISP"))
(make-package "SERROR" :use '("LISP" "SLOOP"))
(make-package "ANSI-LOOP" :use '("LISP"))
(make-package "DEFPACKAGE" :use '("LISP"))
(make-package "TK" :use '("LISP" "SLOOP"))

@LI-PCL-PACKAGE@

(in-package :pcl)
(defvar *the-pcl-package* (find-package :pcl))
(defun load-truename (&optional (errorp nil))
  (flet () si:*load-pathname* nil))

@LI-CLCS-PACKAGE@

(rename-package 'user 'common-lisp-user '(cl-user user))

(in-package "SYSTEM")

(defvar *command-args* nil)
 ;; if ANY header or license information is printed by the
 ;; program, then the following License and Enhancement notice
 ;; must be printed (see License).
(progn 

 (system:init-system) 
 (gbc t)

 (in-package "USER")

 (or lisp::*link-array*
     (setq lisp::*link-array*
	   (make-array (ash 1 11)  :element-type 'string-char :fill-pointer 0)))
 (si::use-fast-links t)

 (let* ((x (append (pathname-directory si::*system-directory*) (list :parent)))
	(lsp (append x (list "lsp")))
	(cmpnew (append x (list "cmpnew")))
	(h (append x (list "h")))
	(pcl (append x (list "pcl")))
	(clcs (append x (list "clcs")))
	(gtk (append x (list "gcl-tk"))))
   (dolist (d (list lsp cmpnew pcl clcs))
       (load (make-pathname :name "sys-proclaim" :type "lisp" :directory d)))
   (load (make-pathname :name "tk-package" :type "lsp" :directory gtk))
;   (load (make-pathname :name "gcl_cmpmain" :type "lsp" :directory cmpnew))
   (load (make-pathname :name "gcl_lfun_list" :type "lsp" :directory cmpnew))
   (load (make-pathname :name "gcl_cmpopt" :type "lsp" :directory cmpnew))
   (load (make-pathname :name "gcl_auto_new" :type "lsp" :directory lsp))

   (gbc t)

   (setq compiler::*cmpinclude* "\"cmpinclude.h\"") 
 
   (when compiler::*cmpinclude-string*
     (with-open-file (st (make-pathname :directory h :name "cmpinclude" :type "h"))
		     (let
			 ((tem (make-array (file-length st) :element-type 'standard-char
					   :static t)))
		       (if (si::fread tem 0 (length tem) st)
			   (setq compiler::*cmpinclude-string* tem))))))
 
 (setf (symbol-function 'si:clear-compiler-properties)
       (symbol-function 'compiler::compiler-clear-compiler-properties))
 (setq system::*old-top-level* (symbol-function 'system:top-level))
 
 (defvar si::*lib-directory* (namestring (make-pathname :directory (list :parent))))
 
 (defun system::gcl-top-level (&aux tem)
   (si::set-up-top-level)
   
   (if (si::get-command-arg "-compile")
       (let (;(system::*quit-tag* (cons nil nil))
		;(system::*quit-tags* nil) (system::*break-level* '())
		;(system::*break-env* nil) (system::*ihs-base* 1)
		;(system::*ihs-top* 1) (system::*current-ihs* 1)
	     (*break-enable* nil) result)
	 (setq result
	       (system:error-set
		'(progn
		   (compile-file
		    (si::get-command-arg "-compile")
		    :output-file 
		    (or (si::get-command-arg "-o")
			(si::get-command-arg "-compile"))
		    :o-file
		    (cond ((equalp
			    (si::get-command-arg "-o-file")
			    "nil") nil)
			  ((si::get-command-arg "-o-file" t))
			  (t t))
		    :c-file (si::get-command-arg "-c-file" t)
		    :h-file (si::get-command-arg "-h-file" t)
		    :data-file (si::get-command-arg "-data-file" t)
		    :system-p (si::get-command-arg "-system-p" t)))))
	 (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
   (cond ((si::get-command-arg "-batch")
	  (setq si::*top-level-hook* 'bye))
	 ((si::get-command-arg "-f"))
	 (t (format t si::*system-banner*)
	    (format t "Temporary directory for compiler files set to ~a~%" *tmp-dir*)))
   (setq si::*ihs-top* 1)
   (in-package 'system::user) (incf system::*ihs-top* 2)
   (funcall system::*old-top-level*))
 
 (terpri)
 (setq si:*inhibit-macro-special* t)
 (gbc t) (system:reset-gbc-count)
 
 (defun system:top-level nil (system::gcl-top-level))
 
 (setq compiler::*default-c-file* nil)
 (setq compiler::*default-h-file* nil)
 (setq compiler::*default-data-file* nil)
 (setq compiler::*default-system-p* nil)
 (setq compiler::*keep-gaz* nil)
 
 
 
 (setq clcs_shadow
       '(CONDITIONS::BREAK
	 CONDITIONS::ERROR
	 CONDITIONS::CERROR
	 CONDITIONS::WARN
	 CONDITIONS::CHECK-TYPE
	 CONDITIONS::ASSERT
	 CONDITIONS::ETYPECASE
	 CONDITIONS::CTYPECASE
	 CONDITIONS::ECASE
	 CONDITIONS::CCASE ))
 
 (setq lisp_unexport
       '(LISP::LAMBDA-BLOCK-CLOSURE
	 LISP::BYE
	 LISP::QUIT
	 LISP::EXIT
	 LISP::IEEE-FLOATING-POINT
	 LISP::DEFENTRY
	 LISP::VOID
	 LISP::ALLOCATE-CONTIGUOUS-PAGES
	 LISP::UNSIGNED-SHORT
	 LISP::DOUBLE
	 LISP::BY
	 LISP::GBC
	 LISP::DEFCFUN
	 LISP::SAVE
	 LISP::MAXIMUM-CONTIGUOUS-PAGES
	 LISP::SPICE
	 LISP::DEFLA
	 LISP::ALLOCATED-PAGES
	 LISP::SUN
	 LISP::INT
	 LISP::USE-FAST-LINKS
	 LISP::CFUN
	 LISP::UNSIGNED-CHAR
	 LISP::HELP
	 LISP::HELP*
	 LISP::MACRO
	 LISP::*BREAK-ENABLE*
	 LISP::CLINES
	 LISP::LAMBDA-CLOSURE
	 LISP::OBJECT
	 LISP::FAT-STRING
	 LISP::SIGNED-SHORT
	 LISP::MC68020
	 LISP::LAMBDA-BLOCK
	 LISP::TAG
	 LISP::PROCLAMATION
	 LISP::ALLOCATED-CONTIGUOUS-PAGES
	 LISP::*EVAL-WHEN-COMPILE*
	 LISP::SIGNED-CHAR
	 LISP::*IGNORE-MAXIMUM-PAGES*
	 LISP::*LINK-ARRAY*
	 LISP::KCL
	 LISP::BSD
	 LISP::ALLOCATE-RELOCATABLE-PAGES
	 LISP::ALLOCATE
	 LISP::UNIX
	 LISP::MAXIMUM-ALLOCATABLE-PAGES
	 LISP::ALLOCATED-RELOCATABLE-PAGES
	 LISP::SYSTEM
	 LISP::KYOTO
	 LISP::CCLOSURE))
 
;anything in "SYSTEM" which should go in "COMMON-LISP"
;can be added to shadow-system
 (setf shadow-system '(system::copy-structure))
 
 (do-external-symbols (s "SYSTEM")
		      (when (member s shadow-system)
			(shadowing-import (list s) "COMMON-LISP")
			(shadowing-import (list s) "USER")))
 
 
 (do-external-symbols (s "LISP")
		      (if (not(member s lisp_unexport))
			  (progn 
			    (import (list s) "COMMON-LISP")
			    (import (list s) "USER")) ))
 
 (do-external-symbols (s "PCL")
		      (import (list s) "COMMON-LISP")
		      (import (list s) "USER"))
 
;(shadowing-import (list 'pcl::classp) "SYSTEM")
 (setf (symbol-function 'si::classp) (symbol-function 'pcl::classp))
 (setf (symbol-function 'si::class-of) (symbol-function 'pcl::class-of))
 (setf (symbol-function 'si::class-precedence-list) 
       (symbol-function 'pcl::class-precedence-list))
 (setf (symbol-function 'si::find-class) 
       (symbol-function 'pcl::find-class))
 
 (do-external-symbols (s "CONDITIONS")
		      (if (member s clcs_shadow)
			  (progn 
			    (shadowing-import (list s) "COMMON-LISP")
			    (shadowing-import (list s) "USER"))
			(progn
			  (import (list s) "COMMON-LISP")
			  (import (list s) "USER"))))
 
 t)

(progn

  (dolist (s '(*compile-file-pathname* *compile-file-truename*
				       *compile-print* *compile-verbose* *load-pathname* *load-print*
				       *load-truename* *print-lines* *print-miser-width*
				       *print-pprint-dispatch* *print-right-margin* *read-eval*
				       lisp::arithmetic-error broadcast-stream-streams cell-error
				       cell-error-name compile compile-file compiler-macro
				       compiler-macro-function complement concatenated-stream-streams
				       condition control-error copy-pprint-dispatch copy-structure count
				       debug define-compiler-macro define-setf-expander define-symbol-macro
				       defpackage describe describe-object division-by-zero dynamic-extent
				       echo-stream-input-stream echo-stream-output-stream
				       ensure-directories-exist fdefinition file-string-length formatter
				       function-lambda-expression get-setf-expansion hash-table-rehash-size
				       hash-table-rehash-threshold ignorable interactive-stream-p
				       load-logical-pathname-translations load-time-value
				       logical-pathname-translations make-load-form
				       make-load-form-saving-slots make-method open-stream-p pathname-match-p
				       pprint-dispatch pprint-exit-if-list-exhausted pprint-fill
				       pprint-indent pprint-linear pprint-logical-block pprint-newline
				       pprint-pop pprint-tab pprint-tabular print-not-readable-object
				       print-unreadable-object readtable-case row-major-aref
				       set-pprint-dispatch simple-condition-format-control
				       stream-external-format synonym-stream-symbol
				       translate-logical-pathname translate-pathname
				       two-way-stream-input-stream two-way-stream-output-stream
				       unbound-slot-instance 
				       upgraded-complex-part-type wild-pathname-p with-compilation-unit
				       with-condition-restarts with-package-iterator with-standard-io-syntax
				        ))
    (shadowing-import (list s) "COMMON-LISP"))
  
  (use-package "ANSI-LOOP" "COMMON-LISP")
  (use-package "ANSI-LOOP" "USER")
  
  (do-symbols (s "COMMON-LISP")
	      (export (list s) "COMMON-LISP"))
  
  (rename-package 'common-lisp 'common-lisp '(cl))
  
  (unintern 'system)
  (unintern 'lisp)
  (unintern 'compiler)
  (unintern 'user)
  (fmakunbound 'si::init-cmp-anon)
  
  (makunbound 'clcs_shadow)
  (makunbound 'lisp_unexport)
  (makunbound 'shadow-system)
  (unintern 'clcs_shadow)
  (unintern 'lisp_unexport)
  (unintern 'int)
  (unintern 'shadow-system)
  
  (push :common-lisp *features*)
  (push :ansi-cl *features*)
  
  (eval-when (load)
	     (if (fboundp 'get-system-time-zone)
		 (setf system:*default-time-zone* (get-system-time-zone))
	       (setf system:*default-time-zone* 6)))
  
  (if (fboundp 'si::user-init) (si::user-init))
  (si::set-up-top-level)
  
  (setq si::*gcl-extra-version* @LI-EXTVERS@
	si::*gcl-minor-version* @LI-MINVERS@ 
	si::*gcl-major-version* @LI-MAJVERS@)
  (setq compiler::*cc* @LI-CC@)
  (setq compiler::*ld* @LI-LD@)
  (setq compiler::*ld-libs* @LI-LD-LIBS@)
  (setq compiler::*opt-three* @LI-OPT-THREE@)
  (setq compiler::*opt-two* @LI-OPT-TWO@)
  (setq compiler::*init-lsp* @LI-INIT-LSP@)

  (defvar si::*system-banner* (si::default-system-banner))

  (in-package 'user)
  (import 'si::info)

  t)
