source: trunk/source/level-1/l1-boot-1.lisp

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.6 KB
Line 
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
Note: See TracBrowser for help on using the repository browser.