(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
-;;; Property representation.
-
-(defun property-key (name)
- "Convert NAME into a keyword.
-
- If NAME isn't a symbol already, then flip its case (using FROB-CASE),
- replace underscores by hyphens, and intern into the KEYWORD package."
- (etypecase name
- (symbol name)
- (string (intern (substitute #\- #\_ (frob-case name)) :keyword))))
-
-(defun property-type (value)
- "Guess a sensible property type to use for VALUE."
- (typecase value
- (symbol :symbol)
- (integer :integer)
- (string :string)
- (character :char)
- (c-fragment :frag)
- (t :other)))
-
-(defstruct (property
- (:conc-name p-)
- (:constructor make-property
- (name value
- &key (type (property-type value))
- ((:location %loc))
- seenp
- &aux (key (property-key name))
- (location (file-location %loc)))))
- "A simple structure for holding a property in a property set.
-
- The main useful feature is the ability to tick off properties which have
- been used, so that we can complain about unrecognized properties.
-
- An explicit type tag is necessary because we need to be able to talk
- distinctly about identifiers, strings and symbols, and we've only got two
- obvious Lisp types to play with. Sad, but true."
-
- (name nil :type (or string symbol))
- (value nil :type t)
- (type nil :type symbol)
- (location (file-location nil) :type file-location)
- (key nil :type symbol)
- (seenp nil :type boolean))
-
-(defun string-to-symbol (string &optional (package *package*))
- "Convert STRING to a symbol in PACKAGE.
-
- If PACKAGE is nil, then parse off a `PACKAGE:' prefix from STRING to
- identify the package. A doubled colon allows access to internal symbols,
- and will intern if necessary. Note that escape characters are /not/
- processed; don't put colons in package names if you want to use them from
- SOD property sets."
-
- (let* ((length (length string))
- (colon (position #\: string)))
- (multiple-value-bind (start internalp)
- (cond ((not colon) (values 0 t))
- ((and (< (1+ colon) length)
- (char= (char string (1+ colon)) #\:))
- (values (+ colon 2) t))
- (t
- (values (1+ colon) nil)))
- (when colon
- (let* ((package-name (subseq string 0 colon))
- (found (find-package package-name)))
- (unless found
- (error "Unknown package `~A'" package-name))
- (setf package found)))
- (let ((name (subseq string start)))
- (multiple-value-bind (symbol status)
- (funcall (if internalp #'intern #'find-symbol) name package)
- (cond ((or internalp (eq status :external))
- symbol)
- ((not status)
- (error "Symbol `~A' not found in package `~A'"
- name (package-name package)))
- (t
- (error "Symbol `~A' not external in package `~A'"
- name (package-name package)))))))))
-
-(defgeneric coerce-property-value (value type wanted)
- (:documentation
- "Convert VALUE, a property of type TYPE, to be of type WANTED.
-
- It's sensible to add additional methods to this function, but there are
- all the ones we need.")
-
- ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
- ;; form. Otherwise, if nothing else matched, then I guess we'll have to
- ;; say it didn't work.
- (:method (value type wanted)
- (if (eql type wanted)
- value
- (error "Incorrect type: expected ~A but found ~A" wanted type)))
-
- ;; If the caller asks for type T then give him the raw thing.
- (:method (value type (wanted (eql t)))
- value)
-
- ;; Keywords.
- (:method ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
- value)
- (:method ((value string) (type (eql :id)) (wanted (eql :keyword)))
- (string-to-symbol (substitute #\- #\_ (frob-case value)) :keyword))
- (:method ((value string) (type (eql :string)) (wanted (eql :keyword)))
- (string-to-symbol (frob-case value) :keyword))
-
- ;; Symbols.
- (:method ((value string) (type (eql :id)) (wanted (eql :symbol)))
- (string-to-symbol (substitute #\- #\_ (frob-case value))))
- (:method ((value string) (type (eql :string)) (wanted (eql :symbol)))
- (string-to-symbol (frob-case value)))
-
- ;; Identifiers.
- (:method ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
- (substitute #\_ #\- (frob-case (symbol-name value)))))
-
-;;;--------------------------------------------------------------------------
-;;; Property set representation.
-;;;
-;;; There shouldn't be any code elsewhere which depends on the
-;;; representation. It's changed before; it may change again.
-
-(defstruct (pset (:constructor %make-pset)
- (:conc-name %pset-))
- "A property set.
-
- Wrapped up in a structure so that we can define a print function."
- (hash (make-hash-table) :type hash-table))
-
-(declaim (inline make-pset pset-get pset-store pset-map))
-
-(defun make-pset ()
- "Constructor for property sets."
- (%make-pset))
-
-(defun pset-get (pset key)
- "Look KEY up in PSET and return what we find.
-
- If there's no property by that name, return NIL."
- (values (gethash key (%pset-hash pset))))
-
-(defun pset-store (pset prop)
- "Store property PROP in PSET.
-
- Overwrite or replace any previous property with the same name. Mutates
- the property set."
- (setf (gethash (p-key prop) (%pset-hash pset)) prop))
-
-(defun pset-map (func pset)
- "Call FUNC for each property in PSET."
- (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
- (%pset-hash pset)))
-
-;;;--------------------------------------------------------------------------
-;;; `Cooked' property set operations.
-
-(defun store-property
- (pset name value &key (type (property-type value)) location)
- "Store a property in PSET."
- (pset-store pset
- (make-property name value :type type :location location)))
-
-(defun get-property (pset name type &optional default)
- "Fetch a property from a property set.
-
- If a property NAME is not found in PSET, or if a property is found, but
- its type doesn't match TYPE, then return DEFAULT and NIL; otherwise return
- the value and its file location. In the latter case, mark the property as
- having been used.
-
- The value returned depends on the TYPE argument provided. If you pass NIL
- then you get back the entire PROPERTY object. If you pass T, then you get
- whatever was left in the property set, uninterpreted. Otherwise the value
- is coerced to the right kind of thing (where possible) and returned.
-
- If PSET is nil, then return DEFAULT."
-
- (let ((prop (and pset (pset-get pset (property-key name)))))
- (with-default-error-location ((and prop (p-location prop)))
- (cond ((not prop)
- (values default nil))
- ((not type)
- (setf (p-seenp prop) t)
- (values prop (p-location prop)))
- (t
- (setf (p-seenp prop) t)
- (values (coerce-property-value (p-value prop)
- (p-type prop)
- type)
- (p-location prop)))))))
-
-(defun add-property
- (pset name value &key (type (property-type value)) location)
- "Add a property to PSET.
-
- If a property with the same NAME already exists, report an error."
-
- (with-default-error-location (location)
- (let ((existing (get-property pset name nil)))
- (when existing
- (error "Property ~S already defined~@[ at ~A~]"
- name (p-location existing)))
- (store-property pset name value :type type :location location))))
-
-(defun make-property-set (&rest plist)
- "Make a new property set, with given properties.
-
- This isn't the way to make properties when parsing, but it works well for
- programmatic generation. The arguments should form a property list
- (alternating keywords and values is good).
-
- An attempt is made to guess property types from the Lisp types of the
- values. This isn't always successful but it's not too bad. The
- alternative is manufacturing a PROPERTY-VALUE object by hand and stuffing
- into the set."
-
- (do ((pset (make-pset))
- (plist plist (cddr plist)))
- ((endp plist) pset)
- (add-property pset (car plist) (cadr plist))))
-
-(defmethod print-object ((pset pset) stream)
- (print-unreadable-object (pset stream :type t)
- (pprint-logical-block (stream nil)
- (let ((firstp t))
- (pset-map (lambda (prop)
- (cond (firstp (setf firstp nil))
- (t (write-char #\space stream)
- (pprint-newline :linear stream)))
- (format stream "~:@<~S ~@_~S ~@_~S~:>"
- (p-name prop) (p-type prop) (p-value prop)))
- pset)))))
-
-(defun check-unused-properties (pset)
- "Issue errors about unused properties in PSET."
- (when pset
- (pset-map (lambda (prop)
- (unless (p-seenp prop)
- (cerror*-with-location (p-location prop)
- "Unknown property `~A'"
- (p-name prop))
- (setf (p-seenp prop) t)))
- pset)))
-
-;;;--------------------------------------------------------------------------
;;; Expression parser.
(defun parse-expression (lexer)
~mdw / sod / blobdiff