Changeset 38716 in project for release

Timestamp:

05/30/20 00:18:26 (8 months ago)

Author:

Kon Lovett

Message:

split grammers, strict-types

Location:

release/5/slib-prec/trunk

Files:

• copyright.txt (deleted)
• output-grammars.scm (modified) (5 diffs)
• slib-basic-grammars.scm (added)
• slib-compat.scm (modified) (3 diffs)
• slib-grammar.scm (modified) (6 diffs)
• slib-prec-grammar.scm (modified) (5 diffs)
• slib-prec-parse.scm (added)
• slib-prec.egg (modified) (1 diff)
• slib-prec.scm (modified) (2 diffs)
• slib-standard-grammar.scm (added)
• slib-tex-grammar.scm (added)
• tests/run.scm (modified) (1 diff)
• tests/slib-prec-test.scm (modified) (5 diffs)

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

@@ +1 @@
+;;;; standard-grammar.scm  -*- Scheme -*-
+;;;; Kon Lovett, Apr '20
+
 ;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
 ;; Copyright (C) 1989, 1990, 1991, 1992, 1993, 1995, 1997, 2007, 2009, 2010 Aubrey Jaffer.
@@ -18 +21 @@
 ;;;; Here are the templates for 2 dimensional output
 
+(define tps:2d)
+#; ;cannot use
 (define tps:2d
   '(
@@ -86 +91 @@
     ))
 
+(define tps:c)
+#; ;cannot use
 (define tps:c
   '(
@@ -108 +115 @@
     ))
 
+(define tps:std)
+#; ;cannot use
 (define tps:std
   '(
@@ -137 +146 @@
     (^^ 210 #d1211 "^^" #d2210)
     ))
+
+(define tps:tex)
+#; ;cannot use
 (define tps:tex
   '(

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

@@ -3 +3 @@
 
 (import (only (srfi 1) every last-pair))
+(import (only (chicken port) call-with-output-string))
+(import (only (chicken pretty-print) pretty-print))
 
-(import (only (chicken port) call-with-output-string))
+(define mod modulo)
+
+(define (cleanup-handlers!) (begin))
 
 (define (find-if . args)
   (import (only (srfi 1) find))
-  (apply find args))
+  (apply find args) )
 
-(define (comlist:nthcdr n lst)
-  (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
+(define (remove-if. args)
+  (import (only (srfi 1) remove))
+  (apply remove args) )
 
-(define (last lst n)
-  (comlist:nthcdr (- (length lst) n) lst))
-
-(import (only (chicken pretty-print) pretty-print))
+(define last)
+(let ()
+  (define (comlist:nthcdr n lst)
+    (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
+  (set! last (lambda (lst n) (comlist:nthcdr (- (length lst) n) lst))) )
 
 ;;@ FORCE-OUTPUT flushes any pending output on optional arg output port
@@ -31 +37 @@
       (else       softtype)) ) )
 
-(define (output-port-width port)
+(define output-port-width)
+(define output-port-height)
+(let ()
   (import (only (chicken port) terminal-size))
-  (let-values (((h w)(terminal-size port)))
-    (if (zero? w) 80 w)))
-
-(define (output-port-height port)
-  (import (only (chicken port) terminal-size))
-  (let-values (((h w) (terminal-size port)))
-    (if (zero? h) 25 h)))
+  (set! output-port-width (lambda (port)
+    (let-values (((h w) (terminal-size port)))
+      (if (zero? w) 80 w))))
+  (set! output-port-height (lambda (port)
+    (let-values (((h w) (terminal-size port)))
+      (if (zero? h) 25 h)))) )
 
 (define provided?
   (let (
-    (+numeric+ '(inexact))
+    (+numeric+ '(inexact bignum))
     (+builtins+ '()) )
     (lambda (x)
@@ -90 +97 @@
 (define slib:tab #\tab)
 (define slib:form-feed #\page)
+
+(define (math:error . args) (apply slib:error 'math: args))
+(define (math:warn . args)  (apply slib:warn 'math: args))
+(define (math:exit b)       (cleanup-handlers!) (slib:error "error in math system"))

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

@@ -1 +1 @@
 ;;;; slib-grammar.scm
 
-;
+;;
+
 (define *grammar-ids* '())
 
@@ -27 +28 @@
 
 ;;from jacal unparse.scm
+
 (define (print-using-grammar sexp grm)
   ;(print "[" (grammar-name grm) "] " sexp)
   (pretty-print sexp)
-  #; ;needs most of jacal!
+  #; ;FIXME needs most of jacal!
   (template-print sexp (grammar-write-tab grm)) )
 
@@ -38 +40 @@
   (make-grammar name reader read-tab writer write-tab)
   grammar?
-  (name grammar-name)
+  (name grammar-name grammar-name-set!)
   (reader grammar-reader grammar-reader-set!)
   (read-tab grammar-read-tab grammar-read-tab-set!)
@@ -67 +69 @@
 
 ;
-(define (read-sexp grm icol) ((grammar-reader grm) grm icol))
-(define (write-sexp sexp grm) ((grammar-writer grm) sexp grm))
+(define (read-sexp grm column)  ((grammar-reader grm) grm column))
+(define (write-sexp sexp grm)   ((grammar-writer grm) sexp grm))
 
 (define *tab-stop* 8)
@@ -87 +89 @@
 ;;
 
-;
-(define (make-grm-parse-reader delim #!optional (port (current-input-port)))
-  (lambda (grm column)
+(define (make-delimited-parse-grammar-reader delim)
+  (lambda (grm column #!optional (port (current-input-port)))
     (prec:parse
       (grammar-read-tab grm)
@@ -96 +97 @@
       port)) )
 
-(define (read-sexp/delim grm delim port)
-  (unless (grammar? grm) (error 'read-sexp/delim "invalid grammar" grm))
-  (let (
-    (tmp (grammar-reader grm)) )
-    (grammar-reader-set! grm (make-grm-parse-reader delim port))
-    (let (
-      (res (read-sexp grm 0)) )
-      (grammar-reader-set! grm tmp)
-      res ) ) )
+;;
+
+(define (grammar-copy! grm1 grm2)
+  (grammar-name-set! grm1 (grammar-name grm2))
+  (grammar-reader-set! grm1 (grammar-reader grm2))
+  (grammar-read-tab-set! grm1 (grammar-read-tab grm2))
+  (grammar-writer-set! grm1 (grammar-writer grm2))
+  (grammar-read-tab-set! grm1 (grammar-write-tab grm2)) )
+
+(define temporary-grammar
+  (let ((+grammar-cache+ (make-grammar #f #f #f #f #f)))
+    (lambda (grm)
+      (grammar-copy! +grammar-cache+ grm)
+      +grammar-cache+ ) ) )
+
+(define (read-delimited-sexp port delim grm column)
+  (unless (grammar? grm) (error 'read-delimited-sexp "invalid grammar" grm))
+  (let ((tmp (temporary-grammar grm)))
+    (grammar-reader-set! tmp (make-delimited-parse-grammar-reader delim))
+    (parameterize ((current-input-port port))
+      (read-sexp tmp column) ) ) )

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

@@ -7 +7 @@
 (;export
   ;
-  active-grammar
-  active-grammar-set!
+  active-grammar active-grammar-set!
+  active-input-grammar active-output-grammar active-echo-grammar
   read-syntax-setup!
   ;
@@ -33 +33 @@
   clear-grammars
   ;
+  make-delimited-parse-grammar-reader
   read-sexp
   write-sexp
@@ -41 +42 @@
 (import (chicken base))
 (import (chicken type))
-(import slib-prec)
+(import slib-prec-parse)
 
 ;;;
 
-(define mod modulo)
+(include "slib-compat")
+(include "slib-grammar")
 
-(include "slib-compat")
-
-(define (math:error . args) (apply slib:error 'math: args))
-(define (math:warn . args) (apply slib:warn 'math: args))
-(define (math:exit b) #;(cleanup-handlers!) (slib:error "error in math system"))
-
-(include "slib-grammar")
+;;
 
 (define *input-grammar*)
 (define *output-grammar*)
 (define *echo-grammar*)
-
-(include "output-grammars")
-(include "input-grammars")
-
-(defgrammar 'null
-  (make-grammar
-    'null
-                (lambda (grm) (math:error 'cannot-read-null-grammar))
-                #f
-                (lambda (sexp grm) #t)
-                #f))
-
-(defgrammar 'scheme
-  (make-grammar
-    'scheme
-                (lambda (grm) (read))
-                #f
-                (lambda (sexp grm) (write sexp) (force-output))
-                #f))
-
-;;; Establish autoload for PRETTY-PRINT.
-(defgrammar 'schemepretty
-  (make-grammar
-    'schemepretty
-    (lambda (grm)
-      (read) )
-    #f
-    (lambda (sexp grm)
-      (import (chicken pretty-print))
-      (pretty-print sexp)
-      (force-output) )
-    #f))
 
 (define (active-grammar-set! input output #!optional (echo 'null))
@@ -96 +60 @@
   (set! *echo-grammar* echo) )
 
-(define (active-grammar) (values *input-grammar* *output-grammar* *echo-grammar*))
+(define (active-grammar)
+  (values *input-grammar* *output-grammar* *echo-grammar*) )
+
+(define (active-input-grammar) (receive (i o e) (active-grammar) i))
+(define (active-output-grammar) (receive (i o e) (active-grammar) o))
+(define (active-echo-grammar) (receive (i o e) (active-grammar) e))
 
 ;;
@@ -103 +72 @@
   (import (only (chicken base) parentheses-synonyms))
   (import (only (chicken read-syntax) set-sharp-read-syntax! set-parameterized-read-syntax!))
-  (parentheses-synonyms #f)
   (set-sharp-read-syntax! #\{
     (lambda (port)
-      (read-sexp/delim (get-grammar/id 0) #\} port)))
+      (parameterize ((parentheses-synonyms #f))
+        (read-delimited-sexp port #\} (get-grammar/id 0) 0))))
   (set-parameterized-read-syntax! #\{
     (lambda (port id)
-      (read-sexp/delim (get-grammar/id id) #\} port))) )
-
-;;
-
-;init by id-# grammar lookup
-(define-constant DEFAULT-GRAMMARS '(
-  standard disp2d tex
-  null scheme schemepretty))
-(grammar-id-name-setup! DEFAULT-GRAMMARS)
+      (parameterize ((parentheses-synonyms #f))
+        (read-delimited-sexp port #\} (get-grammar/id id) 0)))) )
 
 ) ;slib-prec-grammar

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

@@ -13 +13 @@
  (test-dependencies test)
  (components
+  (extension slib-prec-read-syntax
+    (types-file)
+    (component-dependencies slib-prec-grammar)
+    (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
   (extension slib-prec-grammar
     (types-file)
-    (component-dependencies slib-prec)
-    ;no -local since must allow assignment to imported value bindings; ex: `*input-grammar*'
-    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
+    (component-dependencies slib-prec-parse)
+    (csc-options "-O3" "-d1" "-local" "-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"))
+  (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"))
+  (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"))
+  (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"))
   (extension slib-prec
     (types-file)
-    ;no -local since must allow assignment to imported value bindings; ex: `*syn-defs*'
-    ;suspect -strict-types might be an issue
-    (csc-options "-O3" "-d1" "-D" "utf8" "-no-procedure-checks-for-toplevel-bindings")) ) )
+    (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"))  ) )

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

@@ -10 +10 @@
 
 (;export
-  ;
-  syntax-end!                 ; (set! *syn-defs* '())   => (syntax-end!)
-  syntax-begin!               ; (set! *syn-def* ...)    => (syntax-begin! ...)
-  syntax-current              ; *syn-def*               => (syntax-current)
-  syntax-ignore-whitespace    ; *syn-ignore-whitespace* => (syntax-ignore-whitespace)
-  ;
-  char-code-limit
-  tok:decimal-digits
-  tok:upper-case
-  tok:lower-case
-  tok:whitespaces
-  tok:char-group
-  tok:read-char
-  ;
-  prec:define-grammar
-  prec:parse
-  prec:make-led
-  prec:make-nud
-  prec:delim
-  prec:nofix
-  prec:prefix
-  prec:infix
-  prec:infixr
-  prec:nary
-  prec:postfix
-  prec:prestfix
-  prec:commentfix
-  prec:matchfix
-  prec:inmatchfix)
+  read-sexp-from-string)
 
 (import scheme)
+(import (chicken module))
 (import (chicken base))
+
+(import slib-prec-parse)
+(reexport slib-prec-parse)
+
+(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)) )
 
 ;;;
 
-(cond-expand
-  (utf8
-    (import (rename scheme
-        (char-whitespace? scheme:char-whitespace?)
-        (char-alphabetic? scheme:char-alphabetic?)
-        (char-upper-case? scheme:char-upper-case?)
-        (char-lower-case? scheme:char-lower-case?)
-        (char-numeric? scheme:char-numeric?)))
-    (import (chicken foreign))
-    (import utf8)
-    (import utf8-srfi-13)
-    (import utf8-case-map)
-    (import utf8-srfi-14)
-    (import unicode-char-sets)
-
-    ;; UTF-8 char predicates
-
-    (define charset-alphabetic?)
-    (define charset-upper-case?)
-    (define charset-lower-case?)
-    (define charset-whitespace?)
-    (define charset-numeric?)
-    (define charset-hex-numeric?)
-    (let ()
-      (define ((charset-predicate cs) ch) (char-set-contains? cs ch))
-      (set! charset-alphabetic? (charset-predicate char-set:alphabetic))
-      (set! charset-upper-case? (charset-predicate char-set:uppercase))
-      (set! charset-lower-case? (charset-predicate char-set:lowercase))
-      (set! charset-whitespace? (charset-predicate char-set:white-space))
-      (set! charset-numeric? (charset-predicate char-set:digit))
-      (set! charset-hex-numeric? (charset-predicate char-set:hex-digit)) )
-    (define char-hex-numeric? charset-hex-numeric?)
-
-    ;Character range is that of a UTF-8 codepoint, not representable range
-    (define char-code-limit (foreign-value "C_CHAR_BIT_MASK" unsigned-int)))
-  (else
-    (import srfi-13)
-    (import srfi-14)
-    ; "Extended" ASCII
-    (define char-code-limit 256)) )
-
-;; SLIB Code
-
-(import (only (chicken port) call-with-output-string))
-
-(include "slib-compat")
-
-(include "strsrch")
-
-; these shouldn't be literals
-(define *prec:comment-start* 200)
-(define *prec:comment-weight* 220)
-
-(include "prec")
-
-;FIXME fixes what by duplicating `tok:read-through-comment' behavior?
-(set! prec:commentfix (lambda (tk stp match . binds)
-  ;;from tok:read-through-comment
-  (set! match (if (char? match)
-                  (string match)
-                  (prec:de-symbolfy match)))
-  (append
-   (prec:make-nud tk prec:parse-nudcomment stp match (apply append binds))
-   (prec:make-led tk *prec:comment-weight* prec:parse-ledcomment stp match (apply append binds)))))
-
-(define (syntax-begin! #!optional (base '()))   (set! *syn-defs* base))
-(define (syntax-end!)                           (set! *syn-defs* '()))
-(define (syntax-current)                        *syn-defs*)
-(define (syntax-ignore-whitespace)              *syn-ignore-whitespace*)
-
-(include "prec-setup")
-
-;;
-
-(define (prec:infixr tk sop lbp . binds)
-  (let* (
-    (bp (and (not (null? binds)) (number? (car binds)) (car binds)))
-    (binds (if bp (cdr binds) binds))
-    (bp (or bp (max 0 (- lbp 1)))) )
-    (apply prec:infix tk sop lbp bp binds) ) )
-
+#|
 ;;
 
@@ -162 +72 @@
 (define (*eval-grammer-form loc imd base)
   (begin) )
+|#
 
 ) ;slib-prec

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

@@ -71 +71 @@
 ;;; Do Test
 
-(run-tests)
+(run-test)
+;(run-tests)

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

@@ -6 +6 @@
 
 (import slib-prec)
-(import slib-prec-grammar)
+
+;;
 
 ;;;
@@ -14 +15 @@
 (import utf8-srfi-13)
 
+;; Operator Aliaes
+
+(define ^ expt)
+
 ;;
 
-(active-grammar-set! 'standard 'disp2d 'schemepretty)
-(define ^ expt)
+;init by id-# grammar lookup
+;(define-constant DEFAULT-GRAMMARS '(standard disp2d tex null scheme schemepretty))
+(define DEFAULT-GRAMMARS '(standard disp2d tex null scheme schemepretty))
+(clear-grammar-ids)
+(grammar-id-name-setup! DEFAULT-GRAMMARS)
+;(grammar-id-name-setup! `(,@DEFAULT-GRAMMARS))
 
-(define (active-input-grammar) (receive (i o e) (active-grammar) i))
+(active-grammar-set! 'standard #f 'schemepretty)
 
 ;;
 
 (test-group "Grammer IDs"
-  (test 6 (count-of-grammar-ids))
+  (test (length DEFAULT-GRAMMARS) (count-of-grammar-ids))
   (test 'standard (grammar-id-name 0))
   (test 'scheme (grammar-id-name 4))
@@ -31 +40 @@
 ;;
 
-(define (read-sexp/string str #!optional (grm (active-input-grammar)) (icol 0))
- (import (only (chicken port) with-input-from-string))
- (with-input-from-string str (lambda () (read-sexp grm icol))) )
-
 (define-syntax test-parse
   (syntax-rules ()
     ((test-parse ?out ?in)
-      (test ?in ?out (read-sexp/string ?in)) )
+      (test ?in ?out (read-sexp-from-string ?in)) )
     ((test-parse ?msg ?out ?in)
-      (test ?msg ?out (read-sexp/string ?in)) ) ) )
+      (test ?msg ?out (read-sexp-from-string ?in)) ) ) )
 
 (test-group "Jacal Grammar (English)"
@@ -52 +57 @@
   (test-parse "N/D (ratio) => (/ N D)" '(/ (* (+ 1 2) 1) 5) "(1 + 2) * 1/5")
 
-  (test 15 (eval (read-sexp/string "(1 + 2) * 5;")))
-  (test 15.0 (eval (read-sexp/string "(1.0 + 2) * 5")))
-  (test 3/5 (eval (read-sexp/string "(1 + 2) * 1/5")))
+  (test 15 (eval (read-sexp-from-string "(1 + 2) * 5;")))
+  (test 15.0 (eval (read-sexp-from-string "(1.0 + 2) * 5")))
+  (test 3/5 (eval (read-sexp-from-string "(1 + 2) * 1/5")))
 
-  (test 8 (eval (read-sexp/string "2**3")))
+  (test 8 (eval (read-sexp-from-string "2**3")))
 )
 
@@ -80 +85 @@
   (test #(1) #0{[1]})       ;(vector 1)
   (test #(1) #1{[1]})       ;(vector 1)
-  (test #(1) #2{[1]})       ;(vector 1)
 )
 |#