File: cx-layered-function-macros.lisp

package info (click to toggle)
cl-contextl 0.40-2
  • links: PTS
  • area: main
  • in suites: lenny
  • size: 248 kB
  • ctags: 298
  • sloc: lisp: 2,271; makefile: 29
file content (118 lines) | stat: -rw-r--r-- 5,394 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
(in-package :contextl)

(defun parse-method-body (form body)
  (let* ((in-layerp (member (car body) '(:in-layer :in) :test #'eq))
         (layer-spec (if in-layerp (cadr body) 't)))
    (when (consp layer-spec)
      (unless (null (cddr layer-spec))
        (error "Incorrect :in-layer specification in ~S." form)))
    (loop with layer = (if (atom layer-spec)
                         layer-spec
                         (cadr layer-spec))
          with layer-arg = (if (atom layer-spec)
                             (gensym "LAYER-ARG-")
                             (car layer-spec))
          for tail = (if in-layerp (cddr body) body) then (cdr tail)
          until (listp (car tail))
          collect (car tail) into qualifiers
          finally
          (loop for qualifier in qualifiers
                when (member qualifier '(:in-layer :in) :test #'eq)
                do (error "Incorrect occurrence of ~S in ~S. Must occur before qualifiers." qualifier form))
          (return (values layer-arg layer qualifiers (car tail) (cdr tail))))))

(defun prepare-layer (layer)
  (if (symbolp layer)
    (defining-layer layer)
    layer))

(defun prepare-layered-method-body (name form layer-arg body)
  (loop for tail = body then (cdr tail)
        for (first . rest) = tail
        while tail
        while (or (and rest (stringp first))
                  (and (consp first) (eq (car first) 'declare)))
        count (stringp first) into nof-seen-strings
        collect first into declarations
        finally
        (when (> nof-seen-strings 1)
          (error "Too many documentation strings in ~S." form))
        (return `(,@declarations
                  (block ,(plain-function-name name)
                    (flet ((call-next-layered-method (&rest args)
                             (declare (dynamic-extent args))
                             (if args
                               (apply #'call-next-method ,layer-arg args)
                               (call-next-method))))
                      #-lispworks
                      (declare (inline call-next-layered-method)
                               (ignorable (function call-next-layered-method)))
                      ,first ,@rest))))))

(defclass layered-function (standard-generic-function) ()
  (:metaclass funcallable-standard-class)
  (:default-initargs :method-class (find-class 'layered-method)))

(defmethod print-object ((object layered-function) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (princ (lf-caller-name (generic-function-name object)) stream)))

(defun layered-function-definer (name)
  (fdefinition (lf-definer-name name)))

(defgeneric layered-function-argument-precedence-order (function)
  (:method ((function layered-function)) (butlast (generic-function-argument-precedence-order function))))

(defgeneric layered-function-lambda-list (function)
  (:method ((function layered-function)) (rest (generic-function-lambda-list function))))

(defun lfmakunbound (name)
  (fmakunbound (lf-definer-name name))
  (fmakunbound name))

(defclass layered-method (standard-method) ())

(defgeneric layered-method-lambda-list (method)
  (:method ((method layered-method)) (rest (method-lambda-list method))))

(defgeneric layered-method-specializers (method)
  (:method ((method layered-method)) (rest (method-specializers method))))

(defmacro define-layered-function (name (&rest args) &body options)
  (let ((definer (lf-definer-name name)))
    (with-unique-names (layer-arg rest-arg)
      `(progn
         (defgeneric ,definer (,layer-arg ,@args)
           ,@(unless (member :generic-function-class options :key #'car)
               '((:generic-function-class layered-function)))
           (:argument-precedence-order 
            ,@(let ((argument-precedence-order (assoc :argument-precedence-order options)))
                (if argument-precedence-order
                  (cdr argument-precedence-order)
                  (required-args args)))
            ,layer-arg)
           ,@(loop for option in (remove :argument-precedence-order options :key #'car)
                   if (eq (car option) :method)
                   collect (multiple-value-bind
                               (layer-arg layer qualifiers args method-body)
                               (parse-method-body option (cdr option))
                             `(:method ,@qualifiers ((,layer-arg ,(prepare-layer layer)) ,@args)
                               ,@(prepare-layered-method-body name option layer-arg method-body)))
                   else collect option))
         (declaim (inline ,name))
         (defun ,name (&rest ,rest-arg)
           (declare #-openmcl (dynamic-extent ,rest-arg)
                    (optimize (speed 3) (debug 0) (safety 0)
                              (compilation-speed 0)))
           (apply #',definer (layer-context-prototype *active-context*) ,rest-arg))
         (eval-when (:compile-toplevel :load-toplevel :execute)
           (bind-lf-names ',name))
         #',definer))))

(defmacro define-layered-method (&whole form name &body body)
  (multiple-value-bind
      (layer-arg layer qualifiers args method-body)
      (parse-method-body form body)
    `(defmethod ,(lf-definer-name name)
                ,@qualifiers ((,layer-arg ,(prepare-layer layer)) ,@args)
       ,@(prepare-layered-method-body name form layer-arg method-body))))