source: trunk/source/level-1/l1-boot-lds.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: 5.3 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
18; l1-boot-lds.lisp
19
20(in-package "CCL")
21
22
23
24
25
26(defun command-line-arguments ()
27  *command-line-argument-list*)
28
29(defun startup-ccl (&optional init-file)
30  ;; Many of the things done here could enter a break loop on error.
31  ;; If that break loop is exited via :q, quietly exit to here.
32  (catch :toplevel
33    (with-simple-restart (abort "Abort startup.")
34      (let ((init-files (if (listp init-file) init-file (list init-file))))
35        (dolist (init-file init-files)
36          (with-simple-restart (continue "Skip loading init file.")
37            (when (load init-file :if-does-not-exist nil :verbose nil)
38              (return)))))
39      (flet ((eval-string (s)
40               (with-simple-restart (continue "Skip evaluation of ~a" s)
41                 (eval (read-from-string s))))
42             (load-file (name)
43               (with-simple-restart (continue "Skip loading ~s" name)
44                 (load name))))
45        (dolist (p *lisp-startup-parameters*)
46          (let* ((param (cdr p)))
47            (case (car p)
48              (:gc-threshold
49               (multiple-value-bind (n last) (parse-integer param :junk-allowed t)
50                 (when n
51                   (if (< last (length param))
52                     (case (schar param last)
53                       ((#\k #\K) (setq n (ash n 10)))
54                       ((#\m #\M) (setq n (ash n 20)))))
55                   (set-lisp-heap-gc-threshold n)
56                   (use-lisp-heap-gc-threshold))))
57              (:eval (eval-string param))
58              (:load (load-file param)))))))))
59
60(defloadvar *did-show-marketing-blurb* nil)
61
62(defparameter *marketing-blurb* "
63CCL is developed and maintained by Clozure Associates. For more information
64about CCL visit http://ccl.clozure.com.  To enquire about Clozure's Common Lisp
65consulting services e-mail info@clozure.com or visit http://www.clozure.com.
66
67")
68
69(defun listener-function ()
70  (unless (or *inhibit-greeting* *quiet-flag*)
71    (format t "~&Welcome to ~A ~A!~%"
72            (lisp-implementation-type)
73            (lisp-implementation-version))
74    (unless *did-show-marketing-blurb*
75      (write-string *marketing-blurb* t)
76      (setq *did-show-marketing-blurb* t)))
77  (toplevel-loop))
78
79(defun make-mcl-listener-process (procname
80                                  input-stream
81                                  output-stream
82                                  cleanup-function
83                                  &key
84                                  (initial-function #'listener-function)
85                                  (close-streams t)
86                                  (class 'process)
87                                  (control-stack-size *default-control-stack-size*)
88                                  (auto-flush t)
89                                  (value-stack-size *default-value-stack-size*)
90                                  (temp-stack-size *default-temp-stack-size*)
91                                  (echoing t)
92                                  (process)
93                                  (initargs nil))
94  (let ((p (if (typep process class)
95             (progn
96               (setf (process-thread process)
97                     (new-thread procname control-stack-size value-stack-size  temp-stack-size))
98               process)
99             (make-process procname
100                           :class class :initargs initargs
101                           :stack-size control-stack-size
102                           :vstack-size value-stack-size
103                           :tstack-size temp-stack-size))))
104    (process-preset p #'(lambda ()
105                          (let ((*terminal-io*
106                                 (if echoing
107                                   (make-echoing-two-way-stream
108                                    input-stream output-stream)
109                                   (make-two-way-stream
110                                    input-stream output-stream))))
111                            (unwind-protect
112                                 (progn
113                                   (when auto-flush
114                                     (add-auto-flush-stream output-stream))
115                                   (let* ((shared-input
116                                           (input-stream-shared-resource
117                                            input-stream)))
118                                     (when shared-input
119                                       (setf (shared-resource-primary-owner
120                                              shared-input)
121                                             *current-process*)))
122                                   (application-ui-operation
123                                    *application*
124                                    :note-current-package *package*)
125                                   (funcall initial-function))
126                              (remove-auto-flush-stream output-stream)
127                              (funcall cleanup-function)
128                              (when close-streams
129                                (close input-stream)
130                                (close output-stream))))))
131    (process-enable p)
132    p))
133
134
135; End of l1-boot-lds.lisp
Note: See TracBrowser for help on using the repository browser.