summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Lisp/libobjcl.lisp152
-rw-r--r--Lisp/type-handling.lisp170
-rw-r--r--objective-cl.asd4
3 files changed, 174 insertions, 152 deletions
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 92a3f16..eeb6d0d 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -497,158 +497,6 @@ If *selector-designator* is a __selector__, it is simply returned.
(error (make-condition 'no-such-selector :designator designator))))))
-(defun parse-typespec (typestring &optional (start 0))
- "Parse a typestring like \"@0:4{_NSRange=II}8\" into something like (ID ()).
-
-\"rn{_NSRange=II}8\" is parsed into (STRUCT (CONST IN)
-\"_NSRange\" :INTEGER :INTEGER).
-
-Returns: (VALUES typespec byte-position string-position)"
-
- (let ((init-char (char typestring start))
- (string-position start)
- (qualifiers (list)))
- (loop do (setq init-char (char typestring string-position))
- while (let ((qualifier (case init-char
- (#\r 'const)
- (#\n 'in)
- (#\N 'inout)
- (#\o 'out)
- (#\O 'bycopy)
- (#\V 'oneway)
- (#\R 'byref))))
- (and qualifier
- (incf string-position)
- (push qualifier qualifiers))))
- (values (case init-char
- ((#\{ #\()
- (let* ((=-token (position #\= typestring :start start))
- (name-end (or =-token
- ;; An opaque struct whose contents
- ;; we don't know.
- (position (ecase init-char
- (#\{ #\})
- (#\( #\)))
- typestring
- :start start)
- (error "Premature end of file in~
- typespec: ~A."
- typestring)))
- (struct-name (subseq typestring
- (1+ string-position)
- name-end)))
- (list* (ecase init-char
- (#\{ 'struct)
- (#\( 'union))
- (if =-token
- qualifiers
- (cons 'opaque qualifiers))
- struct-name
- (progn
- (setq string-position
- (if =-token
- (1+ name-end) ; skip #\=
- name-end))
- (loop until (char= (char typestring string-position)
- (ecase init-char
- (#\{ #\})
- (#\( #\))))
- collect (multiple-value-bind (typespec
- byte-position
- new-string-pos)
- (parse-typespec
- typestring
- string-position)
- (declare (ignore byte-position))
- (setq string-position new-string-pos)
- typespec)
- ;; Skip end marker (right brace/paren).
- finally (incf string-position))))))
- (#\^ (list 'pointer
- qualifiers
- (multiple-value-bind (typespec byte-pos new-str-pos)
- (parse-typespec typestring (1+ string-position))
- (declare (ignore byte-pos))
- (prog1 typespec
- (setq string-position new-str-pos)))))
- (#\[ (list 'array
- qualifiers
- (multiple-value-bind (count new-str-pos)
- (parse-integer typestring
- :start (1+ string-position)
- :junk-allowed t)
- (prog1 count
- (setq string-position new-str-pos)))
- (multiple-value-bind (typespec byte-pos new-str-pos)
- (parse-typespec typestring string-position)
- (declare (ignore byte-pos))
- ;; Skip end marker (right bracket).
- (prog1 typespec
- (setq string-position (1+ new-str-pos))))))
- (#\j
- (list 'complex
- qualifiers
- (multiple-value-bind (typespec byte-pos new-str-pos)
- (parse-typespec typestring (1+ string-position))
- (declare (ignore byte-pos))
- (prog1 typespec
- (setq string-position new-str-pos)))))
- (#\b
- (let (bit-field-starting-pos
- bit-field-typespec
- bit-field-length
- byte-position)
- (multiple-value-setq (bit-field-starting-pos string-position)
- (parse-integer typestring
- :start (1+ string-position)
- :junk-allowed t))
- (multiple-value-setq (bit-field-typespec
- byte-position
- string-position)
- (parse-typespec typestring string-position))
- (multiple-value-setq (bit-field-length string-position)
- (parse-integer typestring
- :start string-position
- :junk-allowed t))
- (list 'bit-field
- qualifiers
- bit-field-starting-pos
- bit-field-length
- bit-field-typespec)))
- (otherwise
- (prog1 (list (case init-char
- (#\B :boolean)
- (#\c :char)
- (#\C :unsigned-char)
- (#\s :short)
- (#\S :unsigned-short)
- (#\i :int)
- (#\I :unsigned-int)
- (#\l :long)
- (#\L :unsigned-long)
- (#\q :long-long)
- (#\Q :unsigned-long-long)
- (#\f :float)
- (#\d :double)
- (#\v :void)
- (#\@ 'id)
- (#\# 'objc-class)
- (#\: 'selector)
- (#\* :string)
- (#\? :unknown))
- qualifiers)
- (incf string-position))))
- #+(or) ; too greedy (=> bit-fields can't see their length!)
- (multiple-value-bind (byte-position new-string-pos)
- (parse-integer typestring
- :start string-position
- :junk-allowed t)
- (setq string-position new-string-pos)
- byte-position)
- #-(or) nil
- string-position)))
-
-
;;;; (@* "Helper functions")
(defun sizeof (typespec)
(%objcl-sizeof-type typespec))
diff --git a/Lisp/type-handling.lisp b/Lisp/type-handling.lisp
new file mode 100644
index 0000000..152a016
--- /dev/null
+++ b/Lisp/type-handling.lisp
@@ -0,0 +1,170 @@
+;;;; Objective-CL, an Objective-C bridge for Common Lisp.
+;;;; Copyright (C) 2007 Matthias Andreas Benkard.
+;;;;
+;;;; This program is free software: you can redistribute it and/or
+;;;; modify it under the terms of the GNU General Public License as
+;;;; published by the Free Software Foundation, either version 3 of the
+;;;; License, or (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful, but
+;;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program. If not, see
+;;;; <http://www.gnu.org/licenses/>.
+
+(in-package #:mulk.objective-cl)
+
+
+(defun parse-typespec (typestring &optional (start 0))
+ "Parse a typestring like \"@0:4{_NSRange=II}8\" into something like (ID ()).
+
+\"rn{_NSRange=II}8\" is parsed into (STRUCT (CONST IN)
+\"_NSRange\" :INTEGER :INTEGER).
+
+Returns: (VALUES typespec byte-position string-position)"
+
+ (let ((init-char (char typestring start))
+ (string-position start)
+ (qualifiers (list)))
+ (loop do (setq init-char (char typestring string-position))
+ while (let ((qualifier (case init-char
+ (#\r 'const)
+ (#\n 'in)
+ (#\N 'inout)
+ (#\o 'out)
+ (#\O 'bycopy)
+ (#\V 'oneway)
+ (#\R 'byref))))
+ (and qualifier
+ (incf string-position)
+ (push qualifier qualifiers))))
+ (values (case init-char
+ ((#\{ #\()
+ (let* ((=-token (position #\= typestring :start start))
+ (name-end (or =-token
+ ;; An opaque struct whose contents
+ ;; we don't know.
+ (position (ecase init-char
+ (#\{ #\})
+ (#\( #\)))
+ typestring
+ :start start)
+ (error "Premature end of file in~
+ typespec: ~A."
+ typestring)))
+ (struct-name (subseq typestring
+ (1+ string-position)
+ name-end)))
+ (list* (ecase init-char
+ (#\{ 'struct)
+ (#\( 'union))
+ (if =-token
+ qualifiers
+ (cons 'opaque qualifiers))
+ struct-name
+ (progn
+ (setq string-position
+ (if =-token
+ (1+ name-end) ; skip #\=
+ name-end))
+ (loop until (char= (char typestring string-position)
+ (ecase init-char
+ (#\{ #\})
+ (#\( #\))))
+ collect (multiple-value-bind (typespec
+ byte-position
+ new-string-pos)
+ (parse-typespec
+ typestring
+ string-position)
+ (declare (ignore byte-position))
+ (setq string-position new-string-pos)
+ typespec)
+ ;; Skip end marker (right brace/paren).
+ finally (incf string-position))))))
+ (#\^ (list 'pointer
+ qualifiers
+ (multiple-value-bind (typespec byte-pos new-str-pos)
+ (parse-typespec typestring (1+ string-position))
+ (declare (ignore byte-pos))
+ (prog1 typespec
+ (setq string-position new-str-pos)))))
+ (#\[ (list 'array
+ qualifiers
+ (multiple-value-bind (count new-str-pos)
+ (parse-integer typestring
+ :start (1+ string-position)
+ :junk-allowed t)
+ (prog1 count
+ (setq string-position new-str-pos)))
+ (multiple-value-bind (typespec byte-pos new-str-pos)
+ (parse-typespec typestring string-position)
+ (declare (ignore byte-pos))
+ ;; Skip end marker (right bracket).
+ (prog1 typespec
+ (setq string-position (1+ new-str-pos))))))
+ (#\j
+ (list 'complex
+ qualifiers
+ (multiple-value-bind (typespec byte-pos new-str-pos)
+ (parse-typespec typestring (1+ string-position))
+ (declare (ignore byte-pos))
+ (prog1 typespec
+ (setq string-position new-str-pos)))))
+ (#\b
+ (let (bit-field-starting-pos
+ bit-field-typespec
+ bit-field-length
+ byte-position)
+ (multiple-value-setq (bit-field-starting-pos string-position)
+ (parse-integer typestring
+ :start (1+ string-position)
+ :junk-allowed t))
+ (multiple-value-setq (bit-field-typespec
+ byte-position
+ string-position)
+ (parse-typespec typestring string-position))
+ (multiple-value-setq (bit-field-length string-position)
+ (parse-integer typestring
+ :start string-position
+ :junk-allowed t))
+ (list 'bit-field
+ qualifiers
+ bit-field-starting-pos
+ bit-field-length
+ bit-field-typespec)))
+ (otherwise
+ (prog1 (list (case init-char
+ (#\B :boolean)
+ (#\c :char)
+ (#\C :unsigned-char)
+ (#\s :short)
+ (#\S :unsigned-short)
+ (#\i :int)
+ (#\I :unsigned-int)
+ (#\l :long)
+ (#\L :unsigned-long)
+ (#\q :long-long)
+ (#\Q :unsigned-long-long)
+ (#\f :float)
+ (#\d :double)
+ (#\v :void)
+ (#\@ 'id)
+ (#\# 'objc-class)
+ (#\: 'selector)
+ (#\* :string)
+ (#\? :unknown))
+ qualifiers)
+ (incf string-position))))
+ #+(or) ; too greedy (=> bit-fields can't see their length!)
+ (multiple-value-bind (byte-position new-string-pos)
+ (parse-integer typestring
+ :start string-position
+ :junk-allowed t)
+ (setq string-position new-string-pos)
+ byte-position)
+ #-(or) nil
+ string-position))) \ No newline at end of file
diff --git a/objective-cl.asd b/objective-cl.asd
index b195e3c..21d9e6f 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -43,7 +43,11 @@
"memory-management"))
(:file "init" :depends-on ("defpackage"
"libobjcl"))
+ (:file "type-handling" :depends-on ("defpackage"
+ "libobjcl"
+ "init"))
(:file "method-invocation" :depends-on ("defpackage"
+ "type-handling"
"name-conversion"
"data-types"
"libobjcl"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-16 09:11:23 +0000