ovidiu 02/01/18 18:13:19
Modified: src/scratchpad/schecoon/scheme sitemap.scm
Log:
Do some optimizations when generating the Scheme code for the
sitemap. Eliminate as many `let' forms as possible, to speed up the
compilation process.
Revision Changes Path
1.6 +66 -41 xml-cocoon2/src/scratchpad/schecoon/scheme/sitemap.scm
Index: sitemap.scm
===================================================================
RCS file: /home/cvs/xml-cocoon2/src/scratchpad/schecoon/scheme/sitemap.scm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- sitemap.scm 19 Jan 2002 01:20:12 -0000 1.5
+++ sitemap.scm 19 Jan 2002 02:13:19 -0000 1.6
@@ -61,7 +61,9 @@
;; parser to the SXML representation as attributes of the element.
;;
;; The Scheme code translates the above SXML representation in the
-;; following code.
+;; following code. [The code below actually does some optimizations to
+;; eliminate as many `let' forms as possible. This speeds up a bit the
+;; compilation process, but the code is semantically the same.]
;;
;;(define the-sitemap
;; (let ((rx1 (regexp "documentation/(.*).html"))
@@ -317,27 +319,28 @@
(let ((procname (string->symbol (format "p~a" pcount)))
(rxname (string->symbol (format "rx~a" pcount))))
`(define (,procname url sitemap env)
- (let ((result (regexp-match ,rxname url)))
- (if result
- (apply
- (lambda ,(let loop ((index 1))
- (if (> index pattern-regexps-no)
- 'rest
- (cons
- (string->symbol
- (format "arg~a" (number->string index)))
- (loop (+ index 1)))))
- (sitemap:process
- sitemap env '()
- ,(or
- (match-generate pipeline)
- (match-reader pipeline)
- (let* ((nodelist ((node-pos 1) pipeline))
- (node (if (null? nodelist) '() (car nodelist))))
- (xml-error node "Invalid pipeline definition")))))
- (cdr result))
- #f)))
- ))
+ ((lambda (result)
+ (if result
+ (apply
+ (lambda ,(let loop ((index 1))
+ (if (> index pattern-regexps-no)
+ 'rest
+ (cons
+ (string->symbol
+ (format "arg~a" (number->string index)))
+ (loop (+ index 1)))))
+ (sitemap:process
+ sitemap env '()
+ ,(or
+ (match-generate pipeline)
+ (match-reader pipeline)
+ (let* ((nodelist ((node-pos 1) pipeline))
+ (node (if (null? nodelist) '() (car nodelist))))
+ (xml-error node "Invalid pipeline definition")))))
+ (cdr result))
+ #f))
+ (regexp-match ,rxname url)))
+ ))
;; This is the main processing function for a 'match' node in the
;; SXML representation of the sitemap. This function returns an
@@ -384,25 +387,31 @@
sitemap
`((match . ,(lambda (node) (process-match node))))))
(sitemap-code
- `(let ,(let loop ((ms matchers))
- (if (null? ms)
- '()
- (cons (caar ms)
- (loop (cdr ms)))))
- ,@(let loop ((ms matchers))
- (if (null? ms)
- '()
- (cons (cdar ms)
- (loop (cdr ms)))))
- (lambda (url sitemap env)
- (or ,@(let loop ((index 1))
- (if (> index pcount)
- '()
- (cons
- (list (string->symbol (format "p~a" index))
- 'url 'sitemap 'env)
- (loop (+ index 1))))))))))
-; (newline) (write sitemap-code) (newline)
+ `((lambda (,@(let loop ((ms matchers))
+ (if (null? ms)
+ '()
+ (cons (caaar ms)
+ (loop (cdr ms))))))
+ ,@(let loop ((ms matchers))
+ (if (null? ms)
+ '()
+ (cons (cdar ms)
+ (loop (cdr ms)))))
+ (lambda (url sitemap env)
+ (or ,@(let loop ((index 1))
+ (if (> index pcount)
+ '()
+ (cons
+ (list (string->symbol (format "p~a" index))
+ 'url 'sitemap 'env)
+ (loop (+ index 1))))))))
+ ,@(let loop ((ms matchers))
+ (if (null? ms)
+ '()
+ (cons (cadaar ms)
+ (loop (cdr ms))))))
+ ))
+; (newline) (pretty-print sitemap-code) (newline)
(eval sitemap-code (interaction-environment))
)))
))
@@ -439,3 +448,19 @@
;; function is invoked from the SchemeSitemap#process method.
(define (main url sitemap environment)
(the-sitemap url sitemap environment))
+
+(define test-sitemap
+ '(pipelines (@ (*line* 1))
+ (pipeline (@ (*line* 2))
+ (match (@ (pattern "documentation/(.*).html") (*line* 3))
+ (generate (@ (src "docs/{1}.xml") (type "file") (*line* 4))
+ (param (@ (name "test") (value "123") (*line* 5))))
+ (transform (@ (src "stylesheets/document2html.xsl") (@ (*line* 6)))
+ (param (@ (name "test2") (value "456") (@ (*line* 7)))))
+ (serialize (@ (*line* 8)))
+ )
+
+ (match (@ (pattern "sites/images/(.*).gif") (*line* 10))
+ (read (@ (src "{1}") (mime-type "image/gif") (@ (*line* 11)))))
+ )))
+
----------------------------------------------------------------------
In case of troubles, e-mail: [EMAIL PROTECTED]
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
