File: cx-util.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 (98 lines) | stat: -rw-r--r-- 3,612 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
(in-package :contextl)

(defmacro atomic-ensure-get (symbol indicator default)
  (rebinding (symbol indicator)
    `(or (get ,symbol ,indicator)
         (as-atomic-operation
           (or (get ,symbol ,indicator)
               (setf (symbol-plist ,symbol)
                     (list* ,indicator ,default (symbol-plist ,symbol))))))))

(defgeneric map-symbol (indicator symbol)
  (:method ((indicator symbol) (symbol symbol))
   (if (symbol-package symbol)
     (intern (format nil "=~A-FOR-~A="
                     (symbol-name indicator)
                     (symbol-name symbol))
             (symbol-package symbol))
     (atomic-ensure-get symbol indicator (gensym)))))

#|
Layers are represented as CLOS classes. To avoid nameclashes with plain
CLOS classes, the name of a layer is actually mappend to an internal
unambiguous name which is used instead of the regular name.
|#

(defun defining-layer (name)
  "Takes the name of a layer and returns its internal name."
  (case name
    ((t) 't)
    ((nil) (error "NIL is not a valid layer name."))
    (otherwise (map-symbol 'layer-class-definer name))))

#|
Layered functions have two names: The name of the caller and the name of
the definer. The caller is just a function that adds a representation of
the active layers to the list of arguments and calls the definer. The
definer is a generic function that contains all the layered methods.

The caller has the name under which a user knows about a layered function.
The definer has an automatically generated name that can be unambiguously
determined from the caller's name. So for example, consider the following
layered function definition:

(define-layered-function foo (...))

The caller is named 'foo whereas the definer is named something like
=layered-function-definer-for-foo=. [The details of the mapping should
be considered an implementation detail, though, and not part of the
"official" API of ContextL.]
|#

(defun lf-definer-name (name)
  "Takes the name of a layered function caller
   and returns the name of the corresponding definer."
  (cond ((plain-function-name-p name)
         (map-symbol 'layered-function-definer name))
        ((setf-function-name-p name)
         `(setf ,(map-symbol 'layered-function-definer (cadr name))))
        (t (error "Illegal function name: ~S." name))))

(defun bind-lf-names (name)
  "Takes the name of a layered function caller
   and ensures that it can be retrieved again
   from the name of a corresponding definer."
  (let ((plain-function-name (plain-function-name name)))
    (setf (get (map-symbol 'layered-function-definer plain-function-name)
               'layered-function-caller)
          plain-function-name)))

(defun lf-caller-name (name)
  "Takes the name of a layered function definer
   and returns the name of the corresponding caller."
  (cond ((plain-function-name-p name)
         (get name 'layered-function-caller))
        ((setf-function-name-p name)
         `(setf ,(get (cadr name) 'layered-function-caller)))
        (t (error "Illegal function name: ~S." name))))

#|
The following are utility functions to distingush between
the two kinds of function names available in Common Lisp.
|#

(declaim (inline plain-function-name-p))

(defun plain-function-name-p (name)
  (symbolp name))

(defun setf-function-name-p (name)
  (and (consp name)
       (eq (car name) 'setf)
       (symbolp (cadr name))
       (null (cddr name))))

(defun plain-function-name (name)
  (cond ((plain-function-name-p name) name)
        ((setf-function-name-p name) (cadr name))
        (t (error "Illegal function name ~S." name))))