package-excl.lisp 15.9 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

138
139
140
(defun excl::tilde-expand-unix-namestring (namestring)
  (merge-pathnames namestring))

Zach Beane's avatar
Zach Beane committed
141
142
143
144
145
146
(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
147
148
149
(defun excl::merge-to-physical (pathname)
  (merge-pathnames (translate-logical-pathname pathname)))

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

167
168
169
(defun excl::filesys-size (fd)
  (fstat-size fd))

170
171
172
(defvar *unix-epoch-universal-time*
  (encode-universal-time 0 0 0 1 1 1970 0))

173
(defun excl::filesys-write-date (fd)
174
  (+ *unix-epoch-universal-time* (fstat-mtime fd)))
175
176
177
178

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

179
180
181
182
183
184
(defun excl.osi:stat (file)
  (list :mtime (stat-mtime file)))

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

185
186
(defun excl:find-external-format (name &key errorp)
  (declare (ignore errorp))
187
188
189
190
191
192
193
194
  (declare (ignore name))
  :latin-1)

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

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

Zach Beane's avatar
Zach Beane committed
196
(defun excl:fixnump (integer)
197
198
199
200
  (typep integer 'fixnum))

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

202
203
(defun excl:split-on-character (string character)
  (split-sequence character string))
Zach Beane's avatar
Zach Beane committed
204
205
206
207
208
209

(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))
210
  (length (string-to-octets string :external-format (translate-external-format external-format))))
Zach Beane's avatar
Zach Beane committed
211

212
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
Zach Beane's avatar
Zach Beane committed
213
214
  (when null-terminate
    (error "Cannot null-terminate"))
215
216
217
218
219
220
  (let ((result
         (string-to-octets string
                           :external-format (translate-external-format external-format))))
    (if mb-vector
        (replace mb-vector result)
        result)))
Zach Beane's avatar
Zach Beane committed
221

222
223
224
(defun excl:string-to-octets (string &key external-format null-terminate)
  (when null-terminate
    (error "No null terminating!"))
225
226
227
228
  (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
229
230
                                   (end (length string)))
  (octets-to-string string
231
                    :external-format (translate-external-format external-format)
Zach Beane's avatar
Zach Beane committed
232
233
234
                    :start start
                    :end end))

235
(defun excl:octets-to-string (octets &key external-format
236
                                       string string-start string-end truncate
237
                                       (start 0) (end (length octets)))
238
239
  (when (or string string-start string-end truncate)
    (error "Unsupported options given to excl:octets-to-string"))
240
  (octets-to-string octets
241
242
                    :start start
                    :end end
243
244
                    :external-format (translate-external-format external-format)))

Zach Beane's avatar
Zach Beane committed
245
(defun excl:schedule-finalization (object fun)
Zach Beane's avatar
Zach Beane committed
246
247
248
  ;; Doesn't work; semantics differ.
  ;; (finalize object fun))
  (declare (ignore object fun)))
Zach Beane's avatar
Zach Beane committed
249
250
251

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

(defmacro excl:without-package-locks (&body body)
254
  #-sbcl
Zach Beane's avatar
Zach Beane committed
255
256
257
  `(progn ,@body)
  #+sbcl
  `(without-package-locks ,@body))
258

Zach Beane's avatar
Zach Beane committed
259
(defmacro excl:without-interrupts (&body body)
260
261
262
  #+(or ccl sbcl)
  `(without-interrupts ,@body)
  #-(or ccl sbcl)
Zach Beane's avatar
Zach Beane committed
263
264
  `(progn ,@body))

265
266
267
(defmacro excl:defvar-nonbindable (name value &optional doc)
  #+sbcl
  `(defglobal ,name ,value ,@(if doc (list doc)))
268
269
270
  #+ccl
  `(defstaticvar ,name ,value ,@(if doc (list doc)) )
  #-(or ccl sbcl)
271
272
  `(defvar ,name ,value ,@(if doc  (list doc))))

273
274
275
276
277
278
279
280
281
282
283
284
285
286
(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)))
287
288
289
290
291
292
293
294

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

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

295
296
(defmacro excl:with-locked-structure ((struct &key block non-smp) &body body)
  (declare (ignore block non-smp))
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
  `(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)))
316
317
318
319
320
321

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

(defun excl::make-basic-lock (&key name)
  (make-basic-lock :name name))
322
323
324
325
326

(define-condition excl:socket-error (error)
  ((identifier
    :initarg :identifier
    :reader excl:stream-error-identifier)))
327
328
329
330
331
332
333
334


;;; 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
335
336
337
(defgeneric excl:install-single-channel-character-strategy (stream format &optional default)
  (:method (stream format &optional default)
    (declare (ignore stream format default))))
338
339
340

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

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



Zach Beane's avatar
Zach Beane committed
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
(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
399
(defmethod stream-write-string ((stream excl:single-channel-simple-stream) string &optional start end)
400
401
  (unless start (setf start 0))
  (unless end (setf end (length string)))
Zach Beane's avatar
Zach Beane committed
402
403
  (let ((buffer (string-to-octets string :start start :end end)))
    (excl:device-write stream buffer 0 (length buffer) nil)))
404

405
406
407
408
(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
409
410
411
(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)))
412
  (excl:device-write stream sequence start end nil))
Zach Beane's avatar
Zach Beane committed
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428

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

429
430
431
432
433
434
435
(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.
436
437
438
439
440
441
442
  (let ((result end))
    (when (stringp vector)
      (setf vector (string-to-octets vector :start start :end end))
      (setf start 0)
      (setf end (length vector)))
    (write-sequence vector stream :start start :end end)
    result))
443

444
445
446
447
(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
448
449
450
451
452
453
454
455
456
457
(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 ))
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491


;;; 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)))))
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509

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