package-excl.lisp 10 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
17
18
19
(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)
        external-format)))


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
48
49
50
51
52
53
54
55
56
57
(defun excl:match-re (pattern string &key (return :string))
  (multiple-value-bind (start end regs-starts regs-ends)
      (scan pattern string)
    (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
                                  regs-ends))))))))
Zach Beane's avatar
Zach Beane committed
58

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


(defmacro excl:with-output-to-buffer ((stream) &body body)
  `(with-output-to-sequence (,stream)
     ,@body))
Zach Beane's avatar
Zach Beane committed
66
67
68
69
70
71


;;; Streams

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

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
(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)
90
91
92
93
94
95
96
97
98
99
100
101

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

103
104
(defun excl:find-external-format (name &key errorp)
  (declare (ignore errorp))
105
106
107
108
109
110
111
112
  (declare (ignore name))
  :latin-1)

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

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

Zach Beane's avatar
Zach Beane committed
114
(defun excl:fixnump (integer)
115
116
117
118
  (typep integer 'fixnum))

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

120
121
(defun excl:split-on-character (string character)
  (split-sequence character string))
Zach Beane's avatar
Zach Beane committed
122
123
124
125
126
127
128
129

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

130
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
Zach Beane's avatar
Zach Beane committed
131
132
133
  (declare (ignore mb-vector))
  (when null-terminate
    (error "Cannot null-terminate"))
134
135
  (string-to-octets string
                    :external-format (translate-external-format external-format)))
Zach Beane's avatar
Zach Beane committed
136

137
138
139
(defun excl:string-to-octets (string &key external-format null-terminate)
  (when null-terminate
    (error "No null terminating!"))
140
141
142
143
  (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
144
145
                                   (end (length string)))
  (octets-to-string string
146
                    :external-format (translate-external-format external-format)
Zach Beane's avatar
Zach Beane committed
147
148
149
                    :start start
                    :end end))

150
151
(defun excl:octets-to-string (octets &key external-format
                                       (start 0) (end (length octets)))
152
  (octets-to-string octets
153
154
                    :start start
                    :end end
155
156
                    :external-format (translate-external-format external-format)))

Zach Beane's avatar
Zach Beane committed
157
(defun excl:schedule-finalization (object fun)
Zach Beane's avatar
Zach Beane committed
158
159
160
  ;; Doesn't work; semantics differ.
  ;; (finalize object fun))
  (declare (ignore object fun)))
Zach Beane's avatar
Zach Beane committed
161
162
163

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

(defmacro excl:without-package-locks (&body body)
166
  #-sbcl
Zach Beane's avatar
Zach Beane committed
167
168
169
  `(progn ,@body)
  #+sbcl
  `(without-package-locks ,@body))
170

Zach Beane's avatar
Zach Beane committed
171
(defmacro excl:without-interrupts (&body body)
172
173
174
  #+(or ccl sbcl)
  `(without-interrupts ,@body)
  #-(or ccl sbcl)
Zach Beane's avatar
Zach Beane committed
175
176
  `(progn ,@body))

177
178
179
180
181
182
(defmacro excl:defvar-nonbindable (name value &optional doc)
  #+sbcl
  `(defglobal ,name ,value ,@(if doc (list doc)))
  #-sbcl
  `(defvar ,name ,value ,@(if doc  (list doc))))

183
184
185
186
187
188
189
190
191
192
193
194
195
196
(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)))
197
198
199
200
201
202
203
204

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

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

205
206
(defmacro excl:with-locked-structure ((struct &key block non-smp) &body body)
  (declare (ignore block non-smp))
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
  `(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)))
226
227
228
229
230
231

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

(defun excl::make-basic-lock (&key name)
  (make-basic-lock :name name))
232
233
234
235
236

(define-condition excl:socket-error (error)
  ((identifier
    :initarg :identifier
    :reader excl:stream-error-identifier)))
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264


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

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

(defclass excl:single-channel-simple-stream (fundamental-stream)
  ((excl::buffer
    :initform (make-array 1024 :element-type '(unsigned-byte 8)))
   (excl::output-handle)
   (excl::buffer-ptr)
   (excl::control-out)
   (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
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
(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))

283
284
285
(defmethod stream-write-string ((stream excl:single-channel-simple-stream) string &optional start end )
  (unless start (setf start 0))
  (unless end (setf end (length string)))
Zach Beane's avatar
Zach Beane committed
286
  (write-string string (underlying-output-stream stream)
287
288
289
                :start start
                :end end))

Zach Beane's avatar
Zach Beane committed
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
(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)))
  (write-sequence sequence (underlying-output-stream stream)))

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

310
311
312
313
314
315
316
317
318
319
(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.
  (write-sequence vector stream :start start :end end)
  end)

Zach Beane's avatar
Zach Beane committed
320
321
322
323
324
325
326
327
328
329
(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 ))