~ chicken-core (chicken-5) f912e5647a7a410908e0cfbbf5200ae980920364

commit f912e5647a7a410908e0cfbbf5200ae980920364
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jun 24 17:09:28 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jun 24 17:09:28 2011 +0200

    local specializations; added badass define-specialization

diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 08346d58..a1200aa6 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -1202,6 +1202,59 @@
     ((_ ((var type) ...) body ...)
      (let ((var (##core#the type var)) ...) body ...)))))
 
+(##sys#extend-macro-environment
+ 'define-specialization '()
+ (##sys#er-transformer
+  (lambda (x r c)
+    (cond ((memq #:csi ##sys#features) '(##core#undefined))
+	  (else
+	   (##sys#check-syntax 'define-specialization x '(_ (symbol . #(_ 0)) _ . #(_ 0 1)))
+	   (let* ((head (cadr x))
+		  (name (car head))
+		  (args (cdr head))
+		  (alias (gensym name))
+		  (rtypes (and (pair? (cdddr x)) (caddr x)))
+		  (%define (r 'define))
+		  (body (if rtypes (cadddr x) (caddr x))))
+	     (let loop ((args args) (anames '()) (atypes '()))
+	       (cond ((null? args)
+		      (let ((anames (reverse anames))
+			    (atypes (reverse atypes))
+			    (spec
+			     `(,alias ,@(let loop2 ((anames anames) (i 1))
+					 (if (null? anames)
+					     '()
+					     (cons (vector i)
+						   (loop2 (cdr anames) (fx+ i 1))))))))
+			(##sys#put! 
+			 name '##compiler#local-specializations
+			 (##sys#append
+			  (list
+			   (cons atypes
+				 (if rtypes
+				     (list rtypes spec)
+				     (list spec))))
+			  (or (##compiler#variable-mark 
+			       name '##compiler#local-specializations)
+			      '())))
+			`(##core#begin
+			  (##core#declare (inline ,alias) (hide ,alias))
+			  (,%define (,alias ,@anames)
+				    (##core#let ,(map (lambda (an at)
+							(list an `(##core#the ,at ,an)))
+						      anames atypes)
+						,body)))))
+		     (else
+		      (let ((arg (car args)))
+			(cond ((symbol? arg)
+			       (loop (cdr args) (cons arg anames) (cons '* atypes)))
+			      ((and (list? arg) (fx= 2 (length arg)) (symbol? (car arg)))
+			       (loop (cdr args) (cons (car arg) anames)
+				     (cons (cadr arg) atypes)))
+			      (else (##sys#syntax-error
+				     'define-specialization
+				     "invalid argument syntax" arg head)))))))))))))
+
 
 ;; capture current macro env
 
diff --git a/manual/Types b/manual/Types
index ebddf393..3cd55803 100644
--- a/manual/Types
+++ b/manual/Types
@@ -182,6 +182,26 @@ in unsafe mode any faster: compilation in unsafe mode will omit most
 type checks anyway. But specialization can often improve the
 performance of code compiled in safe (default) mode.
 
+Specializations can also be defined by the user:
+
+===== define-specialization
+
+<syntax>(define-specialization (NAME ARGUMENT ...) [RESULTS] BODY)</syntax>
+
+{{NAME}} should have a declared type (for example by using {{:}}).
+Declares the calls to the procedure {{NAME}} with arguments matching
+the types given in {{ARGUMENTS}} should be replaced by {{BODY}} (a
+single expression). If given, {{RESULTS}} (which follows the syntax
+given above under "Type Syntax") narrows the result type(s) if it
+differs from the result types previously declared for {{NAME}}.
+{{ARGUMENT}} should be an identifier naming the formal parameter or a
+list of the form {{(IDENTIFIER TYPE)}}. In the former case, this
+argument specializes on the {{*}} type. User-defined specializations
+are always local to the compilation unit in which they occur and can
+not be exported. When encountered in the interpreter,
+{{define-specialization}} does nothing and returns an unspecified
+result.
+
 
 ---
 Previous: [[Modules]]
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 6ce2190b..bf0ed22d 100755
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -72,6 +72,7 @@
 ;   ##compiler#declared-type   ->  BOOL
 ;   ##compiler#predicate       ->  TYPESPEC
 ;   ##compiler#specializations ->  (SPECIALIZATION ...)
+;   ##compiler#local-specializations ->  (SPECIALIZATION ...)
 ;   ##compiler#enforce         ->  BOOL
 ;   ##compiler#special-result-type -> PROCEDURE
 ;   ##compiler#escape          ->  #f | 'yes | 'no
@@ -471,6 +472,12 @@
 	 (lambda ()
 	   (pp (fragment x))))))
 
+    (define (get-specializations name)
+      (let* ((a (variable-mark name '##compiler#specializations))
+	     (b (variable-mark name '##compiler#local-specializations))
+	     (c (append (or a '()) (or b '()))))
+	(and (pair? c) c)))
+
     (define (call-result node args e loc params)
       (define (pname)
 	(sprintf "~ain procedure call to `~s', " 
@@ -550,7 +557,7 @@
 					       node
 					       `(let ((#(tmp) #(1))) '#f))
 					      (set! op (list pt `(not ,pt))))))))
-			     ((and specialize (variable-mark pn '##compiler#specializations)) =>
+			     ((and specialize (get-specializations pn)) =>
 			      (lambda (specs)
 				(let loop ((specs specs))
 				  (cond ((null? specs))
@@ -1092,8 +1099,7 @@
        (lambda (sym plist)
 	 (when (variable-visible? sym)
 	   (when (variable-mark sym '##compiler#declared-type)
-	     (let ((specs
-		    (or (variable-mark sym '##compiler#specializations) '()))
+	     (let ((specs (or (variable-mark sym '##compiler#specializations) '()))
 		   (type (variable-mark sym '##compiler#type))
 		   (pred (variable-mark sym '##compiler#predicate))
 		   (enforce (variable-mark sym '##compiler#enforce)))