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

Last change on this file since 15018 was 14995, checked in by gz, 8 years ago

accept an :initargs arg in make-mcl-listener-process

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
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
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18
19; l1-boot-lds.lisp
20
21(in-package "CCL")
22
23
24
25
26
27(defun command-line-arguments ()
28  *command-line-argument-list*)
29
30(defun startup-ccl (&optional init-file)
31  ;; Many of the things done here could enter a break loop on error.
32  ;; If that break loop is exited via :q, quietly exit to here.
33  (catch :toplevel
34    (with-simple-restart (abort "Abort startup.")
35      (let ((init-files (if (listp init-file) init-file (list init-file))))
36        (dolist (init-file init-files)
37          (with-simple-restart (continue "Skip loading init file.")
38            (when (load init-file :if-does-not-exist nil :verbose nil)
39              (return)))))
40      (flet ((eval-string (s)
41               (with-simple-restart (continue "Skip evaluation of ~a" s)
42                 (eval (read-from-string s))))
43             (load-file (name)
44               (with-simple-restart (continue "Skip loading ~s" name)
45                 (load name))))
46        (dolist (p *lisp-startup-parameters*)
47          (let* ((param (cdr p)))
48            (case (car p)
49              (:gc-threshold
50               (multiple-value-bind (n last) (parse-integer param :junk-allowed t)
51                 (when n
52                   (if (< last (length param))
53                     (case (schar param last)
54                       ((#\k #\K) (setq n (ash n 10)))
55                       ((#\m #\M) (setq n (ash n 20)))))
56                   (set-lisp-heap-gc-threshold n)
57                   (use-lisp-heap-gc-threshold))))
58              (:eval (eval-string param))
59              (:load (load-file param)))))))))
60
61
62(defun listener-function ()
63  (progn
64    (unless (or *inhibit-greeting* *quiet-flag*)
65      (format t "~&Welcome to ~A ~A!~%"
66              (lisp-implementation-type)
67              (lisp-implementation-version)))
68    (toplevel-loop)))
69
70
71(defun make-mcl-listener-process (procname
72                                  input-stream
73                                  output-stream
74                                  cleanup-function
75                                  &key
76                                  (initial-function #'listener-function)
77                                  (close-streams t)
78                                  (class 'process)
79                                  (control-stack-size *default-control-stack-size*)
80                                  (auto-flush t)
81                                  (value-stack-size *default-value-stack-size*)
82                                  (temp-stack-size *default-temp-stack-size*)
83                                  (echoing t)
84                                  (process)
85                                  (initargs nil))
86  (let ((p (if (typep process class)
87             (progn
88               (setf (process-thread process)
89                     (new-thread procname control-stack-size value-stack-size  temp-stack-size))
90               process)
91             (make-process procname
92                           :class class :initargs initargs
93                           :stack-size control-stack-size
94                           :vstack-size value-stack-size
95                           :tstack-size temp-stack-size))))
96    (process-preset p #'(lambda ()
97                          (let ((*terminal-io*
98                                 (if echoing
99                                   (make-echoing-two-way-stream
100                                    input-stream output-stream)
101                                   (make-two-way-stream
102                                    input-stream output-stream))))
103                            (unwind-protect
104                                 (progn
105                                   (when auto-flush
106                                     (add-auto-flush-stream output-stream))
107                                   (let* ((shared-input
108                                           (input-stream-shared-resource
109                                            input-stream)))
110                                     (when shared-input
111                                       (setf (shared-resource-primary-owner
112                                              shared-input)
113                                             *current-process*)))
114                                   (application-ui-operation
115                                    *application*
116                                    :note-current-package *package*)
117                                   (funcall initial-function))
118                              (remove-auto-flush-stream output-stream)
119                              (funcall cleanup-function)
120                              (when close-streams
121                                (close input-stream)
122                                (close output-stream))))))
123    (process-enable p)
124    p))
125
126
127; End of l1-boot-lds.lisp
Note: See TracBrowser for help on using the repository browser.