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

Last change on this file since 15278 was 14513, checked in by gb, 9 years ago

Recognize Android as a platform os name.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.7 KB
RevLine 
[6]1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[6]6;;;
[13066]7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18;; L1-boot.lisp
19
[2326]20(in-package "CCL")
[6]21
[929]22(defparameter *gensym-counter* 0 "counter for generating unique GENSYM symbols")
[6]23
24(defparameter *inhibit-greeting* nil)
25
26;the below 3 variables are expected to be redefined in the user's init file
27(defparameter *short-site-name* nil)
28(defparameter *long-site-name* nil)
29#|
30(defparameter *machine-instance* nil)
31|#
32
[7364]33(defun lisp-implementation-type ()
34  #+clozure-common-lisp "Clozure Common Lisp"
35  #-clozure-common-lisp "OpenMCL")
[6]36
37
[3895]38(defparameter *platform-os-names*
39  `((,platform-os-vxworks . :vxwork)
40    (,platform-os-linux . :linux)
41    (,platform-os-solaris . :solaris)
[4827]42    (,platform-os-darwin . :darwin)
[10627]43    (,platform-os-freebsd . :freebsd)
[14513]44    (,platform-os-windows . :windows)
45    (,platform-os-android . :android)))
[6]46
[3895]47(defparameter *platform-cpu-names*
48  `((,platform-cpu-ppc . :ppc)
49    (,platform-cpu-sparc . :sparc)
[14119]50    (,platform-cpu-x86 . :x86)
51    (,platform-cpu-arm . :arm)))
[3895]52
[6]53(defun host-platform ()
[3895]54  (let* ((pf (%get-kernel-global 'host-platform)))
[1728]55    (values
[3895]56     (or (cdr (assoc (logand pf platform-os-mask)
57                     *platform-os-names*))
58         :unknown)
59     (if (logtest pf platform-word-size-mask)
60       64
61       32)
62     (or (cdr (assoc (logand pf platform-cpu-mask)
63                     *platform-cpu-names*))
64         :unknown))))
[6]65
[3895]66
[1728]67(defun platform-description ()
[3895]68  (multiple-value-bind (os bits cpu) (host-platform)
69    (format nil "~a~a~d" (string-capitalize os) cpu bits)))
[1728]70
[6]71(defun lisp-implementation-version ()
[1728]72  (%str-cat "Version " (format nil *openmcl-version* (platform-description))))
[6]73
74
75
76
77(defun replace-base-translation (host-dir new-base-dir)
78  (let* ((host (pathname-host host-dir))
[10627]79         (device (pathname-device new-base-dir))
[6]80         (host-dir (full-pathname host-dir))
81         (trans (logical-pathname-translations host))
82         (host-wild (merge-pathnames "**/*.*" host-dir)))
83    (setq host-dir (pathname-directory host-dir))
84    (setq new-base-dir (pathname-directory new-base-dir))
85    (setf 
86     (logical-pathname-translations host)
87     (mapcar
88      #'(lambda (pair)
89          (let ((rhs (cadr pair)))
90            (if (and (physical-pathname-p rhs)
91                     (pathname-match-p rhs host-wild))
92              (list (car pair)
93                    (merge-pathnames 
94                     (make-pathname 
[10627]95                      :defaults nil
96                      :device device
[6]97                      :directory (append new-base-dir
98                                         (nthcdr (length host-dir) 
99                                                 (pathname-directory rhs))))
100                     rhs))
101              pair)))
102      trans))))
103
[7726]104(defun set-ccl-directory (path)
105  (replace-base-translation "ccl:" (translate-logical-pathname path)))
[6]106
107
108
[7726]109
[6]110; only do these if exist
[10426]111(defun init-logical-directories ()
112  (replace-base-translation "home:"  (user-homedir-pathname))
113  (replace-base-translation "ccl:" (ccl-directory)))
[6]114
115(push #'init-logical-directories *lisp-system-pointer-functions*)
116
[182]117
[6]118(catch :toplevel
119  (init-logical-directories)
120  )
121
122
123
124
125
126
Note: See TracBrowser for help on using the repository browser.