source: branches/working-0711/ccl/level-1/l1-boot-lds.lisp @ 11832

Last change on this file since 11832 was 11101, checked in by gz, 11 years ago

Another round of changes from the trunk, mostly just mods in internal mechanisms in support of various recent ports.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.4 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
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  (with-simple-restart (abort "Abort startup.")
31    (let ((init-files (if (listp init-file) init-file (list init-file))))
32      (dolist (init-file init-files)
33        (with-simple-restart (continue "Skip loading init file.")
34          (when (load init-file :if-does-not-exist nil :verbose nil)
35            (return)))))
36    (flet ((eval-string (s)
37             (with-simple-restart (continue "Skip evaluation of ~a" s)
38               (eval (read-from-string s))))
39           (load-file (name)
40             (with-simple-restart (continue "Skip loading ~s" name)
41               (load name))))
42      (dolist (p *lisp-startup-parameters*)
43        (let* ((param (cdr p)))
44          (case (car p)
45            (:gc-threshold
46             (multiple-value-bind (n last) (parse-integer param :junk-allowed t)
47               (when n
48                 (if (< last (length param))
49                   (case (schar param last)
50                     ((#\k #\K) (setq n (ash n 10)))
51                     ((#\m #\M) (setq n (ash n 20)))))
52                 (set-lisp-heap-gc-threshold n)
53                 (use-lisp-heap-gc-threshold))))
54            (:eval (eval-string param))
55            (:load (load-file param))))))))
56
57
58(defun listener-function ()
59  (progn
60    (unless (or *inhibit-greeting* *quiet-flag*)
61      (format t "~&Welcome to ~A ~A!~%"
62              (lisp-implementation-type)
63              (lisp-implementation-version)))
64    (toplevel-loop)))
65
66
67(defun make-mcl-listener-process (procname
68                                  input-stream
69                                  output-stream
70                                  cleanup-function
71                                  &key
72                                  (initial-function #'listener-function)
73                                  (close-streams t)
74                                  (class 'process)
75                                  (control-stack-size *default-control-stack-size*)
76                                  (auto-flush t)
77                                  (value-stack-size *default-value-stack-size*)
78                                  (temp-stack-size *default-temp-stack-size*)
79                                  (echoing t)
80                                  (process))
81  (let ((p (if (typep process class)
82             (progn
83               (setf (process-thread process)
84                     (new-thread procname control-stack-size value-stack-size  temp-stack-size))
85               process)
86             (make-process procname
87                           :class class
88                           :stack-size control-stack-size
89                           :vstack-size value-stack-size
90                           :tstack-size temp-stack-size))))
91    (process-preset p #'(lambda ()
92                          (let ((*terminal-io*
93                                 (if echoing
94                                   (make-echoing-two-way-stream
95                                    input-stream output-stream)
96                                   (make-two-way-stream
97                                    input-stream output-stream))))
98                            (unwind-protect
99                                 (progn
100                                   (when auto-flush
101                                     (add-auto-flush-stream output-stream))
102                                   (let* ((shared-input
103                                           (input-stream-shared-resource
104                                            input-stream)))
105                                     (when shared-input
106                                       (setf (shared-resource-primary-owner
107                                              shared-input)
108                                             *current-process*)))
109                                   (application-ui-operation
110                                    *application*
111                                    :note-current-package *package*)
112                                   (funcall initial-function))
113                              (remove-auto-flush-stream output-stream)
114                              (funcall cleanup-function)
115                              (when close-streams
116                                (close input-stream)
117                                (close output-stream))))))
118    (process-enable p)
119    p))
120
121
122; End of l1-boot-lds.lisp
Note: See TracBrowser for help on using the repository browser.