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
117
118
119
120
121
122
123
124
|
;FIXME
(defun make-package (name &key nicknames use)
(si::make-package-int name nicknames use))
(make-package :cstruct :use '(:cl))
(make-package :compiler :use '(:cl :si :cstruct))
(make-package :sloop :use '(:cl))
(make-package :ansi-loop :use'(:cl))
(make-package :defpackage :use '(:cl))
(make-package :tk :use '(:cl :sloop))
(make-package :fpe :use '(:cl))
(make-package :cltl1-compat)
(make-package "libm")
(in-package :system)
(use-package '(:fpe :cstruct :gmp))
(export 'si::(object double cnum system cmp-inline cmp-eval type-propagator c1no-side-effects defcfun clines defentry) :si);FIXME
(setq *features* (cons :raw-image *features*))
(init-system)
(setq *features* (remove :raw-image *features*))
(in-package :si)
(gbc t)
;FIXME
(progn
(do-all-symbols (s)
(when (or (coerce-to-standard-class s) (get s 's-data))
(remprop s 'deftype-definition)
(remprop s 'deftype-form)))
(let* ((p (find-package "PCL"))(x (when p (find-symbol "DO-SATISFIES-DEFTYPE" p))))
(when (and x (fboundp x))
(setf (symbol-function x) (lambda (x y) (declare (ignore x y)) nil)))))
(do-symbols (s)
(when (get s 'proclaimed-function)
(unless (sig s)
(let* ((fun (symbol-function s)))
(c-set-function-plist
fun
(apply 'make-function-plist
(list (mapcar 'cmp-norm-tp (get s 'proclaimed-arg-types))
(cmp-norm-tp (get s 'proclaimed-return-type)))
(or (cdr (c-function-plist fun)) (list nil nil nil 1 s))))));FIXME props
(dolist (l '(proclaimed-function proclaimed-arg-types proclaimed-return-type))
(remprop s l))))
(unless *link-array*
(setq *link-array* (make-array (ash 1 11) :element-type 'character :fill-pointer 0)))
(use-fast-links t)
(let* ((x (append (pathname-directory (getenv "GCL_LSPSYSDIR")) (list :back)))
(lsp (append x (list "lsp")))
(cmpnew (append x (list "cmpnew")))
(h (append x (list "h")))
(xgcl-2 (append x (list "xgcl-2")))
(pcl (append x (list "pcl")))
(clcs (append x (list "clcs")))
(gtk (append x (list "gcl-tk"))))
;; (dolist (d (list lsp cmpnew #+(and xgcl (not pre-gcl)) xgcl-2 #+(or pcl ansi-cl) pcl #+ansi-cl 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_lfun_list" :type "lsp" :directory cmpnew))
(load (make-pathname :name "gcl_cmpopt" :type "lsp" :directory cmpnew))
(let* ((x (merge-pathnames (make-pathname :name "gcl_cmpnopt" :type "lsp") *system-directory*)))
(when (probe-file x) (load x)))
(load (make-pathname :name "gcl_auto_new" :type "lsp" :directory lsp))
(gbc t))
(terpri)
(setq *inhibit-macro-special* t)
(gbc t)
(reset-gbc-count)
(set-up-top-level)
(setq *gcl-extra-version* @LI_EXTVERS@
*gcl-minor-version* @LI_MINVERS@
*gcl-major-version* @LI_MAJVERS@
*gcl-git-tag* @LI_GITTAG@
*gcl-release-date* "@LI_RELEASE@")
(defvar *system-banner* (default-system-banner))
(fmakunbound 'init-cmp-anon)
(when (fboundp 'user-init) (user-init))
(in-package :compiler)
(setq *cc* @LI_CC@
*ld* @LI_LD@
*ld-libs* @LI_LD_LIBS@
*ld-libs* (concatenate 'string "-l" #+ansi-cl "ansi_" "gcl" #+gprof "_gprof" " " *ld-libs*)
*opt-three* @LI_OPT_THREE@
*opt-two* @LI_OPT_TWO@
*init-lsp* @LI_INIT_LSP@
si::*info-paths* (cons "@prefix@/share/info/" si::*info-paths*))
(import 'si::(clines defentry defcfun object void int double quit bye gbc system
commonp *break-on-warnings* make-char char-bits char-font
char-bit set-char-bit string-char-p int-char
char-font-limit char-bits-limit char-control-bit
char-meta-bit char-super-bit char-hyper-bit compiler-let) :cltl1-compat)
(deftype cltl1-compat::string-char nil 'character)
(do-symbols (s :cltl1-compat) (export s :cltl1-compat))
;#-ansi-cl(use-package :cltl1-compat :lisp)
;#-ansi-cl(do-symbols (s :cltl1-compat) (export s :lisp))
#+ansi-cl (use-package :pcl :user)
(import 'si::(clines defentry defcfun object void int double quit bye gbc system
*lib-directory* *system-directory* while) :user)
(let* ((i 4096)(j (si::equal-tail-recursion-check i)))
(unless (<= (ash i -1) j)
(warn "equal is not tail recursive ~s ~s" i j)))
(format t "~s heap words available~%" (multiple-value-bind (a b c d) (si::heap-report) (/ (- d c) (/ a 8))))
(progn (setq si::*code-block-reserve* (make-array 30000000 :element-type 'character :static t :initial-element (code-char 0))) nil)
(setq *optimize-maximum-pages* t)
|
