package-excl.lisp 15.5 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
(defstruct excl::ssl-context)

121
122
123
124
125
126
127
(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))

128
129
130
131
132
133
134
135
136
(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
137

Zach Beane's avatar
Zach Beane committed
138
139
140
141
142
143
(defun excl:run-shell-command (program
                               &key input output error-output separate-streams
                                 wait environment show-window)
  (declare (ignore program input output error-output separate-streams wait environment show-window))
  (error "Not implemented -- RUN-SHELL-COMMAND"))

Zach Beane's avatar
Zach Beane committed
144
145
146
(defun excl::merge-to-physical (pathname)
  (merge-pathnames (translate-logical-pathname pathname)))

Zach Beane's avatar
Zach Beane committed
147
148
149
150
151
152
153
(defun excl:rename-file-raw (file new-name)
  (let ((new-name (merge-pathnames new-name
                                   (make-pathname :name :unspecific
                                                  :type :unspecific
                                                  :defaults *default-pathname-defaults*))))
    (rename-file file new-name)))

Zach Beane's avatar
Zach Beane committed
154
155
156
157
158
159
(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
160
(defun excl:stream-input-fn (stream)
Zach Beane's avatar
Zach Beane committed
161
  "Return the underlying Unix input FD of STREAM."
162
  (stream-unix-fd stream))
Zach Beane's avatar
Zach Beane committed
163

164
165
166
167
168
169
170
171
172
(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))

173
174
175
176
177
178
(defun excl.osi:stat (file)
  (list :mtime (stat-mtime file)))

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

179
180
(defun excl:find-external-format (name &key errorp)
  (declare (ignore errorp))
181
182
183
184
185
186
187
188
  (declare (ignore name))
  :latin-1)

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

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

Zach Beane's avatar
Zach Beane committed
190
(defun excl:fixnump (integer)
191
192
193
194
  (typep integer 'fixnum))

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

196
197
(defun excl:split-on-character (string character)
  (split-sequence character string))
Zach Beane's avatar
Zach Beane committed
198
199
200
201
202
203
204
205

(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)))

206
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
Zach Beane's avatar
Zach Beane committed
207
208
209
  (declare (ignore mb-vector))
  (when null-terminate
    (error "Cannot null-terminate"))
210
211
  (string-to-octets string
                    :external-format (translate-external-format external-format)))
Zach Beane's avatar
Zach Beane committed
212

213
214
215
(defun excl:string-to-octets (string &key external-format null-terminate)
  (when null-terminate
    (error "No null terminating!"))
216
217
218
219
  (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
220
221
                                   (end (length string)))
  (octets-to-string string
222
                    :external-format (translate-external-format external-format)
Zach Beane's avatar
Zach Beane committed
223
224
225
                    :start start
                    :end end))

226
(defun excl:octets-to-string (octets &key external-format
227
                                       string string-start string-end truncate
228
                                       (start 0) (end (length octets)))
229
230
  (when (or string string-start string-end truncate)
    (error "Unsupported options given to excl:octets-to-string"))
231
  (octets-to-string octets
232
233
                    :start start
                    :end end
234
235
                    :external-format (translate-external-format external-format)))

Zach Beane's avatar
Zach Beane committed
236
(defun excl:schedule-finalization (object fun)
Zach Beane's avatar
Zach Beane committed
237
238
239
  ;; Doesn't work; semantics differ.
  ;; (finalize object fun))
  (declare (ignore object fun)))
Zach Beane's avatar
Zach Beane committed
240
241
242

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

(defmacro excl:without-package-locks (&body body)
245
  #-sbcl
Zach Beane's avatar
Zach Beane committed
246
247
248
  `(progn ,@body)
  #+sbcl
  `(without-package-locks ,@body))
249

Zach Beane's avatar
Zach Beane committed
250
(defmacro excl:without-interrupts (&body body)
251
252
253
  #+(or ccl sbcl)
  `(without-interrupts ,@body)
  #-(or ccl sbcl)
Zach Beane's avatar
Zach Beane committed
254
255
  `(progn ,@body))

256
257
258
(defmacro excl:defvar-nonbindable (name value &optional doc)
  #+sbcl
  `(defglobal ,name ,value ,@(if doc (list doc)))
259
260
261
  #+ccl
  `(defstaticvar ,name ,value ,@(if doc (list doc)) )
  #-(or ccl sbcl)
262
263
  `(defvar ,name ,value ,@(if doc  (list doc))))

264
265
266
267
268
269
270
271
272
273
274
275
276
277
(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)))
278
279
280
281
282
283
284
285

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

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

286
287
(defmacro excl:with-locked-structure ((struct &key block non-smp) &body body)
  (declare (ignore block non-smp))
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
  `(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)))
307
308
309
310
311
312

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

(defun excl::make-basic-lock (&key name)
  (make-basic-lock :name name))
313
314
315
316
317

(define-condition excl:socket-error (error)
  ((identifier
    :initarg :identifier
    :reader excl:stream-error-identifier)))
318
319
320
321
322
323
324
325


;;; 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
326
327
328
(defgeneric excl:install-single-channel-character-strategy (stream format &optional default)
  (:method (stream format &optional default)
    (declare (ignore stream format default))))
329
330
331

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

Zach Beane's avatar
Zach Beane committed
332
333
334
335
336
337
338
339
340
341
342
343
344
345
(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)
346
347
  ((excl::buffer
    :initform (make-array 1024 :element-type '(unsigned-byte 8)))
348
349
350
   (excl::output-handle
    :initarg :output-handle)
   (excl::input-handle
351
352
    :initarg :input-handle
    :reader excl::stream-input-handle)
353
354
   (excl::buffer-ptr)
   (excl::control-out)
Zach Beane's avatar
Zach Beane committed
355
   (excl::oc-state)
356
357
358
359
360
361
362
363
364
365
366
   (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
367
368
369
370
371
(defmethod close ((stream excl:single-channel-simple-stream) &key abort)
  (excl:device-close stream abort))



Zach Beane's avatar
Zach Beane committed
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
(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
390
(defmethod stream-write-string ((stream excl:single-channel-simple-stream) string &optional start end)
391
392
  (unless start (setf start 0))
  (unless end (setf end (length string)))
Zach Beane's avatar
Zach Beane committed
393
394
  (let ((buffer (string-to-octets string :start start :end end)))
    (excl:device-write stream buffer 0 (length buffer) nil)))
395

396
397
398
399
(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
400
401
402
(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)))
403
  (excl:device-write stream sequence start end nil))
Zach Beane's avatar
Zach Beane committed
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419

(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))

420
421
422
423
424
425
426
(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
427
428
  (when (stringp vector)
    (setf vector (string-to-octets vector :start start :end end)))
429
430
431
  (write-sequence vector stream :start start :end end)
  end)

432
433
434
435
(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
436
437
438
439
440
441
442
443
444
445
(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 ))
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479


;;; 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)))))
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497

;;; 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)))