/[rdnzl]/RDNZL/util.lisp
ViewVC logotype

Contents of /RDNZL/util.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Thu Aug 10 15:36:47 2006 UTC (7 years, 8 months ago) by eweitz
Branch: MAIN
CVS Tags: HEAD
Changes since 1.6: +5 -1 lines
Sync with 10.1.2
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: RDNZL; Base: 10 -*-
2 ;;; $Header: /tiger/var/lib/cvsroots/rdnzl/RDNZL/util.lisp,v 1.7 2006/08/10 15:36:47 eweitz Exp $
3
4 ;;; Copyright (c) 2004-2006, Dr. Edmund Weitz. All rights reserved.
5
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29
30 ;;; Several utility functions.
31
32 (in-package :rdnzl)
33
34 #+:lispworks
35 (eval-when (:compile-toplevel :load-toplevel :execute)
36 (import 'lw:with-unique-names))
37
38 #-:lispworks
39 (defmacro with-unique-names ((&rest bindings) &body body)
40 "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
41
42 Executes a series of forms with each VAR bound to a fresh,
43 uninterned symbol. The uninterned symbol is as if returned by a call
44 to GENSYM with the string denoted by X - or, if X is not supplied, the
45 string denoted by VAR - as argument.
46
47 The variable bindings created are lexical unless special declarations
48 are specified. The scopes of the name bindings and declarations do not
49 include the Xs.
50
51 The forms are evaluated in order, and the values of all but the last
52 are discarded \(that is, the body is an implicit PROGN)."
53 ;; reference implementation posted to comp.lang.lisp as
54 ;; <cy3bshuf30f.fsf@ljosa.com> by Vebjorn Ljosa - see also
55 ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
56 `(let ,(mapcar #'(lambda (binding)
57 (check-type binding (or cons symbol))
58 (if (consp binding)
59 (destructuring-bind (var x) binding
60 (check-type var symbol)
61 `(,var (gensym ,(etypecase x
62 (symbol (symbol-name x))
63 (character (string x))
64 (string x)))))
65 `(,binding (gensym ,(symbol-name binding)))))
66 bindings)
67 ,@body))
68
69 #+:lispworks
70 (eval-when (:compile-toplevel :load-toplevel :execute)
71 (setf (macro-function 'with-rebinding)
72 (macro-function 'lw:rebinding)))
73
74 #-:lispworks
75 (defmacro with-rebinding (bindings &body body)
76 "WITH-REBINDING ( { var | (var prefix) }* ) form*
77
78 Evaluates a series of forms in the lexical environment that is
79 formed by adding the binding of each VAR to a fresh, uninterned
80 symbol, and the binding of that fresh, uninterned symbol to VAR's
81 original value, i.e., its value in the current lexical environment.
82
83 The uninterned symbol is created as if by a call to GENSYM with the
84 string denoted by PREFIX - or, if PREFIX is not supplied, the string
85 denoted by VAR - as argument.
86
87 The forms are evaluated in order, and the values of all but the last
88 are discarded \(that is, the body is an implicit PROGN)."
89 ;; reference implementation posted to comp.lang.lisp as
90 ;; <cy3wv0fya0p.fsf@ljosa.com> by Vebjorn Ljosa - see also
91 ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
92 (loop for binding in bindings
93 for var = (if (consp binding) (car binding) binding)
94 for name = (gensym)
95 collect `(,name ,var) into renames
96 collect ``(,,var ,,name) into temps
97 finally (return `(let ,renames
98 (with-unique-names ,bindings
99 `(let (,,@temps)
100 ,,@body))))))
101
102 (defun starts-with (string sub-string)
103 "Returns true if the string STRING starts with the string
104 SUB-STRING."
105 (let ((mismatch (mismatch string sub-string :test #'char-equal)))
106 (or (null mismatch)
107 (>= mismatch (length sub-string)))))
108
109 (defmacro named-when ((var form) &body body)
110 "Executes BODY if FORM evaluates to a true value. During the
111 execution of BODY VAR is bound to the value returned by FORM."
112 `(let ((,var ,form))
113 (when ,var
114 ,@body)))
115
116 (defun use-namespace (namespace)
117 "Adds the .NET namespace NAMESPACE \(a string) to the list of
118 namespaces that will be prefixed when trying to resolve a type name.
119 After calling this function NAMESPACE will be the first entry in this
120 list unless it has already been there."
121 (pushnew (concatenate 'string namespace ".")
122 *used-namespaces*
123 :test #'string=)
124 (values))
125
126 (defun unuse-namespace (namespace)
127 "Removes the .NET namespace NAMESPACE \(a string) from the list of
128 namespaces that will be prefixed when trying to resolve a type name."
129 (setq *used-namespaces*
130 (delete (concatenate 'string namespace ".")
131 *used-namespaces*
132 :test #'string=))
133 (values))
134
135 (defun unuse-all-namespaces ()
136 "Removes all entries from the list of namespaces that will be
137 prefixed when trying to resolve a type name."
138 (setq *used-namespaces* nil)
139 (values))
140
141 (defun resolve-type-name (name)
142 "If NAME \(a string) names a type which has been previously imported
143 via IMPORT-TYPE then return its assembly-qualified name. If a type
144 named NAME can't be found directly then also try the `used'
145 namespaces."
146 (loop for namespace in (cons "" *used-namespaces*)
147 for full-name = (concatenate 'string namespace name)
148 for hashed-name = (gethash full-name *type-hash*)
149 when hashed-name
150 do (return (cond ((stringp hashed-name) hashed-name)
151 (t full-name)))
152 finally (return name)))
153
154 (defun mangle-name (string)
155 "Converts the string STRING into another string with case determined by the
156 current readtable-case and where a hyphen is inserted whenever the case changes
157 from lower to upper, e.g. \"myCoolFoo\" becomes \"MY-COOL-FOO\"."
158 (symbol-name
159 (read-from-string
160 (with-output-to-string (out)
161 (loop for last-char = #\. then char
162 for char across string
163 when (and (lower-case-p last-char)
164 (upper-case-p char))
165 do (write-char #\- out)
166 do (write-char (char-downcase char) out))))))
167
168 (defun make-lisp-name (c-name)
169 "Makes a Lisp name \(a symbol in the RDNZL package) from a C name."
170 (intern (concatenate 'string "%" (mangle-name c-name)) :rdnzl))
171
172 (defun unmangle-name* (string)
173 "STRING is assumed to be a string consisting solely of
174 single-case letters and hyphens. This function will return a
175 string with all hyphens removed and all characters downcased
176 except for the first one and those following a hyphen - these are
177 upcased."
178 (with-output-to-string (out)
179 (loop with upcase = t
180 for c across string
181 do (cond ((char= c #\-)
182 (setq upcase t))
183 (upcase
184 (write-char (char-upcase c) out)
185 (setq upcase nil))
186 (t
187 (write-char (char-downcase c) out))))))
188
189 (defun unmangle-name (function-name)
190 "FUNCTION-NAME is assumed to be a function name, i.e. a symbol
191 or a cons of the form \(SETF symbol). If the symbol name of this
192 symbol consists solely of single-case letters appropriate for the
193 current readtable-case and hyphens then UNMANGLE-NAME* is applied
194 to it, otherwise the symbol name itself is returned. Note that
195 the return value is always a symbol even if the argument was a
196 cons."
197 (let* ((symbol (cond ((consp function-name)
198 (second function-name))
199 (t function-name)))
200 (symbol-name (symbol-name symbol)))
201 (let ((case-test (case (readtable-case *readtable*)
202 ((:upcase :invert) #'upper-case-p)
203 (t #'lower-case-p))))
204 (cond ((every (lambda (c)
205 (or (funcall case-test c)
206 (char= c #\-)))
207 symbol-name)
208 (unmangle-name* symbol-name))
209 (t symbol-name)))))
210
211 (defun find-partial-assembly-name (type-name)
212 "Tries to extract the partial assembly name from the
213 assembly-qualified type name TYPE-NAME."
214 (let ((length (length type-name)))
215 (flet ((find-comma (start)
216 "Finds the position of the first comma within TYPE-NAME
217 \(starting from position START) which is not preceded by a backslash."
218 (loop for i = start then (1+ pos)
219 for pos = (and (< i length)
220 (position #\, type-name :test #'char= :start i))
221 while (and pos
222 (plusp pos)
223 (char= (char type-name (1- pos)) #\\))
224 finally (return pos))))
225 (let* ((first-comma (find-comma 0))
226 ;; now skip spaces
227 (non-space (and first-comma
228 (position #\Space type-name :test #'char/= :start (1+ first-comma))))
229 (second-comma (and non-space
230 (find-comma non-space))))
231 (or (and second-comma
232 (> second-comma non-space)
233 (subseq type-name non-space second-comma))
234 (error "Couldn't find partial assembly name in ~S" type-name))))))
235
236 (defun whitespacep (chr)
237 "Tests whether a character is whitespace."
238 (member chr +whitespace-char-list+ :test #'char=))
239

  ViewVC Help
Powered by ViewVC 1.1.5