3 ;;; Implementation for property sets
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensible Object Design, an object system for C.
12 ;;; SOD is free software; you can redistribute it and/or modify
13 ;;; it under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 2 of the License, or
15 ;;; (at your option) any later version.
17 ;;; SOD is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with SOD; if not, write to the Free Software Foundation,
24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
28 ;;;--------------------------------------------------------------------------
29 ;;; Conversion utilities.
31 (defun string-to-symbol
32 (string &key (package *package*) (swap-case t) (swap-hyphen t))
33 "Convert STRING to a symbol in PACKAGE.
35 Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the
36 package; PACKAGE is used if there isn't a prefix. A doubled colon allows
37 access to internal symbols, and will intern if necessary. Note that
38 escape characters are /not/ processed; don't put colons in package names
39 if you want to use them from SOD property sets.
41 The portions of the string are modified by `frob-identifier'; the
42 arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to
43 control this process."
45 (let* ((length (length string))
46 (colon (position #\: string)))
47 (multiple-value-bind (start internalp)
48 (cond ((not colon) (values 0 t))
49 ((and (< (1+ colon) length)
50 (char= (char string (1+ colon)) #\:))
51 (values (+ colon 2) t))
53 (values (1+ colon) nil)))
55 (let* ((package-name (if (zerop colon) "KEYWORD"
56 (frob-identifier (subseq string 0 colon)
58 :swap-hyphen swap-hyphen)))
59 (found (find-package package-name)))
61 (error "Unknown package `~A'" package-name))
62 (setf package found)))
63 (let ((name (frob-identifier (subseq string start)
65 :swap-hyphen swap-hyphen)))
66 (multiple-value-bind (symbol status)
67 (funcall (if internalp #'intern #'find-symbol) name package)
68 (cond ((or internalp (eq status :external))
71 (error "Symbol `~A' not found in package `~A'"
72 name (package-name package)))
74 (error "Symbol `~A' not external in package `~A'"
75 name (package-name package)))))))))
77 ;;;--------------------------------------------------------------------------
78 ;;; Property representation.
80 (defmethod file-location ((prop property))
81 (file-location (p-location prop)))
85 (defmethod coerce-property-value
86 ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
89 (defmethod coerce-property-value
90 ((value string) (type (eql :id)) (wanted (eql :keyword)))
91 (string-to-symbol value :package :keyword))
93 (defmethod coerce-property-value
94 ((value string) (type (eql :string)) (wanted (eql :keyword)))
95 (string-to-symbol value :package :keyword :swap-hyphen nil))
99 (defmethod coerce-property-value
100 ((value string) (type (eql :id)) (wanted (eql :symbol)))
101 (string-to-symbol value))
103 (defmethod coerce-property-value
104 ((value string) (type (eql :string)) (wanted (eql :symbol)))
105 (string-to-symbol value :swap-hyphen nil))
109 (defmethod coerce-property-value
110 ((value string) (type (eql :string)) (wanted (eql :id)))
113 (defmethod coerce-property-value
114 ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
115 (frob-identifier (symbol-name value)))
119 (defmethod coerce-property-value
120 ((value string) (type (eql :id)) (wanted (eql :type)))
121 (or (and (boundp '*module-type-map*)
122 (gethash value *module-type-map*))
123 (find-simple-c-type value)
124 (error "Unknown type `~A'" value)))
126 ;;;--------------------------------------------------------------------------
129 (defmethod print-object ((pset pset) stream)
130 (print-unreadable-object (pset stream :type t)
131 (pprint-logical-block (stream nil)
133 (pset-map (lambda (prop)
134 (cond (firstp (setf firstp nil))
135 (t (write-char #\space stream)
136 (pprint-newline :linear stream)))
137 (format stream "~:@<~S ~@_~S ~@_~S~:>"
138 (p-name prop) (p-type prop) (p-value prop)))
141 ;;;----- That's all, folks --------------------------------------------------