/[gcl]/gcl/lsp/gcl_iolib.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_iolib.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.7 by camm, Wed Sep 7 02:49:01 2005 UTC revision 1.8 by camm, Sun Sep 18 02:46:35 2005 UTC
# Line 46  Line 46 
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))
# Line 60  Line 61 
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)
# Line 73  Line 75 
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)
# Line 85  Line 88 
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)
# Line 110  Line 114 
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*
# Line 145  Line 150 
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)
# Line 162  Line 170 
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)))
# Line 171  Line 180 
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    
# Line 179  Line 189 
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)))
# Line 187  Line 198 
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)
# Line 242  Line 254 
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*)
# Line 273  Line 286 
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
# Line 364  Line 378 
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    
# Line 456  Line 471 
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))
# Line 470  Line 486 
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)
# Line 508  the one defined in the ANSI standard. *p Line 525  the one defined in the ANSI standard. *p
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
# Line 516  the one defined in the ANSI standard. *p Line 534  the one defined in the ANSI standard. *p
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    

Legend:
Removed from v.1.7  
changed lines
  Added in v.1.8

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26