1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
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 () "OpenMCL") |
---|
33 | |
---|
34 | |
---|
35 | (defparameter *platform-os-names* |
---|
36 | `((,platform-os-vxworks . :vxwork) |
---|
37 | (,platform-os-linux . :linux) |
---|
38 | (,platform-os-solaris . :solaris) |
---|
39 | (,platform-os-darwin . :darwin) |
---|
40 | (,platform-os-freebsd . :freebsd))) |
---|
41 | |
---|
42 | (defparameter *platform-cpu-names* |
---|
43 | `((,platform-cpu-ppc . :ppc) |
---|
44 | (,platform-cpu-sparc . :sparc) |
---|
45 | (,platform-cpu-x86 . :x86))) |
---|
46 | |
---|
47 | (defun host-platform () |
---|
48 | (let* ((pf (%get-kernel-global 'host-platform))) |
---|
49 | (values |
---|
50 | (or (cdr (assoc (logand pf platform-os-mask) |
---|
51 | *platform-os-names*)) |
---|
52 | :unknown) |
---|
53 | (if (logtest pf platform-word-size-mask) |
---|
54 | 64 |
---|
55 | 32) |
---|
56 | (or (cdr (assoc (logand pf platform-cpu-mask) |
---|
57 | *platform-cpu-names*)) |
---|
58 | :unknown)))) |
---|
59 | |
---|
60 | |
---|
61 | (defun platform-description () |
---|
62 | (multiple-value-bind (os bits cpu) (host-platform) |
---|
63 | (format nil "~a~a~d" (string-capitalize os) cpu bits))) |
---|
64 | |
---|
65 | (defun lisp-implementation-version () |
---|
66 | (%str-cat "Version " (format nil *openmcl-version* (platform-description)))) |
---|
67 | |
---|
68 | |
---|
69 | |
---|
70 | |
---|
71 | (defun replace-base-translation (host-dir new-base-dir) |
---|
72 | (let* ((host (pathname-host host-dir)) |
---|
73 | (host-dir (full-pathname host-dir)) |
---|
74 | (trans (logical-pathname-translations host)) |
---|
75 | (host-wild (merge-pathnames "**/*.*" host-dir))) |
---|
76 | (setq host-dir (pathname-directory host-dir)) |
---|
77 | (setq new-base-dir (pathname-directory new-base-dir)) |
---|
78 | (setf |
---|
79 | (logical-pathname-translations host) |
---|
80 | (mapcar |
---|
81 | #'(lambda (pair) |
---|
82 | (let ((rhs (cadr pair))) |
---|
83 | (if (and (physical-pathname-p rhs) |
---|
84 | (pathname-match-p rhs host-wild)) |
---|
85 | (list (car pair) |
---|
86 | (merge-pathnames |
---|
87 | (make-pathname |
---|
88 | :defaults nil |
---|
89 | :directory (append new-base-dir |
---|
90 | (nthcdr (length host-dir) |
---|
91 | (pathname-directory rhs)))) |
---|
92 | rhs)) |
---|
93 | pair))) |
---|
94 | trans)))) |
---|
95 | |
---|
96 | |
---|
97 | |
---|
98 | |
---|
99 | ; only do these if exist |
---|
100 | (defun init-logical-directories () |
---|
101 | (let ((startup (mac-default-directory))) |
---|
102 | (replace-base-translation "home:" (or (user-homedir-pathname) startup)) |
---|
103 | (replace-base-translation "ccl:" (ccl-directory)) |
---|
104 | )) |
---|
105 | |
---|
106 | (push #'init-logical-directories *lisp-system-pointer-functions*) |
---|
107 | |
---|
108 | |
---|
109 | (catch :toplevel |
---|
110 | (setq *loading-file-source-file* nil) ;Reset from last %fasload... |
---|
111 | (init-logical-directories) |
---|
112 | ) |
---|
113 | |
---|
114 | |
---|
115 | |
---|
116 | |
---|
117 | |
---|
118 | |
---|