forked from dbmcclain/Lisp-Actors
-
Notifications
You must be signed in to change notification settings - Fork 0
/
project-packages-lw.lisp
131 lines (110 loc) · 3.77 KB
/
project-packages-lw.lisp
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
119
120
121
122
123
124
125
126
127
128
129
130
131
;; project-packages-lw.lisp -- Project package mapping for LispWorks
;;
;; DM/RAL 10/22
;; -----------------------------------------------------------
(defpackage #:com.ral.project-packages
(:use #:common-lisp)
(:export
#:defproject
#:map-name
#:show-mappings
))
(in-package #:com.ral.project-packages)
(defvar *mappings* (make-hash-table :test #'string=))
(defvar *map-lock* (mp:make-lock :sharing t))
(defvar *bypass-mapping* nil)
(defun normalize (name)
(declare (optimize speed)) ;this is critical code
(cond ((stringp name)
(string-upcase name))
((symbolp name)
(normalize (symbol-name name)))
(t
(error "What!? (~S)" name))
))
(defun do-defproject (pairs)
(mp:with-exclusive-lock (*map-lock*)
(dolist (pair pairs)
(destructuring-bind (from-name to-name) pair
(let ((from-name (normalize from-name)))
(setf (gethash from-name *mappings*) to-name)
)))
))
(defmacro defproject (&rest pairs)
`(do-defproject ',pairs))
(defun map-name (name &optional froms)
(declare (optimize speed)) ;this is critical code
(cond ((or *bypass-mapping*
(packagep name))
name)
(t
(let ((norm-name (normalize name))
to-name)
(when (find norm-name froms :test #'string=)
(error "Cyclic mappong ~A" norm-name))
(mp:with-sharing-lock (*map-lock*)
(if (setf to-name (gethash norm-name *mappings*))
(map-name to-name (cons norm-name froms))
name))))
))
;; ------------------------------------------------
(lw:defadvice (find-package project-packages :around)
(name/package)
(declare (optimize speed)) ;this is critical code
(lw:call-next-advice
(map-name name/package)) )
#|
(lw:defadvice (sys::find-package-without-lod project-packages :around)
(name)
;; used by editor to set buffer package
(declare (optimize speed))
;; (format t "find-package-without-lod: ~S" (editor:variable-value 'editor::current-package) )
(lw:call-next-advice (map-name name)))
|#
#||#
(lw:defadvice (sys::find-global-package project-packages :around)
(name)
;; used by editor to set buffer package
(declare (optimize speed))
;; (format t "find-package-without-lod: ~S" (editor:variable-value 'editor::current-package) )
(lw:call-next-advice (map-name name)))
#||#
;; ------------------------------------------------
#|
(lw:defadvice (sys::%in-package project-packages :around)
(name &rest args)
(declare (optimize speed))
(apply #'lw:call-next-advice (map-name name) args))
|#
(lw:defadvice (in-package project-packages :around)
(call-form env)
(lw:call-next-advice `(in-package ,(map-name (cadr call-form))) env))
;; ------------------------------------------------
(defmethod in-quicklisp-p (filename)
(find "quicklisp" (pathname-directory filename)
:test #'string=))
(defmethod in-quicklisp-p ((stream stream))
nil)
(lw:defadvice (load project-packages :around)
(filename &rest args)
(let ((*bypass-mapping* (in-quicklisp-p filename)))
(apply #'lw:call-next-advice filename args)))
(lw:defadvice (compile-file project-packages :around)
(filename &rest args)
(let ((*bypass-mapping* (in-quicklisp-p filename)))
(apply #'lw:call-next-advice filename args)))
;; ------------------------------------------------------
(defun show-mappings ()
(let (lst)
(mp:with-sharing-lock (*map-lock*)
(with-hash-table-iterator (gen *mappings*)
(loop
(multiple-value-bind (more? key value) (gen)
(unless more? (return))
(push `(,key ,value) lst)))))
(with-standard-io-syntax
(pprint (sort lst #'string< :key #'car)))
(values)))
#|
(show-mappings)
|#