Changeset 9764 in project


Ignore:
Timestamp:
03/15/08 20:52:28 (12 years ago)
Author:
Kon Lovett
Message:

syntax-case support.

Location:
release/3/hart/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/3/hart/trunk/fast_escape.c

    r8179 r9764  
    55/* a faster html escaping routine. */
    66
     7static
    78char *hart_html_escape(char *orig) {
    89  char *buf;
  • release/3/hart/trunk/hart-support.scm

    r8634 r9764  
     1;;;; hart-support.scm
     2
    13(use srfi-1 regex vector-lib)
    24
    3 (declare (export hart-parse hart-html-escape
    4                  hart-vector-for-each* hart-print))
     5(declare
     6  (usual-integrations)
     7  (fixnum)
     8  (no-procedure-checks)
     9  (no-bound-checks)
     10  (bound-to-procedure
     11    ##sys#print )
     12  (always-bound
     13    ##sys#standard-output )
     14  (export
     15    hart-parse
     16    hart-html-escape
     17    hart-vector-for-each*
     18    hart-print ) )
    519
    620;; todo: general optimizations; extensible keyword syntax.
     21
     22#>#include "fast_escape.c"<#
    723
    824;;;parser support
     
    2238  ;; replace it with (hart-print S).
    2339  (cond ((null? lst) (reverse acc))
    24         ((string? (car lst))
    25         (print-for-strings (cdr lst)
    26                             (cons (list 'hart-print (car lst))
    27                                   acc)))
    28         (#t (print-for-strings (cdr lst)
    29                                (cons (car lst) acc)))))
     40        ((string? (car lst))
     41        (print-for-strings (cdr lst)
     42                            (cons (list 'hart-print (car lst))
     43                                  acc)))
     44        (#t (print-for-strings (cdr lst)
     45                               (cons (car lst) acc)))))
    3046
    3147(define (hart-print . lst)
     
    3854    (for-each hart-parse-form forms)
    3955    (cons 'begin
    40           (print-for-strings (conc-strings (reverse (*hart-emitted*)))))))
     56          (print-for-strings (conc-strings (reverse (*hart-emitted*)))))))
    4157
    4258(define (hart-parse-form form)
    4359  (match form
    44         ('() (noop))
    45         ((? number?)
    46            (hart-emit (hart-html-escape form)))
    47         ((? string?)
    48            (hart-emit (hart-html-escape form)))
    49         ((? symbol? x)
    50            (hart-emit-single-tag x))
    51         (((? keyword? x) . rest)
    52           (hart-parse-keyword-form form))
    53         (((? symbol? x) . rest)
    54           (hart-parse-xml-form form))
    55         ))
     60        ('() (noop))
     61        ((? number?)
     62           (hart-emit (hart-html-escape form)))
     63        ((? string?)
     64           (hart-emit (hart-html-escape form)))
     65        ((? symbol? x)
     66           (hart-emit-single-tag x))
     67        (((? keyword? x) . rest)
     68          (hart-parse-keyword-form form))
     69        (((? symbol? x) . rest)
     70          (hart-parse-xml-form form))
     71        ))
    5672
    5773(define (hart-parse-xml-form form)
    5874  (match form
    59         ((tag) (hart-emit-single-tag tag))
    60         ((tag ('@ . attrs))
    61           (hart-emit-single-tag tag attrs))
    62         ((tag ('@ . attrs) . body)
    63           (hart-emit-opening-tag tag attrs)
    64           (map (lambda (form) (hart-parse-form form)) body)
    65           (hart-emit-closing-tag tag))
    66         ((tag . body)
    67           (hart-emit-opening-tag tag '())
    68           (map (lambda (form) (hart-parse-form form)) body)
    69           (hart-emit-closing-tag tag))
    70         ))
     75        ((tag) (hart-emit-single-tag tag))
     76        ((tag ('@ . attrs))
     77          (hart-emit-single-tag tag attrs))
     78        ((tag ('@ . attrs) . body)
     79          (hart-emit-opening-tag tag attrs)
     80          (map (lambda (form) (hart-parse-form form)) body)
     81          (hart-emit-closing-tag tag))
     82        ((tag . body)
     83          (hart-emit-opening-tag tag '())
     84          (map (lambda (form) (hart-parse-form form)) body)
     85          (hart-emit-closing-tag tag))
     86        ))
    7187
    7288
     
    7591
    7692(define (hart-parse-keyword-form form)
    77   (let ((keyword->symbol (compose string->symbol
    78                                   keyword->string)))
     93  (let ((keyword->symbol (compose string->symbol keyword->string)))
    7994    (match-let (((kwd . body) form))
    8095      (case kwd
    81         ((when: unless: let: let*: letrec:)
    82          (hart-emit `(,(keyword->symbol kwd) ,(car body)
    83                  ,@(map hart-parse (cdr body)))))
    84         ((begin:)
    85          (hart-emit `(,@(apply hart-parse body))))
    86         ((if:)
    87          (hart-emit `(if ,(first body)
    88                     ,(hart-parse (second body))
    89                     ,(hart-parse (third body)))))
    90         ((raw:)         
    91          (hart-emit `(hart-print ,@body)))
    92         ((t: text:)         
    93          (hart-emit `(apply hart-print (map hart-html-escape
    94                                    (list ,@body)))))
    95         ((fmt:)         
     96        ((when: unless: let: let*: letrec:)
     97         (hart-emit `(,(keyword->symbol kwd) ,(car body)
     98                                             ,@(map hart-parse (cdr body)))))
     99        ((begin:)
     100         (hart-emit `(,@(apply hart-parse body))))
     101        ((if:)
     102         (hart-emit `(if ,(first body)
     103                         ,(hart-parse (second body))
     104                         ,(hart-parse (third body)))))
     105        ((raw:)
     106         (hart-emit `(hart-print ,@body)))
     107        ((t: text:)
     108         (hart-emit `(apply hart-print (map hart-html-escape (list ,@body)))))
     109        ((fmt:)
    96110         (hart-emit `(hart-print (hart-html-escape (format ,@body)))))
    97         ((for:)
    98          (match-let (((kwd (iter lst) . body) form))
    99            (hart-emit `(hart-for (,iter ,lst)
    100                     ,@(map hart-parse body)))))
    101         ((scheme:)
    102           (hart-emit `(begin ,@body)))
    103         ((for-select:)
    104          (match-let (((kwd select-form . body) form))
    105            (hart-emit `(for-select ,@select-form
    106                                    ,@ (map hart-parse body)))))
    107         (else (error "unknown keyword" kwd))))))
     111        ((for:)
     112         (match-let (((kwd (iter lst) . body) form))
     113           (hart-emit `(hart-for (,iter ,lst) ,@(map hart-parse body)))))
     114        ((scheme:)
     115         (hart-emit `(begin ,@body)))
     116        ((for-select:)
     117         (match-let (((kwd select-form . body) form))
     118           (hart-emit `(for-select ,@select-form ,@(map hart-parse body)))))
     119        (else (error "unknown keyword" kwd))))))
    108120
    109121
     
    111123
    112124(define (hart-emit-tag tag single? attrs)
    113   (if (null? attrs)
    114       (hart-emit (format "<~a" tag))
    115       (begin
    116         (hart-emit (format "<~a" tag))
    117         (for-each
    118          (lambda (iter3)
    119            (match-let
    120             (((key value) iter3))
    121             (if ((disjoin string? number?) value)
    122                 (hart-emit (format " ~a=\"~a\"" key (hart-html-escape value)))
    123                 (hart-emit
    124                  (let ((val (gensym)))
    125                    `(let ((,val ,value))
    126                       (when ,val
    127                             (hart-print
    128                              ,(format " ~a=\"" key)
    129                              (hart-html-escape ,val)
    130                              "\""))))))))
    131          attrs)))
     125  (hart-emit (format "<~A" tag))
     126  (unless (null? attrs)
     127    (for-each
     128     (lambda (iter3)
     129       (match-let (((key value) iter3))
     130         (if ((disjoin string? number?) value)
     131             (hart-emit (format " ~A=\"~A\"" key (hart-html-escape value)))
     132             (hart-emit
     133              (let ((val (gensym)))
     134                `(let ((,val ,value))
     135                   (when ,val
     136                     (hart-print
     137                      ,(format " ~A=\"" key)
     138                      (hart-html-escape ,val)
     139                      "\""))))))))
     140     attrs) )
    132141  (hart-emit (if single? "/>" ">")))
    133142
     
    139148
    140149(define (hart-emit-closing-tag tag)
    141   (hart-emit (format "</~a>" tag)))
     150  (hart-emit (format "</~A>" tag)))
    142151
    143152
     
    146155(define hart-html-escape
    147156  (compose (foreign-lambda c-string* "hart_html_escape" c-string)
    148            ->string))
     157           ->string))
    149158
    150159(define (empty-string? s) (= (string-length s) 0))
     
    155164      acc
    156165      (receive (strings rest)
    157           (span string? lst)
    158         (receive (nonstrings rest2)
    159             (span (complement string?) rest)
    160           (let ((str (fold-right conc "" strings)))
    161             (conc-strings rest2
    162                           (append acc
    163                                   (if (empty-string? str)
    164                                       nonstrings
    165                                       (cons str nonstrings)))))))))
     166          (span string? lst)
     167        (receive (nonstrings rest2)
     168            (span (complement string?) rest)
     169          (let ((str (fold-right conc "" strings)))
     170            (conc-strings rest2
     171                          (append acc
     172                                  (if (empty-string? str)
     173                                      nonstrings
     174                                      (cons str nonstrings)))))))))
    166175
    167176;;; other
  • release/3/hart/trunk/hart.scm

    r8334 r9764  
    55;; stuff --- and do not want their return value.
    66
    7 (use hart-support)
     7(cond-expand
    88
    9 (define-macro (hart . forms)
    10   ;; prints to current-output-port
    11   `(noop ,(apply hart-parse forms)))
     9  [syntax-case
    1210
    13 (define-macro (hart->string . expressions)
    14   `(with-output-to-string (lambda () (noop ,(apply hart-parse
    15                                                    expressions)))))
     11    (require-extension matchable)
    1612
    17 (define-macro (hart-compile . expressions)
    18   ;; runtime compiling of a hart expression.
    19   `(lambda ()
    20      (noop ,(apply hart-parse (apply eval expressions)))))
     13    (define-syntax (hart X)
     14      (syntax-case X ()
     15        [(K FORM0 ...)
     16         (with-syntax ([EXP (datum->syntax-object #'K (apply hart-parse (syntax-object->datum #'(FORM0 ...))))])
     17           #'(noop EXP) ) ] ) )
    2118
    22 ;; some aliases, deprecated.
     19    (define-syntax (hart->string X)
     20      (syntax-case X ()
     21        [(K FORM0 ...)
     22         (with-syntax ([EXP (datum->syntax-object #'K (apply hart-parse (syntax-object->datum #'(FORM0 ...))))])
     23           #'(with-output-to-string (lambda () (noop EXP))) ) ] ) )
    2324
    24 (define-macro who hart)                 ;with-html-output
    25 (define-macro who/s hart->string)       ;with-html-output-to-string
     25    (define-syntax (hart-compile X)
     26      (syntax-case X ()
     27        [(K FORM0 ...)
     28         (with-syntax ([EXP (datum->syntax-object #'K (apply hart-parse (apply eval (syntax-object->datum #'(FORM0 ...)))))])
     29           #'(lambda () (noop EXP)) ) ] ) )
    2630
    27 ;;; FOR: a for-loop macro.
     31    (define-syntax hart-for
     32      (syntax-rules ()
     33        [(_ (ITER SEQ) EXPR0 ...)
     34         (let ([the-seq SEQ])
     35           ((if (list? the-seq) for-each hart-vector-for-each*)
     36              (lambda (real-iter)
     37                (match-let ((ITER real-iter))
     38                  EXPR0 ...))
     39              the-seq) ) ] ) ) ]
    2840
    29 (define-macro (hart-for args . body)
    30   (let ((real-iter (gensym 'iter))
    31         (foreach (gensym 'foreach))
    32         (lst (gensym 'list)))
    33     (match-let (((iter the-lst) args))
    34                `(let* ((,lst ,the-lst)
    35                        (,foreach (if (list? ,lst)
    36                                      for-each
    37                                      hart-vector-for-each*)))
    38                   (,foreach (lambda (,real-iter)
    39                               (match-let ((,iter ,real-iter))
    40                                          ,@body))
    41                             ,lst)))))
     41  [else
    4242
     43    (define-macro (hart . forms)
     44      ;; prints to current-output-port
     45      `(noop ,(apply hart-parse forms)))
     46
     47    (define-macro (hart->string . expressions)
     48      `(with-output-to-string (lambda () (noop ,(apply hart-parse
     49                                                       expressions)))))
     50
     51    (define-macro (hart-compile . expressions)
     52      ;; runtime compiling of a hart expression.
     53      `(lambda ()
     54         (noop ,(apply hart-parse (apply eval expressions)))))
     55
     56    ;; some aliases, deprecated.
     57
     58    (define-macro who hart)                 ;with-html-output
     59    (define-macro who/s hart->string)       ;with-html-output-to-string
     60
     61    ;;; FOR: a for-loop macro.
     62
     63    (define-macro (hart-for args . body)
     64      (let ((real-iter (gensym 'iter))
     65            (foreach (gensym 'foreach))
     66            (lst (gensym 'list)))
     67        (match-let (((iter the-lst) args))
     68         `(let* ((,lst ,the-lst)
     69                 (,foreach (if (list? ,lst)
     70                               for-each
     71                               hart-vector-for-each*)))
     72            (,foreach (lambda (,real-iter)
     73                        (match-let ((,iter ,real-iter))
     74                          ,@body))
     75                      ,lst))))) ] )
  • release/3/hart/trunk/hart.setup

    r8590 r9764  
    11;; -*- mode: scheme -*-
    22
    3 (run (csc -O1 -s hart-support.scm fast_escape.c))
     3(compile -O2 -d0 -s hart-support.scm)
    44
    55(install-extension
Note: See TracChangeset for help on using the changeset viewer.