Changeset 38717 in project for release


Ignore:
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:
1 added
1 deleted
5 edited

Legend:

Unmodified
Added
Removed
  • release/5/slib-prec/trunk/slib-prec-grammar.scm

    r38716 r38717  
    99  active-grammar active-grammar-set!
    1010  active-input-grammar active-output-grammar active-echo-grammar
    11   read-syntax-setup!
    1211  ;
    1312  make-grammar
     
    1918  grammar-write-tab
    2019  ;
    21   grammar-id-name-set!
    2220  grammar-id-name
    2321  list-of-grammar-ids
     
    3331  clear-grammars
    3432  ;
    35   make-delimited-parse-grammar-reader
    3633  read-sexp
    3734  write-sexp
    3835  print-using-grammar
    39   flush-input-whitespace)
     36  flush-input-whitespace
     37  ;
     38  make-delimited-parse-grammar-reader
     39  make-delimited-sexp-reader
     40  read-sexp-from-string)
    4041
    4142(import scheme)
    4243(import (chicken base))
    4344(import (chicken type))
     45(import (only (srfi 1) iota))
    4446(import slib-prec-parse)
    4547
     
    4749
    4850(include "slib-compat")
    49 (include "slib-grammar")
     51
     52;;
     53
     54(define *grammar-ids* '())
     55
     56(define (grammar-id-name-set! id name)
     57  (set! *grammar-ids* (alist-update! id name *grammar-ids* eqv?)) )
     58
     59(define (grammar-id-name id)
     60  (alist-ref id *grammar-ids* eqv?) )
     61
     62(define (list-of-grammar-ids)
     63  (map car *grammar-ids*) )
     64
     65(define (count-of-grammar-ids)
     66  (length *grammar-ids*) )
     67
     68(define (clear-grammar-ids)
     69  (set! *grammar-ids* '()) )
     70
     71;ordered list of grammar names
     72(define (grammar-id-name-setup! names)
     73  (clear-grammar-ids)
     74  (for-each grammar-id-name-set! (iota (length names)) names) )
     75
     76;;
     77
     78;;from jacal unparse.scm
     79
     80(define (print-using-grammar sexp grm)
     81  ;(print "[" (grammar-name grm) "] " sexp)
     82  (pretty-print sexp)
     83  #; ;FIXME needs most of jacal!
     84  (template-print sexp (grammar-write-tab grm)) )
     85
     86; supplies module based struct tag & other identifiers
     87(define-record grammar name reader read-tab writer write-tab)
     88(define-record-type grammar
     89  (make-grammar name reader read-tab writer write-tab)
     90  grammar?
     91  (name grammar-name grammar-name-set!)
     92  (reader grammar-reader grammar-reader-set!)
     93  (read-tab grammar-read-tab grammar-read-tab-set!)
     94  (writer grammar-writer grammar-writer-set!)
     95  (write-tab grammar-write-tab grammar-write-tab-set!) )
     96
     97(define (grammar-copy! grm1 grm2 #!key name reader read-tab writer write-tab)
     98  (grammar-name-set! grm1 (or name (grammar-name grm2)))
     99  (grammar-reader-set! grm1 (or reader (grammar-reader grm2)))
     100  (grammar-read-tab-set! grm1 (or read-tab (grammar-read-tab grm2)))
     101  (grammar-writer-set! grm1 (or writer (grammar-writer grm2)))
     102  (grammar-write-tab-set! grm1 (or write-tab (grammar-write-tab grm2))) )
     103
     104;
     105(define *grammars* '())
     106
     107(define (defgrammar name grm)
     108  (set! *grammars* (alist-update! name grm *grammars* eq?)) )
     109
     110(define (get-grammar name)
     111  (alist-ref name *grammars* eq?) )
     112
     113(define (list-of-grammars)
     114  (map (lambda (cell) (car cell)) *grammars*) )
     115
     116(define (count-of-grammars)
     117  (length *grammars*) )
     118
     119(define (get-grammar/id id)
     120  (get-grammar (grammar-id-name id)) )
     121
     122(define (clear-grammars)
     123  (clear-grammar-ids)
     124  (set! *grammar* '()) )
     125
     126;;
     127
     128;
     129(define (read-sexp grm column)  ((grammar-reader grm) grm column))
     130(define (write-sexp sexp grm)   ((grammar-writer grm) sexp grm))
     131
     132(define *tab-stop* 8)
     133
     134;
     135(define (flush-input-whitespace port)
     136  (do ((chr (peek-char port) (peek-char port))
     137       (col 0 (case chr
     138                ((#\space)    (+ 1 col))
     139                ((#\tab)      (modulo (+ (sub1 *tab-stop*) col) *tab-stop*))
     140                ((#\newline)  0)
     141                (else         col))))
     142      ((or (eof-object? chr)
     143           (not (char-whitespace? chr)))
     144       col)
     145    (read-char port)))
     146
     147;;
     148
     149(define (make-delimited-parse-grammar-reader delim)
     150  (lambda (grm column #!optional (port (current-input-port)))
     151    (prec:parse
     152      (grammar-read-tab grm)
     153      delim
     154      (+ column (flush-input-whitespace port))
     155      port)) )
     156
     157(define (make-delimited-sexp-reader port delim)
     158  (lambda (grm column)
     159    (define temporary-grammar
     160      (let ((+grammar-cache+ (make-grammar #f #f #f #f #f)))
     161        (lambda (grm . args)
     162          (apply grammar-copy! +grammar-cache+ grm args)
     163          +grammar-cache+ ) ) )
     164    (let ((grm* (temporary-grammar grm #:reader (make-delimited-parse-grammar-reader delim))))
     165      ;ugly but SLIB prec kinda assumes
     166      (parameterize ((current-input-port port))
     167        (read-sexp grm* column) ) ) ) )
     168
     169;;
     170
     171(define (read-sexp-from-string str #!optional (grm (active-input-grammar)) (column 0))
     172  (import (only (chicken port) with-input-from-string))
     173  (with-input-from-string str (cut read-sexp grm column)) )
    50174
    51175;;
     
    67191(define (active-echo-grammar) (receive (i o e) (active-grammar) e))
    68192
    69 ;;
    70 
    71 (define (read-syntax-setup!)
    72   (import (only (chicken base) parentheses-synonyms))
    73   (import (only (chicken read-syntax) set-sharp-read-syntax! set-parameterized-read-syntax!))
    74   (set-sharp-read-syntax! #\{
    75     (lambda (port)
    76       (parameterize ((parentheses-synonyms #f))
    77         (read-delimited-sexp port #\} (get-grammar/id 0) 0))))
    78   (set-parameterized-read-syntax! #\{
    79     (lambda (port id)
    80       (parameterize ((parentheses-synonyms #f))
    81         (read-delimited-sexp port #\} (get-grammar/id id) 0)))) )
    82 
    83193) ;slib-prec-grammar
  • release/5/slib-prec/trunk/slib-prec-parse.scm

    r38716 r38717  
    11;;;; slib-prec-parse.scm  -*-scheme-*-
    22;;;; Kon Lovett, Apr '20
    3 ;;;; Kon Lovett, Apr '18
    43
    54;; Issues
  • release/5/slib-prec/trunk/slib-prec.egg

    r38716 r38717  
    99 (maintainer "[[kon lovett]]")
    1010 (license "SLIB")
    11  (dependencies
    12         (utf8 "3.5.0"))
     11 (dependencies utf8)
    1312 (test-dependencies test)
    1413 (components
     
    1615    (types-file)
    1716    (component-dependencies slib-prec-grammar)
    18     (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     17    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
    1918  (extension slib-prec-grammar
    2019    (types-file)
    2120    (component-dependencies slib-prec-parse)
    22     (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     21    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
    2322  (extension slib-prec-parse
    2423    (types-file)
    2524    ;suspect -strict-types might be an issue
    26     (csc-options "-O3" "-d1" "-local" "-D" "utf8" "-no-procedure-checks-for-toplevel-bindings"))
     25    (csc-options "-O3" "-d1" "-D" "utf8" "-no-procedure-checks-for-toplevel-bindings"))
    2726  (extension slib-basic-grammars
    2827    (types-file)
    2928    (component-dependencies slib-prec-parse slib-prec-grammar)
    30     (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     29    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
    3130  (extension slib-standard-grammar
    3231    (types-file)
    3332    (component-dependencies slib-prec-parse slib-prec-grammar)
    34     (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     33    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
    3534  (extension slib-tex-grammar
    3635    (types-file)
    3736    (component-dependencies slib-prec-parse slib-prec-grammar)
    38     (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
     37    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))
    3938  (extension slib-prec
    4039    (types-file)
    4140    (component-dependencies slib-prec-grammar slib-prec-parse slib-standard-grammar slib-basic-grammars)
    42     (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))  ) )
     41    (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings"))  ) )
  • release/5/slib-prec/trunk/slib-prec.scm

    r38716 r38717  
    11;;;; slib-prec.scm  -*-scheme-*-
    22;;;; Kon Lovett, Apr '20
    3 ;;;; Kon Lovett, Apr '18
    43
    54;; Issues
     
    76;; - needs a "surface notation"
    87
    9 (module slib-prec
    10 
    11 (;export
    12   read-sexp-from-string)
     8(module slib-prec ()
    139
    1410(import scheme)
     
    2117(import slib-prec-grammar)
    2218(reexport slib-prec-grammar)
    23 
    24 ;defgrammar doesn't define
    25 (import slib-basic-grammars)
    26 (import slib-standard-grammar)
    27 (import slib-tex-grammar)
    28 
    29 ;;
    30 
    31 (define (read-sexp-from-string str #!optional (grm (active-input-grammar)) (column 0))
    32   (import (only (chicken port) with-input-from-string))
    33   (with-input-from-string str (cut read-sexp grm column)) )
    3419
    3520;;;
  • release/5/slib-prec/trunk/tests/slib-prec-test.scm

    r38716 r38717  
    1 ;;;; slib-prec-test.scm
     1;;;; slib-prec-test.scm  -*- scheme -*-
     2;;;; Kon Lovett, Apr '20
    23
    34(import test)
     
    1819
    1920(define ^ expt)
     21(define mod modulo)
    2022
    2123;;
    2224
     25;defgrammar doesn't `define'
     26(import slib-basic-grammars)
     27(import slib-standard-grammar)
     28(import slib-tex-grammar)
     29
    2330;init by id-# grammar lookup
    24 ;(define-constant DEFAULT-GRAMMARS '(standard disp2d tex null scheme schemepretty))
    25 (define DEFAULT-GRAMMARS '(standard disp2d tex null scheme schemepretty))
     31(define-constant TEST-GRAMMARS '(standard disp2d tex null scheme schemepretty))
    2632(clear-grammar-ids)
    27 (grammar-id-name-setup! DEFAULT-GRAMMARS)
    28 ;(grammar-id-name-setup! `(,@DEFAULT-GRAMMARS))
    29 
     33(grammar-id-name-setup! TEST-GRAMMARS)
    3034(active-grammar-set! 'standard #f 'schemepretty)
    3135
     
    3337
    3438(test-group "Grammer IDs"
    35   (test (length DEFAULT-GRAMMARS) (count-of-grammar-ids))
     39  (test (length TEST-GRAMMARS) (count-of-grammar-ids))
    3640  (test 'standard (grammar-id-name 0))
    3741  (test 'scheme (grammar-id-name 4))
Note: See TracChangeset for help on using the changeset viewer.