package-excl.lisp 5.65 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
105
106
(defun excl:find-external-format (name &key errorp)
  (declare (ignore errorp))
  (error "(find-external-format ~S) -- not implemented" name))

Zach Beane's avatar
Zach Beane committed
107
(defun excl:fixnump (integer)
108
109
110
111
  (typep integer 'fixnum))

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

113
114
(defun excl:split-on-character (string character)
  (split-sequence character string))
Zach Beane's avatar
Zach Beane committed
115
116
117
118
119
120
121
122

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

123
(defun excl:string-to-mb (string &key external-format mb-vector null-terminate)
Zach Beane's avatar
Zach Beane committed
124
125
126
  (declare (ignore mb-vector))
  (when null-terminate
    (error "Cannot null-terminate"))
127
128
  (string-to-octets string
                    :external-format (translate-external-format external-format)))
Zach Beane's avatar
Zach Beane committed
129

130
131
132
133
134
(defun excl:string-to-octets (string &key external-format)
  (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
135
136
                                   (end (length string)))
  (octets-to-string string
137
                    :external-format (translate-external-format external-format)
Zach Beane's avatar
Zach Beane committed
138
139
140
                    :start start
                    :end end))

141
142
(defun excl:octets-to-string (octets &key external-format
                                       (start 0) (end (length octets)))
143
  (octets-to-string octets
144
145
                    :start start
                    :end end
146
147
                    :external-format (translate-external-format external-format)))

Zach Beane's avatar
Zach Beane committed
148
149
(defun excl:schedule-finalization (object fun)
  (finalize object fun))
Zach Beane's avatar
Zach Beane committed
150
151
152

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

(defmacro excl:without-package-locks (&body body)
155
  #-sbcl
Zach Beane's avatar
Zach Beane committed
156
157
158
  `(progn ,@body)
  #+sbcl
  `(without-package-locks ,@body))
159

Zach Beane's avatar
Zach Beane committed
160
(defmacro excl:without-interrupts (&body body)
161
162
163
  #+(or ccl sbcl)
  `(without-interrupts ,@body)
  #-(or ccl sbcl)
Zach Beane's avatar
Zach Beane committed
164
165
  `(progn ,@body))

166
167
168
169
170
171
(defmacro excl:defvar-nonbindable (name value &optional doc)
  #+sbcl
  `(defglobal ,name ,value ,@(if doc (list doc)))
  #-sbcl
  `(defvar ,name ,value ,@(if doc  (list doc))))

172
173
174
175
176
177
178
179
180
181
182
183
184
185
(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)))