← Back to branch summary

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

« back to all changes in this revision

Viewing changes to unixport/init_pre_gcl.lsp.in

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
unixport/init_pre_gcl.lsp.in
 
1
(make-package "COMPILER" :use '("LISP"))
 
2
(make-package "SLOOP" :use '("LISP"))
 
3
(make-package "SERROR" :use '("LISP" "SLOOP"))
 
4
(make-package "ANSI-LOOP" :use '("LISP"))
 
5
(make-package "DEFPACKAGE" :use '("LISP"))
 
6
(make-package "TK" :use '("LISP" "SLOOP"))
 
7
 
 
8
(in-package "SYSTEM")
 
9
 
 
10
(defvar *command-args* nil)
 
11
 ;; if ANY header or license information is printed by the
 
12
 ;; program, then the following License and Enhancement notice
 
13
 ;; must be printed (see License).
 
14
 
 
15
(progn 
 
16
 
 
17
  (system:init-system) 
 
18
  (gbc t)
 
19
 
 
20
  (in-package "USER")
 
21
 
 
22
 (or lisp::*link-array*
 
23
     (setq lisp::*link-array*
 
24
           (make-array (ash 1 11)  :element-type 'string-char :fill-pointer 0)))
 
25
 (si::use-fast-links t)
 
26
 
 
27
 (let* ((x (append (pathname-directory si::*system-directory*) (list :parent)))
 
28
        (lsp (append x (list "lsp")))
 
29
        (cmpnew (append x (list "cmpnew")))
 
30
        (h (append x (list "h")))
 
31
        (gtk (append x (list "gcl-tk"))))
 
32
   (dolist (d (list lsp cmpnew))
 
33
       (load (make-pathname :name "sys-proclaim" :type "lisp" :directory d)))
 
34
   (load (make-pathname :name "tk-package" :type "lsp" :directory gtk))
 
35
   (load (make-pathname :name "gcl_cmpmain" :type "lsp" :directory cmpnew))
 
36
   (load (make-pathname :name "gcl_lfun_list" :type "lsp" :directory cmpnew))
 
37
   (load (make-pathname :name "gcl_cmpopt" :type "lsp" :directory cmpnew))
 
38
   (load (make-pathname :name "gcl_auto_new" :type "lsp" :directory lsp))
 
39
 
 
40
   (gbc t)
 
41
 
 
42
   (setq compiler::*cmpinclude* "\"cmpinclude.h\"") 
 
43
 
 
44
   (when compiler::*cmpinclude-string*
 
45
     (with-open-file (st (make-pathname :directory h :name "cmpinclude" :type "h"))
 
46
                     (let
 
47
                         ((tem (make-array (file-length st) :element-type 'standard-char
 
48
                                           :static t)))
 
49
                       (if (si::fread tem 0 (length tem) st)
 
50
                           (setq compiler::*cmpinclude-string* tem))))))
 
51
 
 
52
 (setf (symbol-function 'si:clear-compiler-properties)
 
53
       (symbol-function 'compiler::compiler-clear-compiler-properties))
 
54
 (setq system::*old-top-level* (symbol-function 'system:top-level))
 
55
 
 
56
 (defvar si::*lib-directory* (namestring (make-pathname :directory (list :parent))))
 
57
 
 
58
 (defun system::gcl-top-level (&aux tem)
 
59
   (si::set-up-top-level)
 
60
   
 
61
   (if (si::get-command-arg "-compile")
 
62
       (let (;(system::*quit-tag* (cons nil nil))
 
63
                                        ;(system::*quit-tags* nil) (system::*break-level* '())
 
64
                                        ;(system::*break-env* nil) (system::*ihs-base* 1)
 
65
                                        ;(system::*ihs-top* 1) (system::*current-ihs* 1)
 
66
             (*break-enable* nil) result)
 
67
         (setq result
 
68
               (system:error-set
 
69
                '(progn
 
70
                   (compile-file
 
71
                    (si::get-command-arg "-compile")
 
72
                    :output-file 
 
73
                    (or (si::get-command-arg "-o")
 
74
                        (si::get-command-arg "-compile"))
 
75
                    :o-file
 
76
                    (cond ((equalp
 
77
                            (si::get-command-arg "-o-file")
 
78
                            "nil") nil)
 
79
                          ((si::get-command-arg "-o-file" t))
 
80
                          (t t))
 
81
                    :c-file (si::get-command-arg "-c-file" t)
 
82
                    :h-file (si::get-command-arg "-h-file" t)
 
83
                    :data-file (si::get-command-arg "-data-file" t)
 
84
                    :system-p (si::get-command-arg "-system-p" t)))))
 
85
         (bye (if (or compiler::*error-p* (equal result '(nil))) 1 0))))
 
86
   (cond ((si::get-command-arg "-batch")
 
87
          (setq si::*top-level-hook* 'bye))
 
88
         ((si::get-command-arg "-f"))
 
89
         (t (format t si::*system-banner*)))
 
90
   (setq si::*ihs-top* 1)
 
91
   (in-package 'system::user) (incf system::*ihs-top* 2)
 
92
   (funcall system::*old-top-level*))
 
93
 
 
94
 (terpri)
 
95
 (setq si:*inhibit-macro-special* t)
 
96
 (gbc t) (system:reset-gbc-count)
 
97
 
 
98
 (defun system:top-level nil (system::gcl-top-level))
 
99
 
 
100
 (setq compiler::*default-c-file* nil)
 
101
 (setq compiler::*default-h-file* nil)
 
102
 (setq compiler::*default-data-file* nil)
 
103
 (setq compiler::*default-system-p* nil)
 
104
 (setq compiler::*keep-gaz* nil)
 
105
 
 
106
 (unintern 'system)
 
107
 (unintern 'lisp)
 
108
 (unintern 'compiler)
 
109
 (unintern 'user)
 
110
 (fmakunbound 'si::init-cmp-anon)
 
111
 
 
112
 (eval-when (load)
 
113
            (if (fboundp 'get-system-time-zone)
 
114
                (setf system:*default-time-zone* (get-system-time-zone))
 
115
              (setf system:*default-time-zone* 6)))
 
116
 
 
117
 (if (fboundp 'si::user-init) (si::user-init))
 
118
 (si::set-up-top-level)
 
119
 
 
120
 (setq si::*gcl-extra-version* @LI-EXTVERS@
 
121
       si::*gcl-minor-version* @LI-MINVERS@
 
122
       si::*gcl-major-version* @LI-MAJVERS@)
 
123
 (setq compiler::*cc* @LI-CC@)
 
124
 (setq compiler::*ld* @LI-LD@)
 
125
 (setq compiler::*ld-libs* @LI-LD-LIBS@)
 
126
 (setq compiler::*opt-three* @LI-OPT-THREE@)
 
127
 (setq compiler::*opt-two* @LI-OPT-TWO@)
 
128
 (setq compiler::*init-lsp* @LI-INIT-LSP@)
 
129
 
 
130
 (defvar si::*system-banner* (si::default-system-banner))
 
131
 
 
132
 (in-package 'user)
 
133
 (import 'si::info)
 
134
 
 
135
 t)