1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright 1994-2009 Clozure Associates |
---|
4 | ;;; |
---|
5 | ;;; Licensed under the Apache License, Version 2.0 (the "License"); |
---|
6 | ;;; you may not use this file except in compliance with the License. |
---|
7 | ;;; You may obtain a copy of the License at |
---|
8 | ;;; |
---|
9 | ;;; http://www.apache.org/licenses/LICENSE-2.0 |
---|
10 | ;;; |
---|
11 | ;;; Unless required by applicable law or agreed to in writing, software |
---|
12 | ;;; distributed under the License is distributed on an "AS IS" BASIS, |
---|
13 | ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. |
---|
14 | ;;; See the License for the specific language governing permissions and |
---|
15 | ;;; limitations under the License. |
---|
16 | |
---|
17 | ;; L1-boot.lisp |
---|
18 | |
---|
19 | (in-package "CCL") |
---|
20 | |
---|
21 | (defparameter *gensym-counter* 0 "counter for generating unique GENSYM symbols") |
---|
22 | |
---|
23 | (defparameter *inhibit-greeting* nil) |
---|
24 | |
---|
25 | ;the below 3 variables are expected to be redefined in the user's init file |
---|
26 | (defparameter *short-site-name* nil) |
---|
27 | (defparameter *long-site-name* nil) |
---|
28 | #| |
---|
29 | (defparameter *machine-instance* nil) |
---|
30 | |# |
---|
31 | |
---|
32 | (defun lisp-implementation-type () |
---|
33 | #+clozure-common-lisp "Clozure Common Lisp" |
---|
34 | #-clozure-common-lisp "OpenMCL") |
---|
35 | |
---|
36 | |
---|
37 | (defparameter *platform-os-names* |
---|
38 | `((,platform-os-vxworks . :vxwork) |
---|
39 | (,platform-os-linux . :linux) |
---|
40 | (,platform-os-solaris . :solaris) |
---|
41 | (,platform-os-darwin . :darwin) |
---|
42 | (,platform-os-freebsd . :freebsd) |
---|
43 | (,platform-os-windows . :windows) |
---|
44 | (,platform-os-android . :android))) |
---|
45 | |
---|
46 | (defparameter *platform-cpu-names* |
---|
47 | `((,platform-cpu-ppc . :ppc) |
---|
48 | (,platform-cpu-sparc . :sparc) |
---|
49 | (,platform-cpu-x86 . :x86) |
---|
50 | (,platform-cpu-arm . :arm))) |
---|
51 | |
---|
52 | (defun host-platform () |
---|
53 | (let* ((pf (%get-kernel-global 'host-platform))) |
---|
54 | (values |
---|
55 | (or (cdr (assoc (logand pf platform-os-mask) |
---|
56 | *platform-os-names*)) |
---|
57 | :unknown) |
---|
58 | (if (logtest pf platform-word-size-mask) |
---|
59 | 64 |
---|
60 | 32) |
---|
61 | (or (cdr (assoc (logand pf platform-cpu-mask) |
---|
62 | *platform-cpu-names*)) |
---|
63 | :unknown)))) |
---|
64 | |
---|
65 | |
---|
66 | (defun platform-description () |
---|
67 | (multiple-value-bind (os bits cpu) (host-platform) |
---|
68 | (format nil "~a~a~d" (string-capitalize os) cpu bits))) |
---|
69 | |
---|
70 | (defun lisp-implementation-version () |
---|
71 | (%str-cat "Version " (format nil *openmcl-version* (platform-description)))) |
---|
72 | |
---|
73 | |
---|
74 | |
---|
75 | |
---|
76 | (defun replace-base-translation (host-dir new-base-dir) |
---|
77 | (let* ((host (pathname-host host-dir)) |
---|
78 | (device (pathname-device new-base-dir)) |
---|
79 | (host-dir (full-pathname host-dir)) |
---|
80 | (trans (logical-pathname-translations host)) |
---|
81 | (host-wild (merge-pathnames "**/*.*" host-dir))) |
---|
82 | (setq host-dir (pathname-directory host-dir)) |
---|
83 | (setq new-base-dir (pathname-directory new-base-dir)) |
---|
84 | (setf |
---|
85 | (logical-pathname-translations host) |
---|
86 | (mapcar |
---|
87 | #'(lambda (pair) |
---|
88 | (let ((rhs (cadr pair))) |
---|
89 | (if (and (physical-pathname-p rhs) |
---|
90 | (pathname-match-p rhs host-wild)) |
---|
91 | (list (car pair) |
---|
92 | (merge-pathnames |
---|
93 | (make-pathname |
---|
94 | :defaults nil |
---|
95 | :device device |
---|
96 | :directory (append new-base-dir |
---|
97 | (nthcdr (length host-dir) |
---|
98 | (pathname-directory rhs)))) |
---|
99 | rhs)) |
---|
100 | pair))) |
---|
101 | trans)))) |
---|
102 | |
---|
103 | (defun set-ccl-directory (path) |
---|
104 | (replace-base-translation "ccl:" (translate-logical-pathname path))) |
---|
105 | |
---|
106 | |
---|
107 | |
---|
108 | |
---|
109 | ; only do these if exist |
---|
110 | (defun init-logical-directories () |
---|
111 | (replace-base-translation "home:" (user-homedir-pathname)) |
---|
112 | (replace-base-translation "ccl:" (ccl-directory))) |
---|
113 | |
---|
114 | (push #'init-logical-directories *lisp-system-pointer-functions*) |
---|
115 | |
---|
116 | |
---|
117 | (catch :toplevel |
---|
118 | (init-logical-directories) |
---|
119 | ) |
---|
120 | |
---|
121 | |
---|
122 | |
---|
123 | |
---|
124 | |
---|
125 | |
---|