46 |
(in-package 'system) |
(in-package 'system) |
47 |
|
|
48 |
|
|
49 |
(proclaim '(optimize (safety 2) (space 3))) |
;(proclaim '(optimize (safety 2) (space 3))) |
50 |
|
|
51 |
|
|
52 |
(defmacro with-open-stream ((var stream) . body) |
(defmacro with-open-stream ((var stream) . body) |
53 |
|
(declare (optimize (safety 1))) |
54 |
(multiple-value-bind (ds b) |
(multiple-value-bind (ds b) |
55 |
(find-declarations body) |
(find-declarations body) |
56 |
`(let ((,var ,stream)) |
`(let ((,var ,stream)) |
61 |
|
|
62 |
|
|
63 |
(defmacro with-input-from-string ((var string &key index start end) . body) |
(defmacro with-input-from-string ((var string &key index start end) . body) |
64 |
|
(declare (optimize (safety 1))) |
65 |
(if index |
(if index |
66 |
(multiple-value-bind (ds b) |
(multiple-value-bind (ds b) |
67 |
(find-declarations body) |
(find-declarations body) |
75 |
|
|
76 |
|
|
77 |
(defmacro with-output-to-string ((var &optional string) . body) |
(defmacro with-output-to-string ((var &optional string) . body) |
78 |
|
(declare (optimize (safety 1))) |
79 |
(if string |
(if string |
80 |
`(let ((,var (make-string-output-stream-from-string ,string))) |
`(let ((,var (make-string-output-stream-from-string ,string))) |
81 |
,@body) |
,@body) |
88 |
&optional (eof-error-p t) eof-value |
&optional (eof-error-p t) eof-value |
89 |
&key (start 0) (end (length string)) |
&key (start 0) (end (length string)) |
90 |
preserve-whitespace) |
preserve-whitespace) |
91 |
|
(declare (optimize (safety 1))) |
92 |
(let ((stream (make-string-input-stream string start end))) |
(let ((stream (make-string-input-stream string start end))) |
93 |
(if preserve-whitespace |
(if preserve-whitespace |
94 |
(values (read-preserving-whitespace stream eof-error-p eof-value) |
(values (read-preserving-whitespace stream eof-error-p eof-value) |
114 |
( readably nil readably-supplied-p ) |
( readably nil readably-supplied-p ) |
115 |
( right-margin nil right-margin-supplied-p ) |
( right-margin nil right-margin-supplied-p ) |
116 |
&aux (stream (make-string-output-stream))) |
&aux (stream (make-string-output-stream))) |
117 |
|
(declare (optimize (safety 1))) |
118 |
(let*((*print-array* |
(let*((*print-array* |
119 |
(if array-supplied-p array *print-array*)) |
(if array-supplied-p array *print-array*)) |
120 |
(*print-base* |
(*print-base* |
150 |
|
|
151 |
(defun prin1-to-string (object |
(defun prin1-to-string (object |
152 |
&aux (stream (make-string-output-stream))) |
&aux (stream (make-string-output-stream))) |
153 |
(prin1 object stream) |
(declare (optimize (safety 1))) |
154 |
(get-output-stream-string stream)) |
(prin1 object stream) |
155 |
|
(get-output-stream-string stream)) |
156 |
|
|
157 |
|
|
158 |
(defun princ-to-string (object |
(defun princ-to-string (object |
159 |
&aux (stream (make-string-output-stream))) |
&aux (stream (make-string-output-stream))) |
160 |
|
(declare (optimize (safety 1))) |
161 |
(princ object stream) |
(princ object stream) |
162 |
(get-output-stream-string stream)) |
(get-output-stream-string stream)) |
163 |
|
|
164 |
(defun file-string-length (ostream object) |
(defun file-string-length (ostream object) |
165 |
|
(declare (optimize (safety 1))) |
166 |
(if (subtypep (stream-element-type ostream) 'character) |
(if (subtypep (stream-element-type ostream) 'character) |
167 |
(let ((sstream (make-string-output-stream))) |
(let ((sstream (make-string-output-stream))) |
168 |
(write object :stream sstream) |
(write object :stream sstream) |
170 |
nil)) |
nil)) |
171 |
|
|
172 |
(defmacro with-open-file ((stream . filespec) . body) |
(defmacro with-open-file ((stream . filespec) . body) |
173 |
|
(declare (optimize (safety 1))) |
174 |
(multiple-value-bind (ds b) |
(multiple-value-bind (ds b) |
175 |
(find-declarations body) |
(find-declarations body) |
176 |
`(let ((,stream (open ,@filespec))) |
`(let ((,stream (open ,@filespec))) |
180 |
(if ,stream (close ,stream)))))) |
(if ,stream (close ,stream)))))) |
181 |
|
|
182 |
(defun pprint-dispatch (obj &optional (table *print-pprint-dispatch*)) |
(defun pprint-dispatch (obj &optional (table *print-pprint-dispatch*)) |
183 |
|
(declare (optimize (safety 1))) |
184 |
(let ((fun (si:get-pprint-dispatch obj table))) |
(let ((fun (si:get-pprint-dispatch obj table))) |
185 |
(if fun (values fun t) (values 'si:default-pprint-object nil)))) |
(if fun (values fun t) (values 'si:default-pprint-object nil)))) |
186 |
|
|
189 |
(defun set-pprint-dispatch (type-spec function &optional |
(defun set-pprint-dispatch (type-spec function &optional |
190 |
(priority 0) |
(priority 0) |
191 |
(table *print-pprint-dispatch*)) |
(table *print-pprint-dispatch*)) |
192 |
|
(declare (optimize (safety 1))) |
193 |
(unless (typep priority 'real) |
(unless (typep priority 'real) |
194 |
(specific-error :wrong-type-argument "~S is not of type ~S." priority 'real)) |
(specific-error :wrong-type-argument "~S is not of type ~S." priority 'real)) |
195 |
(let ((a (assoc type-spec (cdr table) :test 'equal))) |
(let ((a (assoc type-spec (cdr table) :test 'equal))) |
198 |
nil) |
nil) |
199 |
|
|
200 |
(defun copy-pprint-dispatch (&optional table) |
(defun copy-pprint-dispatch (&optional table) |
201 |
|
(declare (optimize (safety 1))) |
202 |
(unless table |
(unless table |
203 |
(setq table *print-pprint-dispatch*)) |
(setq table *print-pprint-dispatch*)) |
204 |
(unless (and (eq (type-of table) 'cons) |
(unless (and (eq (type-of table) 'cons) |
254 |
(defvar *dribble-saved-terminal-io* nil) |
(defvar *dribble-saved-terminal-io* nil) |
255 |
|
|
256 |
(defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede)) |
(defun dribble (&optional (pathname "DRIBBLE.LOG" psp) (f :supersede)) |
257 |
|
(declare (optimize (safety 1))) |
258 |
(cond ((not psp) |
(cond ((not psp) |
259 |
(when (null *dribble-stream*) (error "Not in dribble.")) |
(when (null *dribble-stream*) (error "Not in dribble.")) |
260 |
(if (eq *dribble-io* *terminal-io*) |
(if (eq *dribble-io* *terminal-io*) |
286 |
;;; ensure-directories-exist |
;;; ensure-directories-exist |
287 |
|
|
288 |
(defun ensure-directories-exist (pathspec &key verbose) |
(defun ensure-directories-exist (pathspec &key verbose) |
289 |
|
(declare (optimize (safety 1))) |
290 |
(flet ((pop-path |
(flet ((pop-path |
291 |
(p) |
(p) |
292 |
(if (pathname-name p) p |
(if (pathname-name p) p |
378 |
value)) |
value)) |
379 |
|
|
380 |
(defun logical-pathname-translations (key) |
(defun logical-pathname-translations (key) |
381 |
|
(declare (optimize (safety 1))) |
382 |
(let ((k (if (stringp key) (string-right-trim ":" (string-downcase key)) key))) |
(let ((k (if (stringp key) (string-right-trim ":" (string-downcase key)) key))) |
383 |
(cdr (si:pathname-lookup k si:*pathname-logical*)))) |
(cdr (si:pathname-lookup k si:*pathname-logical*)))) |
384 |
|
|
471 |
; simple formatter macro |
; simple formatter macro |
472 |
|
|
473 |
(defmacro formatter ( control-string ) |
(defmacro formatter ( control-string ) |
474 |
|
(declare (optimize (safety 1))) |
475 |
`(progn |
`(progn |
476 |
(lambda (*standard-output* &rest arguments) |
(lambda (*standard-output* &rest arguments) |
477 |
(let ((*format-unused-args* nil)) |
(let ((*format-unused-args* nil)) |
486 |
The forms of the body are executed in a print environment that corresponds to |
The forms of the body are executed in a print environment that corresponds to |
487 |
the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, |
the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, |
488 |
*package* is \"CL-USER\", etc." |
*package* is \"CL-USER\", etc." |
489 |
|
(declare (optimize (safety 1))) |
490 |
`(let*((*package* (find-package :cl-user)) |
`(let*((*package* (find-package :cl-user)) |
491 |
(*print-array* t) ;; print-array -> core dampft |
(*print-array* t) ;; print-array -> core dampft |
492 |
(*print-base* 10) |
(*print-base* 10) |
525 |
|
|
526 |
(defmacro print-unreadable-object |
(defmacro print-unreadable-object |
527 |
((object stream &key type identity) &body body) |
((object stream &key type identity) &body body) |
528 |
|
(declare (optimize (safety 1))) |
529 |
(if body |
(if body |
530 |
`(flet ((.print-unreadable-object-body. () ,@body)) |
`(flet ((.print-unreadable-object-body. () ,@body)) |
531 |
(si::print-unreadable-object-function |
(si::print-unreadable-object-function |
534 |
|
|
535 |
; i know this should be in cmpnew - but its easier here. |
; i know this should be in cmpnew - but its easier here. |
536 |
|
|
537 |
(defmacro with-compilation-unit (opt &rest body) (declare (ignore opt)) `(progn ,@body)) |
(defmacro with-compilation-unit (opt &rest body) |
538 |
|
(declare (optimize (safety 1))) |
539 |
|
(declare (ignore opt)) |
540 |
|
`(progn ,@body)) |
541 |
|
|