Changeset 28037 in project for release/4/honu/trunk/honu.scm

Timestamp:

01/05/13 22:12:13 (8 years ago)

Author:

felix winkelmann

Message:

extended signature to use keywords and allow flavors

File:

• release/4/honu/trunk/honu.scm (modified) (5 diffs)

release/4/honu/trunk/honu.scm

@@ -9 +9 @@
 
 (define-constant +operator-chars+
-  '(#\- #\+ #\/ #\? #\: #\* #\% #\& #\! #\. #\~ #\_ #\| #\> #\< #\= #\^ #\\ #\@) )
-
-(define (read-honu #!optional (port (current-input-port)) line-numbers lnwrap)
+  '(#\- #\+ #\/ #\? #\: #\* #\% #\& #\! #\. #\~ #\_ #\| #\> #\< #\= #\^) )
+
+;; variant to keep old signature working
+(define (read-honu . args)
+  (apply
+   (if (and (pair? args) (keyword? (car args)))
+      read-honu-expression
+      (lambda (#!optional (port (current-input-port)) ln lnw (flv 'vanilla-flavor))
+        (read-honu-expression port: port line-numbers: ln lnwrap: lnw flavor: flv)))
+   args))       
+
+(define (read-honu-expression #!key (port (current-input-port)) 
+                              line-numbers
+                              lnwrap
+                              (flavor 'vanilla-flavor))
   (let ((ln (nth-value 0 (port-position port))))
     (define (lnw x)
@@ -19 +31 @@
        error 'read-honu
        (string-append msg (if line-numbers (conc " in line " ln) "")) args) )
-    (define (opchar? c) (memq c +operator-chars+))
+    (define opchar?
+      (case flavor
+        ((prolog-flavor)
+         (lambda (c)
+           (or (memq c +operator-chars+)
+               (memq c '(#\@ #\\)))))
+        (else (cut memq <> +operator-chars+))))
     (define (skip)
       (let ((c (peek-char port)))
@@ -30 +48 @@
                (read-char port)
                (skip) )
-              ((char=? #\/ c)
+              ((and (char=? #\% c)
+                    (eq? flavor 'prolog-flavor))
+               (skip-line))
+              ((and (char=? #\/ c)
+                    (not (eq? flavor 'prolog-flavor)))
                (read-char port)
                (let ((c (peek-char port)))
                  (case c
-                   ((#\/) 
-                    (read-line port)
-                    (set! ln (fx+ ln 1))
-                    (skip) )
+                   ((#\/) (skip-line))
                    ((#\*) (skip-comment) (skip))
                    (else
@@ -45 +64 @@
                         (lnw '/) ) ) ) ) )
               (else #f) ) ) )
+    (define (skip-line)
+      (read-line port)
+      (set! ln (fx+ ln 1))
+      (skip))
     (define (scan)
       (or (skip)
@@ -66 +89 @@
                             ((string=? "sx" t) (read port)) 
                             (else (err "invalid escape syntax" (conc "#" t))) ) ) ) ) ) )
-              ((#\') 
+              ((#\')
                (read-char port)
                (let ((s (read-escaped (lambda (c) (char=? #\' c)))))
-                 (if (zero? (string-length s))
-                     (err "empty character literal")
-                     (lnw (string-ref s 0) ) ) ) )
+                 (case flavor
+                   ((prolog-flavor) (lnw (string->symbol s)))
+                   ((javascript-flavor) (lnw s))
+                   (else
+                    (if (zero? (string-length s))
+                        (err "empty character literal")
+                        (lnw (string-ref s 0) ) ) ) ) ) )
               ((#\,) (read-char port) (lnw '|,|))
               ((#\;) (read-char port) (lnw '|;|))