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

Last change on this file since 13537 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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