[slime-cvs] CVS slime
CVS User trittweiler
trittweiler at common-lisp.net
Sat Oct 31 22:13:55 UTC 2009
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv6057
Modified Files:
ChangeLog slime.el swank-loader.lisp swank.lisp
Added Files:
swank-match.lisp
Log Message:
* slime.el (slime-inside-string-p, slime-inside-comment-p)
(slime-inside-string-or-comment-p): New.
* swank-match.lisp: New file. Contains very simple pattern matcher
from the CMU AI archive.
* swank-loader.lisp: Compile swank-match.lisp.
* swank.lisp: Make SWANK package use new SWANK-MATCH package.
* slime-autodoc.el, swank-arglists.lisp: Large parts were
rewritten. Autodoc is now able to highlight &key parameters, and
parameters in nested arglists.
* slime-parse.el, slime-c-p-c.el, slime-highlighting-edits.el:
Adapted to changes.
--- /project/slime/cvsroot/slime/ChangeLog 2009/10/31 20:47:13 1.1901
+++ /project/slime/cvsroot/slime/ChangeLog 2009/10/31 22:13:54 1.1902
@@ -1,5 +1,17 @@
2009-10-31 Tobias C. Rittweiler <tcr at freebits.de>
+ * slime.el (slime-inside-string-p, slime-inside-comment-p)
+ (slime-inside-string-or-comment-p): New.
+
+ * swank-match.lisp: New file. Contains very simple pattern matcher
+ from the CMU AI archive.
+
+ * swank-loader.lisp: Compile swank-match.lisp.
+
+ * swank.lisp: Make SWANK package use new SWANK-MATCH package.
+
+2009-10-31 Tobias C. Rittweiler <tcr at freebits.de>
+
* swank.lisp (find-symbol-with-status): New.
(parse-symbol): Use it to correctly parse symbols where only one
colon is given. Consequences: Autodoc won't display an arglist on
--- /project/slime/cvsroot/slime/slime.el 2009/10/31 08:54:45 1.1243
+++ /project/slime/cvsroot/slime/slime.el 2009/10/31 22:13:54 1.1244
@@ -8218,6 +8218,18 @@
until (= (point) (point-max))
maximizing column)))
+(defun slime-inside-string-p ()
+ (nth 3 (slime-current-parser-state)))
+
+(defun slime-inside-comment-p ()
+ (nth 4 (slime-current-parser-state)))
+
+(defun slime-inside-string-or-comment-p ()
+ (let ((state (slime-current-parser-state)))
+ (or (nth 3 state) (nth 4 state))))
+
+
+
;;;;; CL symbols vs. Elisp symbols.
(defun slime-cl-symbol-name (symbol)
--- /project/slime/cvsroot/slime/swank-loader.lisp 2009/10/30 19:39:34 1.94
+++ /project/slime/cvsroot/slime/swank-loader.lisp 2009/10/31 22:13:55 1.95
@@ -182,7 +182,7 @@
:defaults src-dir))
names))
-(defvar *swank-files* `(swank-backend ,@*sysdep-files* swank))
+(defvar *swank-files* `(swank-backend ,@*sysdep-files* swank-match swank))
(defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy
swank-fancy-inspector
--- /project/slime/cvsroot/slime/swank.lisp 2009/10/31 20:47:13 1.668
+++ /project/slime/cvsroot/slime/swank.lisp 2009/10/31 22:13:55 1.669
@@ -13,7 +13,7 @@
;;; available to us here via the `SWANK-BACKEND' package.
(defpackage :swank
- (:use :cl :swank-backend)
+ (:use :cl :swank-backend :swank-match)
(:export #:startup-multiprocessing
#:start-server
#:create-server
@@ -478,11 +478,11 @@
(,operands (cdr ,tmp)))
(case ,operator
,@(loop for (pattern . body) in patterns collect
- (if (eq pattern t)
- `(t , at body)
- (destructuring-bind (op &rest rands) pattern
- `(,op (destructuring-bind ,rands ,operands
- , at body)))))
+ (if (eq pattern t)
+ `(t , at body)
+ (destructuring-bind (op &rest rands) pattern
+ `(,op (destructuring-bind ,rands ,operands
+ , at body)))))
,@(if (eq (caar (last patterns)) t)
'()
`((t (error "destructure-case failed: ~S" ,tmp))))))))
@@ -1232,6 +1232,7 @@
(cdr tail)))
tail)))
+;;; FIXME: Make this use SWANK-MATCH.
(defun event-match-p (event pattern)
(cond ((or (keywordp pattern) (numberp pattern) (stringp pattern)
(member pattern '(nil t)))
--- /project/slime/cvsroot/slime/swank-match.lisp 2009/10/31 22:13:55 NONE
+++ /project/slime/cvsroot/slime/swank-match.lisp 2009/10/31 22:13:55 1.1
;;
;; SELECT-MATCH macro (and IN macro)
;;
;; Copyright 1990 Stephen Adams
;;
;; You are free to copy, distribute and make derivative works of this
;; source provided that this copyright notice is displayed near the
;; beginning of the file. No liability is accepted for the
;; correctness or performance of the code. If you modify the code
;; please indicate this fact both at the place of modification and in
;; this copyright message.
;;
;; Stephen Adams
;; Department of Electronics and Computer Science
;; University of Southampton
;; SO9 5NH, UK
;;
;; sra at ecs.soton.ac.uk
;;
;;
;; Synopsis:
;;
;; (select-match expression
;; (pattern action+)*
;; )
;;
;; --- or ---
;;
;; (select-match expression
;; pattern => expression
;; pattern => expression
;; ...
;; )
;;
;; pattern -> constant ;egs 1, #\x, #c(1.0 1.1)
;; | symbol ;matches anything
;; | 'anything ;must be EQUAL
;; | (pattern = pattern) ;both patterns must match
;; | (#'function pattern) ;predicate test
;; | (pattern . pattern) ;cons cell
;;
;; Example
;;
;; (select-match item
;; (('if e1 e2 e3) 'if-then-else) ;(1)
;; ((#'oddp k) 'an-odd-integer) ;(2)
;; (((#'treep tree) = (hd . tl)) 'something-else) ;(3)
;; (other 'anything-else)) ;(4)
;;
;; Notes
;;
;; . Each pattern is tested in turn. The first match is taken.
;;
;; . If no pattern matches, an error is signalled.
;;
;; . Constant patterns (things X for which (CONSTANTP X) is true, i.e.
;; numbers, strings, characters, etc.) match things which are EQUAL.
;;
;; . Quoted patterns (which are CONSTANTP) are constants.
;;
;; . Symbols match anything. The symbol is bound to the matched item
;; for the execution of the actions.
;; For example, (SELECT-MATCH '(1 2 3)
;; (1 . X) => X
;; )
;; returns (2 3) because X is bound to the cdr of the candidate.
;;
;; . The two pattern match (p1 = p2) can be used to name parts
;; of the matched structure. For example, (ALL = (HD . TL))
;; matches a cons cell. ALL is bound to the cons cell, HD to its car
;; and TL to its tail.
;;
;; . A predicate test applies the predicate to the item being matched.
;; If the predicate returns NIL then the match fails.
;; If it returns truth, then the nested pattern is matched. This is
;; often just a symbol like K in the example.
;;
;; . Care should be taken with the domain values for predicate matches.
;; If, in the above eg, item is not an integer, an error would occur
;; during the test. A safer pattern would be
;; (#'integerp (#'oddp k))
;; This would only test for oddness of the item was an integer.
;;
;; . A single symbol will match anything so it can be used as a default
;; case, like OTHER above.
;;
(defpackage :swank-match
(:use :cl)
(:export #:match))
(in-package :swank-match)
(defmacro match (expression &body patterns)
`(select-match ,expression , at patterns))
(defmacro select-match (expression &rest patterns)
(let* ( (do-let (not (atom expression)))
(key (if do-let (gensym) expression))
(cbody (expand-select-patterns key patterns))
(cform `(cond . ,cbody))
)
(if do-let
`(let ((,key ,expression)) ,cform)
cform))
)
(defun expand-select-patterns (key patterns)
(if (eq (second patterns) '=>)
(expand-select-patterns-style-2 key patterns)
(expand-select-patterns-style-1 key patterns)))
(defun expand-select-patterns-style-1 (key patterns)
(if (null patterns)
`((t (error "Case select pattern match failure on ~S" ,key)))
(let ((pattern (caar patterns))
(actions (cdar patterns))
(rest (cdr patterns)) )
(let ( (test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`( ,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(if (eq test t)
nil
(expand-select-patterns-style-1 key rest)))
)
)
))
(defun expand-select-patterns-style-2 (key patterns)
(if (null patterns)
`((t (error "Case select pattern match failure on ~S" ,key)))
(let ((pattern (first patterns))
(arrow (if (or (< (length patterns) 3)
(not (eq (second patterns) '=>)))
(error "Illegal patterns: ~S" patterns)))
(actions (list (third patterns)))
(rest (cdddr patterns)) )
(let ( (test (compile-select-test key pattern))
(bindings (compile-select-bindings key pattern actions)))
`( ,(if bindings `(,test (let ,bindings . ,actions))
`(,test . ,actions))
. ,(if (eq test t)
nil
(expand-select-patterns-style-2 key rest)))
)
)
))
(defun compile-select-test (key pattern)
(let ((tests (remove-if
#'(lambda (item) (eq item t))
(compile-select-tests key pattern))))
(cond
;; note AND does this anyway, but this allows us to tell if
;; the pattern will always match.
((null tests) t)
((= (length tests) 1) (car tests))
(t `(and . ,tests)))))
(defun compile-select-tests (key pattern)
(cond ((constantp pattern) `((,(cond ((numberp pattern) 'eql)
((symbolp pattern) 'eq)
(t 'equal))
,key ,pattern)))
((symbolp pattern) '(t))
((select-double-match? pattern)
(append
(compile-select-tests key (first pattern))
(compile-select-tests key (third pattern))))
((select-predicate? pattern)
(append
`((,(second (first pattern)) ,key))
(compile-select-tests key (second pattern))))
((consp pattern)
(append
`((consp ,key))
(compile-select-tests (!cs-car key) (car
pattern))
(compile-select-tests (!cs-cdr key) (cdr
pattern))))
(t (error "Illegal select pattern: ~S" pattern))
)
)
(defun compile-select-bindings (key pattern action)
(cond ((constantp pattern) '())
((symbolp pattern)
(if (select!-in-tree pattern action) `((,pattern ,key))
'()))
((select-double-match? pattern)
(append
(compile-select-bindings key (first pattern) action)
(compile-select-bindings key (third pattern)
action)))
((select-predicate? pattern)
(compile-select-bindings key (second pattern)
action))
((consp pattern)
(append
(compile-select-bindings (!cs-car key) (car pattern)
action)
(compile-select-bindings (!cs-cdr key) (cdr pattern)
action)))
)
)
(defun select!-in-tree (atom tree)
(or (eq atom tree)
(if (consp tree)
(or (select!-in-tree atom (car tree))
(select!-in-tree atom (cdr tree))))))
(defun select-double-match? (pattern)
;; (<pattern> = <pattern>)
(and (consp pattern) (consp (cdr pattern)) (consp (cddr pattern))
(null (cdddr pattern))
(eq (second pattern) '=)))
(defun select-predicate? (pattern)
;; ((function <f>) <pattern>)
(and (consp pattern)
(consp (cdr pattern))
(null (cddr pattern))
(consp (first pattern))
(consp (cdr (first pattern)))
(null (cddr (first pattern)))
(eq (caar pattern) 'function)))
(defun !cs-car (exp)
(!cs-car/cdr 'car exp '(
(car . caar) (cdr . cadr) (caar . caaar) (cadr . caadr)
(cdar . cadar) (cddr . caddr)
(caaar . caaaar) (caadr . caaadr) (cadar . caadar)
(caddr . caaddr) (cdaar . cadaar) (cdadr . cadadr)
(cddar . caddar) (cdddr . cadddr))))
(defun !cs-cdr (exp)
(!cs-car/cdr 'cdr exp '(
(car . cdar) (cdr . cddr) (caar . cdaar) (cadr . cdadr)
(cdar . cddar) (cddr . cdddr)
(caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar)
(caddr . cdaddr) (cdaar . cddaar) (cdadr . cddadr)
(cddar . cdddar) (cdddr . cddddr))))
(defun !cs-car/cdr (op exp table)
(if (and (consp exp) (= (length exp) 2))
(let ((replacement (assoc (car exp) table)))
(if replacement
`(,(cdr replacement) ,(second exp))
`(,op ,exp)))
`(,op ,exp)))
;; (setf c1 '(select-match x (a 1) (b 2 3 4)))
;; (setf c2 '(select-match (car y)
;; (1 (print 100) 101) (2 200) ("hello" 5) (:x 20) (else (1+
;; else))))
;; (setf c3 '(select-match (caddr y)
;; ((all = (x y)) (list x y all))
;; ((a '= b) (list 'assign a b))
;; ((#'oddp k) (1+ k)))))
More information about the slime-cvs
mailing list