~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

1
2
3
4
5
6
7
8
9
10
11
12
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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
(make-package "C")
(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"))
(make-package "JAPI-PRIMITIVES" :use '("LISP"))
(make-package "TK-PRIMITIVES" :use '("LISP"))

(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).

;FIXME this preliminary definition is needed for bootstraping, and is overwritten later
(defun abs (z)
  (cond ((complexp z)
	 ;; Compute (sqrt (+ (* x x) (* y y))) carefully to prevent
	 ;; overflow!
	 (let* ((x (abs (realpart z)))
		(y (abs (imagpart z))))
	   (if (< x y)
	       (rotatef x y))
	   (if (zerop x)
	       x
	     (let ((r (/  y x)))
	       (* x (sqrt (+ 1 (* r r))))))))
	((minusp z) (- z))
	(z)))


(progn 

  (system:init-system) 
  (gbc t)

  (in-package "USER")

 (or lisp::*link-array*
     (setq lisp::*link-array*
	   (make-array (ash 1 11)  :element-type 'character :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")))
	(gtk (append x (list "gcl-tk"))))
   (dolist (d (list lsp cmpnew))
       (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))
 
 (defvar si::*lib-directory* (namestring (make-pathname :directory (list :parent))))
 
 (terpri)
 (setq si:*inhibit-macro-special* t)
 (gbc t) (system:reset-gbc-count)
 
 (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)
 
 (unintern 'system)
 (unintern 'lisp)
 (unintern 'compiler)
 (unintern 'user)
 (when (fboundp 'si::init-cmp-anon) (fmakunbound 'si::init-cmp-anon))
 
 (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)