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

Last change on this file since 8914 was 8914, checked in by gb, 12 years ago

MAKE-MCL-LISTENER-PROCESS: make auto-flush a keyword. Do IDE
listeners want housekeeping thread to force-output on them
periodically ?

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 4.6 KB
RevLine 
[6]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
[2326]20(in-package "CCL")
[6]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.")
[7487]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            #+clozure-common-lisp ;; Kludge to help people transition
36            (when (equalp (pathname-name init-file) "openmcl-init")
37              (warn ">>>>>> The use of openmcl-init.lisp is deprecated.  Please rename your init file to ccl-init.lisp"))
38            (return)))))
[6]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))
[2298]58            (:load (load-file param))))))))
[6]59
60
61(defun listener-function ()
62  (progn
[2072]63    (unless (or *inhibit-greeting* *quiet-flag*)
[6]64      (format t "~&Welcome to ~A ~A!~%"
65              (lisp-implementation-type)
66              (lisp-implementation-version)))
67    (toplevel-loop)))
68
[693]69
70(defun make-mcl-listener-process (procname
71                                  input-stream
72                                  output-stream
73                                  cleanup-function
74                                  &key
75                                  (initial-function #'listener-function)
76                                  (close-streams t)
[3525]77                                  (class 'process)
78                                  (control-stack-size *default-control-stack-size*)
[8914]79                                  (auto-flush t)
[3525]80                                  (value-stack-size *default-value-stack-size*)
[5893]81                                  (temp-stack-size *default-temp-stack-size*)
[8166]82                                  (echoing t)
[5893]83                                  (process))
84  (let ((p (if (typep process class)
85             (progn
86               (setf (process-thread process)
87                     (new-thread procname control-stack-size value-stack-size  temp-stack-size))
88               process)
89             (make-process procname
90                           :class class
91                           :stack-size control-stack-size
92                           :vstack-size value-stack-size
93                           :tstack-size temp-stack-size))))
[6]94    (process-preset p #'(lambda ()
[693]95                          (let ((*terminal-io*
[8166]96                                 (if echoing
97                                   (make-echoing-two-way-stream
98                                    input-stream output-stream)
99                                   (make-two-way-stream
100                                    input-stream output-stream))))
[6]101                            (unwind-protect
102                                 (progn
[8914]103                                   (when auto-flush
104                                     (add-auto-flush-stream output-stream))
[482]105                                   (let* ((shared-input
106                                           (input-stream-shared-resource
107                                            input-stream)))
108                                     (when shared-input
109                                       (setf (shared-resource-primary-owner
110                                              shared-input)
111                                             *current-process*)))
[600]112                                   (application-ui-operation
113                                    *application*
[693]114                                    :note-current-package *package*)
[6]115                                   (funcall initial-function))
[5027]116                              (remove-auto-flush-stream output-stream)
[6]117                              (funcall cleanup-function)
118                              (when close-streams
119                                (close input-stream)
120                                (close output-stream))))))
121    (process-enable p)
122    p))
123
124
125; End of l1-boot-lds.lisp
Note: See TracBrowser for help on using the repository browser.