Changeset 38717 in project for release

Timestamp:

05/30/20 19:58:54 (2 months ago)

Author:

Kon Lovett

Message:

move grammer record into module, remove redundant -local, add #{..} read-syntax module, grammer define not automatic w/o syntax

Location:

release/5/slib-prec/trunk

Files:

• slib-grammar.scm (deleted)
• slib-prec-grammar.scm (modified) (5 diffs)
• slib-prec-parse.scm (modified) (1 diff)
• slib-prec-read-syntax.scm (added)
• slib-prec.egg (modified) (2 diffs)
• slib-prec.scm (modified) (3 diffs)
• tests/slib-prec-test.scm (modified) (3 diffs)

release/5/slib-prec/trunk/slib-prec-grammar.scm

@@ -9 +9 @@
   active-grammar active-grammar-set!
   active-input-grammar active-output-grammar active-echo-grammar
-  read-syntax-setup!
   ;
   make-grammar
@@ -19 +18 @@
   grammar-write-tab
   ;
-  grammar-id-name-set!
   grammar-id-name
   list-of-grammar-ids
@@ -33 +31 @@
   clear-grammars
   ;
-  make-delimited-parse-grammar-reader
   read-sexp
   write-sexp
   print-using-grammar
-  flush-input-whitespace)
+  flush-input-whitespace
+  ;
+  make-delimited-parse-grammar-reader
+  make-delimited-sexp-reader
+  read-sexp-from-string)
 
 (import scheme)
 (import (chicken base))
 (import (chicken type))
+(import (only (srfi 1) iota))
 (import slib-prec-parse)
 
@@ -47 +49 @@
 
 (include "slib-compat")
-(include "slib-grammar")
+
+;;
+
+(define *grammar-ids* '())
+
+(define (grammar-id-name-set! id name)
+  (set! *grammar-ids* (alist-update! id name *grammar-ids* eqv?)) )
+
+(define (grammar-id-name id)
+  (alist-ref id *grammar-ids* eqv?) )
+
+(define (list-of-grammar-ids)
+  (map car *grammar-ids*) )
+
+(define (count-of-grammar-ids)
+  (length *grammar-ids*) )
+
+(define (clear-grammar-ids)
+  (set! *grammar-ids* '()) )
+
+;ordered list of grammar names
+(define (grammar-id-name-setup! names)
+  (clear-grammar-ids)
+  (for-each grammar-id-name-set! (iota (length names)) names) )
+
+;;
+
+;;from jacal unparse.scm
+
+(define (print-using-grammar sexp grm)
+  ;(print "[" (grammar-name grm) "] " sexp)
+  (pretty-print sexp)
+  #; ;FIXME needs most of jacal!
+  (template-print sexp (grammar-write-tab grm)) )
+
+; supplies module based struct tag & other identifiers
+(define-record grammar name reader read-tab writer write-tab)
+(define-record-type grammar
+  (make-grammar name reader read-tab writer write-tab)
+  grammar?
+  (name grammar-name grammar-name-set!)
+  (reader grammar-reader grammar-reader-set!)
+  (read-tab grammar-read-tab grammar-read-tab-set!)
+  (writer grammar-writer grammar-writer-set!)
+  (write-tab grammar-write-tab grammar-write-tab-set!) )
+
+(define (grammar-copy! grm1 grm2 #!key name reader read-tab writer write-tab)
+  (grammar-name-set! grm1 (or name (grammar-name grm2)))
+  (grammar-reader-set! grm1 (or reader (grammar-reader grm2)))
+  (grammar-read-tab-set! grm1 (or read-tab (grammar-read-tab grm2)))
+  (grammar-writer-set! grm1 (or writer (grammar-writer grm2)))
+  (grammar-write-tab-set! grm1 (or write-tab (grammar-write-tab grm2))) )
+
+;
+(define *grammars* '())
+
+(define (defgrammar name grm)
+  (set! *grammars* (alist-update! name grm *grammars* eq?)) )
+
+(define (get-grammar name)
+  (alist-ref name *grammars* eq?) )
+
+(define (list-of-grammars)
+  (map (lambda (cell) (car cell)) *grammars*) )
+
+(define (count-of-grammars)
+  (length *grammars*) )
+
+(define (get-grammar/id id)
+  (get-grammar (grammar-id-name id)) )
+
+(define (clear-grammars)
+  (clear-grammar-ids)
+  (set! *grammar* '()) )
+
+;;
+
+;
+(define (read-sexp grm column)  ((grammar-reader grm) grm column))
+(define (write-sexp sexp grm)   ((grammar-writer grm) sexp grm))
+
+(define *tab-stop* 8)
+
+;
+(define (flush-input-whitespace port)
+  (do ((chr (peek-char port) (peek-char port))
+       (col 0 (case chr
+                ((#\space)    (+ 1 col))
+                ((#\tab)      (modulo (+ (sub1 *tab-stop*) col) *tab-stop*))
+                ((#\newline)  0)
+                (else         col))))
+      ((or (eof-object? chr)
+           (not (char-whitespace? chr)))
+       col)
+    (read-char port)))
+
+;;
+
+(define (make-delimited-parse-grammar-reader delim)
+  (lambda (grm column #!optional (port (current-input-port)))
+    (prec:parse
+      (grammar-read-tab grm)
+      delim
+      (+ column (flush-input-whitespace port))
+      port)) )
+
+(define (make-delimited-sexp-reader port delim)
+  (lambda (grm column)
+    (define temporary-grammar
+      (let ((+grammar-cache+ (make-grammar #f #f #f #f #f)))
+        (lambda (grm . args)
+          (apply grammar-copy! +grammar-cache+ grm args)
+          +grammar-cache+ ) ) )
+    (let ((grm* (temporary-grammar grm #:reader (make-delimited-parse-grammar-reader delim))))
+      ;ugly but SLIB prec kinda assumes
+      (parameterize ((current-input-port port))
+        (read-sexp grm* column) ) ) ) )
+
+;;
+
+(define (read-sexp-from-string str #!optional (grm (active-input-grammar)) (column 0))
+  (import (only (chicken port) with-input-from-string))
+  (with-input-from-string str (cut read-sexp grm column)) )
 
 ;;
@@ -67 +191 @@
 (define (active-echo-grammar) (receive (i o e) (active-grammar) e))
 
-;;
-
-(define (read-syntax-setup!)
-  (import (only (chicken base) parentheses-synonyms))
-  (import (only (chicken read-syntax) set-sharp-read-syntax! set-parameterized-read-syntax!))
-  (set-sharp-read-syntax! #\{
-    (lambda (port)
-      (parameterize ((parentheses-synonyms #f))
-        (read-delimited-sexp port #\} (get-grammar/id 0) 0))))
-  (set-parameterized-read-syntax! #\{
-    (lambda (port id)
-      (parameterize ((parentheses-synonyms #f))
-        (read-delimited-sexp port #\} (get-grammar/id id) 0)))) )
-
 ) ;slib-prec-grammar

release/5/slib-prec/trunk/slib-prec-parse.scm

@@ -1 +1 @@
 ;;;; slib-prec-parse.scm  -*-scheme-*-
 ;;;; Kon Lovett, Apr '20
-;;;; Kon Lovett, Apr '18
 
 ;; Issues

release/5/slib-prec/trunk/slib-prec.egg

@@ -9 +9 @@
  (maintainer "[[kon lovett]]")
  (license "SLIB")
- (dependencies
-        (utf8 "3.5.0"))
+ (dependencies utf8)
  (test-dependencies test)
  (components
@@ -16 +15 @@
     (types-file)
     (component-dependencies slib-prec-grammar)
-    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
   (extension slib-prec-grammar
     (types-file)
     (component-dependencies slib-prec-parse)
-    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
   (extension slib-prec-parse
     (types-file)
     ;suspect -strict-types might be an issue
-    (csc-options "-O3" "-d1" "-local" "-D" "utf8" "-no-procedure-checks-for-toplevel-bindings"))
+    (csc-options "-O3" "-d1" "-D" "utf8" "-no-procedure-checks-for-toplevel-bindings"))
   (extension slib-basic-grammars
     (types-file)
     (component-dependencies slib-prec-parse slib-prec-grammar)
-    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
   (extension slib-standard-grammar
     (types-file)
     (component-dependencies slib-prec-parse slib-prec-grammar)
-    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
   (extension slib-tex-grammar
     (types-file)
     (component-dependencies slib-prec-parse slib-prec-grammar)
-    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
   (extension slib-prec
     (types-file)
     (component-dependencies slib-prec-grammar slib-prec-parse slib-standard-grammar slib-basic-grammars)
-    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))  ) )
+    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))  ) )

release/5/slib-prec/trunk/slib-prec.scm

@@ -1 +1 @@
 ;;;; slib-prec.scm  -*-scheme-*-
 ;;;; Kon Lovett, Apr '20
-;;;; Kon Lovett, Apr '18
 
 ;; Issues
@@ -7 +6 @@
 ;; - needs a "surface notation"
 
-(module slib-prec
-
-(;export
-  read-sexp-from-string)
+(module slib-prec ()
 
 (import scheme)
@@ -21 +17 @@
 (import slib-prec-grammar)
 (reexport slib-prec-grammar)
-
-;defgrammar doesn't define
-(import slib-basic-grammars)
-(import slib-standard-grammar)
-(import slib-tex-grammar)
-
-;;
-
-(define (read-sexp-from-string str #!optional (grm (active-input-grammar)) (column 0))
-  (import (only (chicken port) with-input-from-string))
-  (with-input-from-string str (cut read-sexp grm column)) )
 
 ;;;

release/5/slib-prec/trunk/tests/slib-prec-test.scm

@@ -1 @@
-;;;; slib-prec-test.scm
+;;;; slib-prec-test.scm  -*- scheme -*-
+;;;; Kon Lovett, Apr '20
 
 (import test)
@@ -18 +19 @@
 
 (define ^ expt)
+(define mod modulo)
 
 ;;
 
+;defgrammar doesn't `define'
+(import slib-basic-grammars)
+(import slib-standard-grammar)
+(import slib-tex-grammar)
+
 ;init by id-# grammar lookup
-;(define-constant DEFAULT-GRAMMARS '(standard disp2d tex null scheme schemepretty))
-(define DEFAULT-GRAMMARS '(standard disp2d tex null scheme schemepretty))
+(define-constant TEST-GRAMMARS '(standard disp2d tex null scheme schemepretty))
 (clear-grammar-ids)
-(grammar-id-name-setup! DEFAULT-GRAMMARS)
-;(grammar-id-name-setup! `(,@DEFAULT-GRAMMARS))
-
+(grammar-id-name-setup! TEST-GRAMMARS)
 (active-grammar-set! 'standard #f 'schemepretty)
 
@@ -33 +37 @@
 
 (test-group "Grammer IDs"
-  (test (length DEFAULT-GRAMMARS) (count-of-grammar-ids))
+  (test (length TEST-GRAMMARS) (count-of-grammar-ids))
   (test 'standard (grammar-id-name 0))
   (test 'scheme (grammar-id-name 4))