File: cx-layered-function.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 (72 lines) | stat: -rw-r--r-- 3,140 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
(in-package :contextl)

(defun ensure-layered-function
       (name
        &rest initargs
        &key (lambda-list () lambda-list-p)
        (argument-precedence-order (required-args lambda-list))
        (generic-function-class 'layered-function)
        &allow-other-keys)
  (declare (dynamic-extent initargs))
  (unless lambda-list-p
    (error "The layered function ~S must be initialized with a lambda list." name))
  (let ((gf (let ((layer-arg (gensym "LAYER-ARG-")))
              (apply #'ensure-generic-function
                     (lf-definer-name name)
		     #-allegro :generic-function-class
                     #-allegro generic-function-class
                     :argument-precedence-order
                     `(,@argument-precedence-order ,layer-arg)
                     :lambda-list
                     `(,layer-arg ,@lambda-list)
                     initargs))))
    (setf (fdefinition name)
          (compile nil `(lambda (&rest rest)
                          (declare (dynamic-extent rest)
                                   (optimize (speed 3) (debug 0) (safety 0)
                                             (compilation-speed 0)))
                          (apply (the function ,gf)
                                 (layer-context-prototype *active-context*)
                                 rest))))
    (bind-lf-names name)
    gf))

(defun ensure-layered-method
       (layered-function-name
        lambda-expression 
        &key
        #-(or allegro clisp cmu ecl mcl openmcl) 
        (method-class
         (generic-function-method-class
          (fdefinition (lf-definer-name layered-function-name))))
        (in-layer 't)
        (qualifiers ())
        (lambda-list (cadr lambda-expression))
        (specializers (required-args lambda-list (constantly (find-class 't)))))
  (let ((layer-arg (gensym "LAYER-ARG-")))
    (destructuring-bind
        (lambda (&rest args) &body body)
        lambda-expression
      (unless (eq lambda 'lambda)
        (error "Incorrect lambda expression: ~S." lambda-expression))
      (ensure-method (fdefinition (lf-definer-name layered-function-name))
                     `(lambda (,layer-arg ,@args) ,@body)
                     #-(or allegro clisp cmu ecl mcl openmcl) :method-class
                     #-(or allegro clisp cmu ecl mcl openmcl) method-class
                     :qualifiers qualifiers
                     :lambda-list `(,layer-arg ,@lambda-list)
                     :specializers (cons (find-layer-class in-layer) specializers)))))

(defgeneric layered-method-layer (method)
  (:method ((method layered-method)) (find-layer (first (method-specializers method)))))

(defmethod print-object ((object layered-method) stream)
  (print-unreadable-object (object stream :type t :identity t)
    (format stream "~A ~A ~S ~A"
            (when (method-generic-function object)
              (lf-caller-name
               (generic-function-name
                (method-generic-function object))))
            (layer-name (layered-method-layer object))
            (method-qualifiers object)
            (layered-method-specializers object))))