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

Zach Beane's avatar
Zach Beane committed
45
(defun excl:match-re (pattern string &key (return :string) case-fold)
46
  (multiple-value-bind (start end regs-starts regs-ends)
Zach Beane's avatar
Zach Beane committed
47
      (scan (create-scanner pattern :case-insensitive-mode case-fold) string )
48
49
50
51
52
53
54
55
56
    (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
57
58
59
                                  regs-ends))))
        ((nil)
         t)))))
Zach Beane's avatar
Zach Beane committed
60

61
62
(defun excl:match-regexp (pattern string &key (return :string))
  (excl:match-re pattern string :return return))
Zach Beane's avatar
Zach Beane committed
63

Zach Beane's avatar
Zach Beane committed
64
65
66
(defun excl:compile-regexp (pattern)
  (create-scanner pattern))

Zach Beane's avatar
Zach Beane committed
67
68
69
70

(defmacro excl:with-output-to-buffer ((stream) &body body)
  `(with-output-to-sequence (,stream)
     ,@body))
Zach Beane's avatar
Zach Beane committed
71
72
73
74
75
76


;;; Streams

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

78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
(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)
95

96
97
98
99
100
101
102
103
#+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))

104
105
106
107
108
109
110
111
112
113
114
;;; Misc

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

116
117
(defun excl:find-external-format (name &key errorp)
  (declare (ignore errorp))
118
119
120
121
122
123
124
125
  (declare (ignore name))
  :latin-1)

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

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

Zach Beane's avatar
Zach Beane committed
127
(defun excl:fixnump (integer)
128
129
130
131
  (typep integer 'fixnum))

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

133
134
(defun excl:split-on-character (string character)
  (split-sequence character string))
Zach Beane's avatar
Zach Beane committed
135
136
137
138
139
140
141
142

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

143
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
Zach Beane's avatar
Zach Beane committed
144
145
146
  (declare (ignore mb-vector))
  (when null-terminate
    (error "Cannot null-terminate"))
147
148
  (string-to-octets string
                    :external-format (translate-external-format external-format)))
Zach Beane's avatar
Zach Beane committed
149

150
151
152
(defun excl:string-to-octets (string &key external-format null-terminate)
  (when null-terminate
    (error "No null terminating!"))
153
154
155
156
  (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
157
158
                                   (end (length string)))
  (octets-to-string string
159
                    :external-format (translate-external-format external-format)
Zach Beane's avatar
Zach Beane committed
160
161
162
                    :start start
                    :end end))

163
(defun excl:octets-to-string (octets &key external-format
164
                                       string string-start string-end truncate
165
                                       (start 0) (end (length octets)))
166
167
  (when (or string string-start string-end truncate)
    (error "Unsupported options given to excl:octets-to-string"))
168
  (octets-to-string octets
169
170
                    :start start
                    :end end
171
172
                    :external-format (translate-external-format external-format)))

Zach Beane's avatar
Zach Beane committed
173
(defun excl:schedule-finalization (object fun)
Zach Beane's avatar
Zach Beane committed
174
175
176
  ;; Doesn't work; semantics differ.
  ;; (finalize object fun))
  (declare (ignore object fun)))
Zach Beane's avatar
Zach Beane committed
177
178
179

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

(defmacro excl:without-package-locks (&body body)
182
  #-sbcl
Zach Beane's avatar
Zach Beane committed
183
184
185
  `(progn ,@body)
  #+sbcl
  `(without-package-locks ,@body))
186

Zach Beane's avatar
Zach Beane committed
187
(defmacro excl:without-interrupts (&body body)
188
189
190
  #+(or ccl sbcl)
  `(without-interrupts ,@body)
  #-(or ccl sbcl)
Zach Beane's avatar
Zach Beane committed
191
192
  `(progn ,@body))

193
194
195
(defmacro excl:defvar-nonbindable (name value &optional doc)
  #+sbcl
  `(defglobal ,name ,value ,@(if doc (list doc)))
196
197
198
  #+ccl
  `(defstaticvar ,name ,value ,@(if doc (list doc)) )
  #-(or ccl sbcl)
199
200
  `(defvar ,name ,value ,@(if doc  (list doc))))

201
202
203
204
205
206
207
208
209
210
211
212
213
214
(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)))
215
216
217
218
219
220
221
222

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

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

223
224
(defmacro excl:with-locked-structure ((struct &key block non-smp) &body body)
  (declare (ignore block non-smp))
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
  `(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)))
244
245
246
247
248
249

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

(defun excl::make-basic-lock (&key name)
  (make-basic-lock :name name))
250
251
252
253
254

(define-condition excl:socket-error (error)
  ((identifier
    :initarg :identifier
    :reader excl:stream-error-identifier)))
255
256
257
258
259
260
261
262


;;; 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
263
264
265
(defgeneric excl:install-single-channel-character-strategy (stream format &optional default)
  (:method (stream format &optional default)
    (declare (ignore stream format default))))
266
267
268

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

Zach Beane's avatar
Zach Beane committed
269
270
271
272
273
274
275
276
277
278
279
280
281
282
(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)
283
284
  ((excl::buffer
    :initform (make-array 1024 :element-type '(unsigned-byte 8)))
285
286
287
   (excl::output-handle
    :initarg :output-handle)
   (excl::input-handle
288
289
    :initarg :input-handle
    :reader excl::stream-input-handle)
290
291
   (excl::buffer-ptr)
   (excl::control-out)
Zach Beane's avatar
Zach Beane committed
292
   (excl::oc-state)
293
294
295
296
297
298
299
300
301
302
303
   (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
304
305
306
307
308
(defmethod close ((stream excl:single-channel-simple-stream) &key abort)
  (excl:device-close stream abort))



Zach Beane's avatar
Zach Beane committed
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
(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
327
(defmethod stream-write-string ((stream excl:single-channel-simple-stream) string &optional start end)
328
329
  (unless start (setf start 0))
  (unless end (setf end (length string)))
Zach Beane's avatar
Zach Beane committed
330
331
  (let ((buffer (string-to-octets string :start start :end end)))
    (excl:device-write stream buffer 0 (length buffer) nil)))
332

333
334
335
336
(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
337
338
339
(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)))
340
  (excl:device-write stream sequence start end nil))
Zach Beane's avatar
Zach Beane committed
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356

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

357
358
359
360
361
362
363
(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
364
365
  (when (stringp vector)
    (setf vector (string-to-octets vector :start start :end end)))
366
367
368
  (write-sequence vector stream :start start :end end)
  end)

369
370
371
372
(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
373
374
375
376
377
378
379
380
381
382
(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 ))
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416


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