src/parser/floc-proto.lisp: Associate restarts when resignalling.
[sod] / src / pset-impl.lisp
CommitLineData
dea4d055
MW
1;;; -*-lisp-*-
2;;;
3;;; Implementation for property sets
4;;;
5;;; (c) 2009 Straylight/Edgeware
6;;;
7
8;;;----- Licensing notice ---------------------------------------------------
9;;;
e0808c47 10;;; This file is part of the Sensible Object Design, an object system for C.
dea4d055
MW
11;;;
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.
16;;;
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.
21;;;
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.
25
26(cl:in-package #:sod)
27
28;;;--------------------------------------------------------------------------
4ee476bc
MW
29;;; Conversion utilities.
30
31(defun string-to-symbol
32 (string &key (package *package*) (swap-case t) (swap-hyphen t))
33 "Convert STRING to a symbol in PACKAGE.
34
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.
40
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."
44
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))
52 (t
53 (values (1+ colon) nil)))
54 (when colon
55 (let* ((package-name (if (zerop colon) "KEYWORD"
56 (frob-identifier (subseq string 0 colon)
57 :swap-case swap-case
58 :swap-hyphen swap-hyphen)))
59 (found (find-package package-name)))
60 (unless found
61 (error "Unknown package `~A'" package-name))
62 (setf package found)))
63 (let ((name (frob-identifier (subseq string start)
64 :swap-case swap-case
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))
69 symbol)
70 ((not status)
71 (error "Symbol `~A' not found in package `~A'"
72 name (package-name package)))
73 (t
74 (error "Symbol `~A' not external in package `~A'"
75 name (package-name package)))))))))
76
77;;;--------------------------------------------------------------------------
dea4d055
MW
78;;; Property representation.
79
80(defmethod file-location ((prop property))
81 (file-location (p-location prop)))
82
83;;; Keywords.
84
85(defmethod coerce-property-value
86 ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
87 value)
88
89(defmethod coerce-property-value
90 ((value string) (type (eql :id)) (wanted (eql :keyword)))
91 (string-to-symbol value :package :keyword))
92
93(defmethod coerce-property-value
94 ((value string) (type (eql :string)) (wanted (eql :keyword)))
95 (string-to-symbol value :package :keyword :swap-hyphen nil))
96
97;;; Symbols.
98
99(defmethod coerce-property-value
100 ((value string) (type (eql :id)) (wanted (eql :symbol)))
101 (string-to-symbol value))
102
103(defmethod coerce-property-value
104 ((value string) (type (eql :string)) (wanted (eql :symbol)))
105 (string-to-symbol value :swap-hyphen nil))
106
107;;; Identifiers.
108
109(defmethod coerce-property-value
110 ((value string) (type (eql :string)) (wanted (eql :id)))
111 value)
112
113(defmethod coerce-property-value
114 ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
115 (frob-identifier (symbol-name value)))
116
6ee19709
MW
117;;; Types.
118
119(defmethod coerce-property-value
120 ((value string) (type (eql :id)) (wanted (eql :type)))
ff344fb7
MW
121 (or (and (boundp '*module-type-map*)
122 (gethash value *module-type-map*))
14adef2f 123 (find-simple-c-type value)
a1985b3c 124 (error "Unknown type `~A'" value)))
6ee19709 125
dea4d055
MW
126;;;--------------------------------------------------------------------------
127;;; Property sets.
128
129(defmethod print-object ((pset pset) stream)
130 (print-unreadable-object (pset stream :type t)
131 (pprint-logical-block (stream nil)
132 (let ((firstp t))
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)))
139 pset)))))
140
141;;;----- That's all, folks --------------------------------------------------