55 lines
1.9 KiB
Common Lisp
55 lines
1.9 KiB
Common Lisp
#|
|
|
This file is a part of LASS
|
|
(c) 2014 Shirakumo http://tymoon.eu (shinmera@tymoon.eu)
|
|
Author: Nicolas Hafner <shinmera@tymoon.eu>
|
|
|#
|
|
|
|
(in-package #:org.tymoonnext.lass)
|
|
|
|
(defvar *property-functions* (make-hash-table :test 'equalp))
|
|
|
|
(defun property-function (name)
|
|
(gethash (string name) *property-functions*))
|
|
|
|
(defun (setf property-function) (function name)
|
|
(setf (gethash (string name) *property-functions*)
|
|
function))
|
|
|
|
(defmacro define-property-function (name args &body body)
|
|
`(setf (property-function ,(string name))
|
|
#'(lambda ,args ,@body)))
|
|
|
|
(defmacro define-simple-property-function (name args)
|
|
`(define-property-function ,name ,args
|
|
(format NIL ,(format NIL "~(~a~)(~{~*~~a~^,~})" name args)
|
|
,@(loop for arg in args collect `(resolve ,arg)))))
|
|
|
|
(defun resolve-function (function &rest args)
|
|
(let ((resolver (property-function function)))
|
|
(if resolver
|
|
(apply resolver args)
|
|
(format NIL "~(~a~)(~{~a~^,~})" function args))))
|
|
|
|
(defmethod resolve ((thing list))
|
|
(apply #'resolve-function (car thing) (cdr thing)))
|
|
|
|
;; We redefine the method here in order to delegate to property functions
|
|
;; if they do actually exist.
|
|
(defmethod consume-item ((property symbol) readable-list)
|
|
(if (keywordp property)
|
|
(values
|
|
(let ((propvals ()))
|
|
(loop for (next fullp) = (multiple-value-list (peek readable-list))
|
|
while fullp
|
|
do (etypecase next
|
|
(keyword (return))
|
|
(list
|
|
(let ((resolver (property-function (car next))))
|
|
(if resolver
|
|
(push (consume readable-list) propvals)
|
|
(return))))
|
|
(T (push (consume readable-list) propvals))))
|
|
(cons property (nreverse propvals)))
|
|
NIL)
|
|
(call-next-method)))
|