package-excl.lisp 14.7 KB
Newer Older
Zach Beane's avatar
Zach Beane committed
1
2
3
4
5
6
7
;;;; package-excl.lisp
;;;
;;; This file is a grab-bag of miscellaneous functions from EXCL.
;;;

(in-package #:zacl)

8
9
10
11
12
13
14
15
16
(defparameter *external-format-translations*
  '((:octets . :latin1)
    (:latin1-base . :latin1)
    (nil . :latin1)))

(defun translate-external-format (external-format)
  (let ((entry (assoc external-format *external-format-translations*)))
    (if entry
        (cdr entry)
17
        :utf-8)))
18
19


20
21
(defvar excl:*initial-terminal-io* *terminal-io*)

22
23
(defvar excl:*cl-default-special-bindings* nil)

24
25
(defvar excl:*required-top-level-bindings* nil)

Zach Beane's avatar
Zach Beane committed
26
27
(defvar excl:*current-case-mode* :case-insensitive-upper)

28

Zach Beane's avatar
Zach Beane committed
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
(defmacro excl:named-function (name lambda-form)
  "Return the function produced by LAMBDA-FORM wrapped in a named
function object. Useful for debugging, as the function object is no
longer anonymous, but has a meaningful name name."
  (destructuring-bind (lambda-name lambda-list &body body)
      lambda-form
    (unless (eq lambda-name 'cl:lambda)
      (error "Unexpected named-function form"))
    `(flet ((,name ,lambda-list ,@body))
       #',name)))


(defun excl:featurep (feature)
  (find feature *features*))

Zach Beane's avatar
Zach Beane committed
44

45
46
47
(defmacro excl::fast (&body body)
  `(progn ,@body))

Zach Beane's avatar
Zach Beane committed
48
49
50
51
52
53
54
(defun excl:gc (&optional full)
  (declare (ignorable full))
  #+ccl
  (ccl:gc)
  #+sbcl
  (sb-ext:gc :full full))

Zach Beane's avatar
Zach Beane committed
55
(defun excl:match-re (pattern string &key (return :string) case-fold)
56
  (multiple-value-bind (start end regs-starts regs-ends)
Zach Beane's avatar
Zach Beane committed
57
      (scan (create-scanner pattern :case-insensitive-mode case-fold) string )
58
59
60
61
62
63
64
65
66
    (when (and start end)
      (ecase return
        (:index
         (values-list (list* (cons start end) (map 'list 'cons regs-starts regs-ends))))
        (:string
         (values-list (list* (subseq string start end)
                             (map 'list (lambda (start end)
                                          (subseq string start end))
                                  regs-starts
Zach Beane's avatar
Zach Beane committed
67
68
69
                                  regs-ends))))
        ((nil)
         t)))))
Zach Beane's avatar
Zach Beane committed
70

71
72
(defun excl:match-regexp (pattern string &key (return :string))
  (excl:match-re pattern string :return return))
Zach Beane's avatar
Zach Beane committed
73

Zach Beane's avatar
Zach Beane committed
74
75
76
(defun excl:compile-regexp (pattern)
  (create-scanner pattern))

Zach Beane's avatar
Zach Beane committed
77
78
79
80

(defmacro excl:with-output-to-buffer ((stream) &body body)
  `(with-output-to-sequence (,stream)
     ,@body))
Zach Beane's avatar
Zach Beane committed
81

82
83
84
(defun excl:get-output-stream-buffer (stream)
  (get-output-stream-sequence stream))

Zach Beane's avatar
Zach Beane committed
85
86
87
88
89

;;; Streams

(defmacro excl:sm (slot-name object)
  `(slot-value ,object ',slot-name))
90

91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
(defmacro excl:def-stream-class (name (&rest parents) &body slot-defs)
  `(defclass ,name (,@parents)
     ,@slot-defs))

(defmacro excl:with-stream-class ((class var) &body body)
  (declare (ignore class var))
  `(progn ,@body))

(defgeneric excl:device-read (stream buffer start end blocking))

(defgeneric excl:device-close (stream abort))

(define-condition excl:stream-closed-error (error) ())

(def-fake-slot excl::stream-property-list stream :default-value nil)
(def-fake-slot excl:stream-error-identifier stream :default-value nil)
(def-fake-slot excl:stream-error-code stream :default-value 0)
108

109
110
111
112
113
114
115
116
#+ccl
(defmethod excl:stream-error-identifier ((condition ccl:socket-error))
  (ccl:socket-error-identifier condition))

#+ccl
(defmethod excl:stream-error-code ((condition ccl:socket-error))
  (ccl:socket-error-code condition))

117
118
;;; Misc

119
120
121
122
123
124
125
(defmacro excl::.atomically (&body body)
  `(progn ,@body))

(defmacro excl:atomic-conditional-setf (place new-value old-value)
  (declare (ignore old-value))
  `(setf ,place ,new-value))

126
127
128
129
130
131
132
133
134
(defmacro excl:errorset (form &optional announce catch-breaks)
  "Return NIL if FORM signals an error, T and values as multiple
values otherwise."
  (declare (ignore announce catch-breaks))
  (let ((result (gensym "RESULT")))
    `(let ((,result (multiple-value-list (ignore-errors ,form))))
       (if (not (first ,result))
           nil
           (values-list (list* t ,result))))))
Zach Beane's avatar
Zach Beane committed
135

Zach Beane's avatar
Zach Beane committed
136
137
138
139
140
141
(defun excl:delimited-string-to-list (string delimiter)
  (unless (characterp delimiter)
    ;; aserve only uses a character
    (error "Unsupported delimiter -- ~A" delimiter))
  (split-sequence delimiter string))

Zach Beane's avatar
Zach Beane committed
142
(defun excl:stream-input-fn (stream)
Zach Beane's avatar
Zach Beane committed
143
  "Return the underlying Unix input FD of STREAM."
144
  (stream-unix-fd stream))
Zach Beane's avatar
Zach Beane committed
145

146
147
148
149
150
151
152
153
154
(defun excl::filesys-size (fd)
  (fstat-size fd))

(defun excl::filesys-write-date (fd)
  (fstat-mtime fd))

(defun excl::filesys-type (native-namestring)
  (file-kind native-namestring))

155
156
157
158
159
160
(defun excl.osi:stat (file)
  (list :mtime (stat-mtime file)))

(defun excl.osi:stat-mtime (stat)
  (getf stat :mtime))

161
162
(defun excl:find-external-format (name &key errorp)
  (declare (ignore errorp))
163
164
165
166
167
168
169
170
  (declare (ignore name))
  :latin-1)

(defun excl:crlf-base-ef (external-format)
  external-format)

(defun excl:ef-name (external-format)
  external-format)
171

Zach Beane's avatar
Zach Beane committed
172
(defun excl:fixnump (integer)
173
174
175
176
  (typep integer 'fixnum))

(defun excl:split-into-words (string)
  (split "\\s+" string))
Zach Beane's avatar
Zach Beane committed
177

178
179
(defun excl:split-on-character (string character)
  (split-sequence character string))
Zach Beane's avatar
Zach Beane committed
180
181
182
183
184
185
186
187

(defmacro excl::with-dynamic-extent-usb8-array ((var len) &body body)
  `(let ((,var (make-array ,len :element-type '(unsigned-byte 8))))
     ,@body))

(defun excl:native-string-sizeof (string &key (external-format :latin1))
  (length (string-to-octets string :external-format external-format)))

188
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
Zach Beane's avatar
Zach Beane committed
189
190
191
  (declare (ignore mb-vector))
  (when null-terminate
    (error "Cannot null-terminate"))
192
193
  (string-to-octets string
                    :external-format (translate-external-format external-format)))
Zach Beane's avatar
Zach Beane committed
194

195
196
197
(defun excl:string-to-octets (string &key external-format null-terminate)
  (when null-terminate
    (error "No null terminating!"))
198
199
200
201
  (string-to-octets string
                    :external-format (translate-external-format external-format)))

(defun excl:mb-to-string (string &key external-format (start 0)
Zach Beane's avatar
Zach Beane committed
202
203
                                   (end (length string)))
  (octets-to-string string
204
                    :external-format (translate-external-format external-format)
Zach Beane's avatar
Zach Beane committed
205
206
207
                    :start start
                    :end end))

208
(defun excl:octets-to-string (octets &key external-format
209
                                       string string-start string-end truncate
210
                                       (start 0) (end (length octets)))
211
212
  (when (or string string-start string-end truncate)
    (error "Unsupported options given to excl:octets-to-string"))
213
  (octets-to-string octets
214
215
                    :start start
                    :end end
216
217
                    :external-format (translate-external-format external-format)))

Zach Beane's avatar
Zach Beane committed
218
(defun excl:schedule-finalization (object fun)
Zach Beane's avatar
Zach Beane committed
219
220
221
  ;; Doesn't work; semantics differ.
  ;; (finalize object fun))
  (declare (ignore object fun)))
Zach Beane's avatar
Zach Beane committed
222
223
224

(defun excl::unix-signal (signal-number action)
  (declare (ignore signal-number action)))
Zach Beane's avatar
Zach Beane committed
225
226

(defmacro excl:without-package-locks (&body body)
227
  #-sbcl
Zach Beane's avatar
Zach Beane committed
228
229
230
  `(progn ,@body)
  #+sbcl
  `(without-package-locks ,@body))
231

Zach Beane's avatar
Zach Beane committed
232
(defmacro excl:without-interrupts (&body body)
233
234
235
  #+(or ccl sbcl)
  `(without-interrupts ,@body)
  #-(or ccl sbcl)
Zach Beane's avatar
Zach Beane committed
236
237
  `(progn ,@body))

238
239
240
(defmacro excl:defvar-nonbindable (name value &optional doc)
  #+sbcl
  `(defglobal ,name ,value ,@(if doc (list doc)))
241
242
243
  #+ccl
  `(defstaticvar ,name ,value ,@(if doc (list doc)) )
  #-(or ccl sbcl)
244
245
  `(defvar ,name ,value ,@(if doc  (list doc))))

246
247
248
249
250
251
252
253
254
255
256
257
258
259
(defclass excl:lockable-object ()
  ((lock
    :initarg :lock
    :reader lock
    :initform (make-lock))))

(defun call-with-locked-object (object fun)
  (let ((lock (lock object)))
    (with-lock-held (lock)
      (funcall fun))))

(defmacro excl:with-locked-object ((object &key type block non-smp) &body body)
  (declare (ignore type block non-smp))
  `(call-with-locked-object ,object (lambda () ,@body)))
260
261
262
263
264
265
266
267

(defstruct excl:synchronizing-structure
  (lock (make-lock)))

(defun call-with-locked-structure (struct fun)
  (with-lock-held ((synchronizing-structure-lock struct))
    (funcall fun)))

268
269
(defmacro excl:with-locked-structure ((struct &key block non-smp) &body body)
  (declare (ignore block non-smp))
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
  `(call-with-locked-structure ,struct (lambda () ,@body)))

(defmacro excl:incf-atomic (place &optional (delta 1))
  #+ccl
  ;; Doesn't work on structure slots on CCL!
  ;;`(atomic-incf-decf ,place ,delta)
  `(incf ,place ,delta)
  ;; XXX
  #-ccl
  `(incf ,place ,delta))

(defmacro excl:decf-atomic (place &optional (delta 1))
  #+ccl
  ;; Doesn't work on structure slots on CCL!
  ;;`(atomic-incf-decf ,place (- ,delta))
  `(decf ,place (- ,delta))
  ;; XXX
  #-ccl
  `(decf ,place (- ,delta)))
289
290
291
292
293
294

(defstruct (basic-lock (:include excl:synchronizing-structure))
  name)

(defun excl::make-basic-lock (&key name)
  (make-basic-lock :name name))
295
296
297
298
299

(define-condition excl:socket-error (error)
  ((identifier
    :initarg :identifier
    :reader excl:stream-error-identifier)))
300
301
302
303
304
305
306
307


;;; Streams

(defgeneric excl:device-open (stream slot-names initargs))
(defgeneric excl:device-close (stream abort))
(defgeneric excl:device-read (stream buffer start end blocking))
(defgeneric excl:device-write (stream buffer start end blocking))
Zach Beane's avatar
Zach Beane committed
308
309
310
(defgeneric excl:install-single-channel-character-strategy (stream format &optional default)
  (:method (stream format &optional default)
    (declare (ignore stream format default))))
311
312
313

(defvar excl::*std-control-out-table* nil)

Zach Beane's avatar
Zach Beane committed
314
315
316
317
318
319
320
321
322
323
324
325
326
327
(defclass zacl-simple-stream (fundamental-binary-output-stream
                              fundamental-binary-input-stream)
  ())

(defmethod stream-write-char ((stream zacl-simple-stream) char)
  (let ((buffer (string-to-octets (string char))))
    (excl:device-write stream buffer 0 (length buffer) nil)))

(defmethod stream-write-byte ((stream zacl-simple-stream) byte)
  (let ((buffer (make-array 1 :element-type '(unsigned-byte 8)
                            :initial-element byte)))
    (excl:device-write stream buffer 0 1 nil)))

(defclass excl:single-channel-simple-stream (zacl-simple-stream)
328
329
  ((excl::buffer
    :initform (make-array 1024 :element-type '(unsigned-byte 8)))
330
331
332
   (excl::output-handle
    :initarg :output-handle)
   (excl::input-handle
333
334
    :initarg :input-handle
    :reader excl::stream-input-handle)
335
336
   (excl::buffer-ptr)
   (excl::control-out)
Zach Beane's avatar
Zach Beane committed
337
   (excl::oc-state)
338
339
340
341
342
343
344
345
346
347
348
   (external-format
    :initarg :external-format
    :initform :default
    :accessor zacl-cl:stream-external-format)))

(defmethod shared-initialize :after ((stream
                                      excl:single-channel-simple-stream)
                                     slot-names
                                     &rest initargs &key &allow-other-keys)
  (excl:device-open stream slot-names initargs))

Zach Beane's avatar
Zach Beane committed
349
350
351
352
353
(defmethod close ((stream excl:single-channel-simple-stream) &key abort)
  (excl:device-close stream abort))



Zach Beane's avatar
Zach Beane committed
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
(defgeneric underlying-output-stream (stream)
  (:method ((stream excl:single-channel-simple-stream))
    (underlying-output-stream (slot-value stream 'excl::output-handle)))
  (:method ((stream stream-usocket))
    (socket-stream stream))
  (:method ((stream usocket))
    (socket-stream stream))
  (:method ((stream stream))
    stream))

(defgeneric underlying-input-stream (stream)
  (:method ((stream excl:single-channel-simple-stream))
    (underlying-input-stream (slot-value stream 'excl::input-handle)))
  (:method ((stream usocket))
    (socket-stream stream))
  (:method ((stream stream))
    stream))

Zach Beane's avatar
Zach Beane committed
372
(defmethod stream-write-string ((stream excl:single-channel-simple-stream) string &optional start end)
373
374
  (unless start (setf start 0))
  (unless end (setf end (length string)))
Zach Beane's avatar
Zach Beane committed
375
376
  (let ((buffer (string-to-octets string :start start :end end)))
    (excl:device-write stream buffer 0 (length buffer) nil)))
377

378
379
380
381
(defmethod stream-write-sequence ((stream excl:single-channel-simple-stream) sequence start end &key &allow-other-keys)
  (excl:device-write stream sequence start end nil))

#+ccl
Zach Beane's avatar
Zach Beane committed
382
383
384
(defmethod ccl:stream-write-vector ((stream excl:single-channel-simple-stream) sequence start end)
  (unless start (setf start 0))
  (unless end (setf end (length sequence)))
385
  (excl:device-write stream sequence start end nil))
Zach Beane's avatar
Zach Beane committed
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401

(defmethod stream-force-output ((stream excl:single-channel-simple-stream))
  (force-output (underlying-output-stream stream)))

(defmethod stream-force-output ((stream usocket))
  (force-output (underlying-output-stream stream)))

(defmethod stream-read-char ((stream usocket))
  (stream-read-char (socket-stream stream)))

(defmethod stream-read-byte ((stream usocket))
  (stream-read-byte (socket-stream stream)))

(defmethod cl:close ((stream usocket) &key abort)
  (close (socket-stream stream) :abort abort))

402
403
404
405
406
407
408
(defmacro excl:add-stream-instance-flags (stream &rest flags)
  (declare (ignore stream flags))
  nil)

(defun excl:write-vector (vector stream &key (start 0) (end (length vector)))
  ;; The real write-vector has more complicated blocking
  ;; behavior. Save that for later.
Zach Beane's avatar
Zach Beane committed
409
410
  (when (stringp vector)
    (setf vector (string-to-octets vector :start start :end end)))
411
412
413
  (write-sequence vector stream :start start :end end)
  end)

414
415
416
417
(defun excl:read-vector (vector stream &key (start 0) end endian-swap)
  (declare (ignore endian-swap))
  (read-sequence vector stream :start start :end end))

Zach Beane's avatar
Zach Beane committed
418
419
420
421
422
423
424
425
426
427
(defmethod excl::socket-bytes-written (socket &optional set)
  (declare (ignore socket))
  (or set
      42))

(defmacro excl:pop-atomic (place)
  `(pop ,place))

(defmacro excl:push-atomic (value place)
  `(push ,value ,place ))
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461


;;; MD5

(defun excl:md5-init ()
  (make-md5-state))

(defun excl:md5-update (state data &key (start 0) end external-format)
  (when (stringp data)
    (setf data (string-to-octets data
                                 :external-format (or external-format :latin-1)
                                 :start start
                                 :end (or end (length data))))
    (setf start 0)
    (setf end (length data)))
  (update-md5-state state data :start start :end end)
  (values))

(defun excl:md5-final (state &key (return :integer))
  (let ((result (finalize-md5-state state)))
    (ecase return
      (:usb8
       result)
      (:hex
       (with-output-to-string (s)
         (map nil (lambda (octet)
                    (format s "~2,'0X" octet))
              result)))
      (:integer
       (let ((i 0))
         (map nil (lambda (octet)
                    (setf i (logior (ash i 8) octet)))
              result)
         i)))))
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479

;;; FASL

(defun excl:fasl-write (object stream &optional fasl-circle compile-verbose)
  (declare (ignore compile-verbose))
  (let ((*check-for-circs* fasl-circle))
    ;; This conversion is used because calls to EXCL:FASL-WRITE assume
    ;; a bivalent stream while passing a character stream. May not
    ;; matter, because it's not in a hot spot - just called at proxy
    ;; shutdown.
    (let ((octets
           (with-output-to-sequence (s)
             (store object stream))))
      (write-string (octets-to-string octets :external-format :latin-1) stream))))

(defun excl:fasl-read (file)
  (with-open-file (stream file :element-type '(unsigned-byte 8))
    (restore stream)))