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

Last change on this file since 10426 was 10426, checked in by gb, 11 years ago

Merge a lot of the CLOS/type-system changes from working-0711 branch
into trunk. Todo: compiler-macros for those changes.

Have -not- yet merged source-tracking changes, new record-source file
from working-0711, but this stuff seems to bootstrap in one swell foop.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.5 KB
Line 
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 ()
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
44(defparameter *platform-cpu-names*
45  `((,platform-cpu-ppc . :ppc)
46    (,platform-cpu-sparc . :sparc)
47    (,platform-cpu-x86 . :x86)))
48
49(defun host-platform ()
50  (let* ((pf (%get-kernel-global 'host-platform)))
51    (values
52     (or (cdr (assoc (logand pf platform-os-mask)
53                     *platform-os-names*))
54         :unknown)
55     (if (logtest pf platform-word-size-mask)
56       64
57       32)
58     (or (cdr (assoc (logand pf platform-cpu-mask)
59                     *platform-cpu-names*))
60         :unknown))))
61
62
63(defun platform-description ()
64  (multiple-value-bind (os bits cpu) (host-platform)
65    (format nil "~a~a~d" (string-capitalize os) cpu bits)))
66
67(defun lisp-implementation-version ()
68  (%str-cat "Version " (format nil *openmcl-version* (platform-description))))
69
70
71
72
73(defun replace-base-translation (host-dir new-base-dir)
74  (let* ((host (pathname-host host-dir))
75         (host-dir (full-pathname host-dir))
76         (trans (logical-pathname-translations host))
77         (host-wild (merge-pathnames "**/*.*" host-dir)))
78    (setq host-dir (pathname-directory host-dir))
79    (setq new-base-dir (pathname-directory new-base-dir))
80    (setf 
81     (logical-pathname-translations host)
82     (mapcar
83      #'(lambda (pair)
84          (let ((rhs (cadr pair)))
85            (if (and (physical-pathname-p rhs)
86                     (pathname-match-p rhs host-wild))
87              (list (car pair)
88                    (merge-pathnames 
89                     (make-pathname 
90                      :defaults nil 
91                      :directory (append new-base-dir
92                                         (nthcdr (length host-dir) 
93                                                 (pathname-directory rhs))))
94                     rhs))
95              pair)))
96      trans))))
97
98(defun set-ccl-directory (path)
99  (replace-base-translation "ccl:" (translate-logical-pathname path)))
100
101
102
103
104; only do these if exist
105(defun init-logical-directories ()
106  (replace-base-translation "home:"  (user-homedir-pathname))
107  (replace-base-translation "ccl:" (ccl-directory)))
108
109(push #'init-logical-directories *lisp-system-pointer-functions*)
110
111
112(catch :toplevel
113  (setq *loading-file-source-file* nil)  ;Reset from last %fasload...
114  (init-logical-directories)
115  )
116
117
118
119
120
121
Note: See TracBrowser for help on using the repository browser.