source: project/release/5/slib-prec/trunk/slib-prec.scm @ 38563

Last change on this file since 38563 was 38563, checked in by Kon Lovett, 10 months ago

use slib prec include, use slib simetrix, combine *-setups

File size: 4.6 KB
Line 
1;;;; slib-prec.scm  -*-scheme-*-
2;;;; Kon Lovett, Apr '20
3;;;; Kon Lovett, Apr '18
4
5;; Issues
6;;
7;; - needs a "surface notation"
8
9(module slib-prec
10
11(;export
12  ;
13  syntax-end!                 ; (set! *syn-defs* '())   => (syntax-end!)
14  syntax-begin!               ; (set! *syn-def* ...)    => (syntax-begin! ...)
15  syntax-current              ; *syn-def*               => (syntax-current)
16  syntax-ignore-whitespace    ; *syn-ignore-whitespace* => (syntax-ignore-whitespace)
17  ;
18  char-code-limit
19  tok:decimal-digits
20  tok:upper-case
21  tok:lower-case
22  tok:whitespaces
23  tok:char-group
24  tok:read-char
25  ;
26  prec:define-grammar
27  prec:parse
28  prec:make-led
29  prec:make-nud
30  prec:delim
31  prec:nofix
32  prec:prefix
33  prec:infix
34  prec:infixr
35  prec:nary
36  prec:postfix
37  prec:prestfix
38  prec:commentfix
39  prec:matchfix
40  prec:inmatchfix)
41
42(import scheme)
43(import (chicken base))
44
45;;;
46
47(cond-expand
48  (utf8
49    (import (rename scheme
50        (char-whitespace? scheme:char-whitespace?)
51        (char-alphabetic? scheme:char-alphabetic?)
52        (char-upper-case? scheme:char-upper-case?)
53        (char-lower-case? scheme:char-lower-case?)
54        (char-numeric? scheme:char-numeric?)))
55    (import (chicken foreign))
56    (import utf8)
57    (import utf8-srfi-13)
58    (import utf8-case-map)
59    (import utf8-srfi-14)
60    (import unicode-char-sets)
61
62    ;; UTF-8 char predicates
63
64    (define charset-alphabetic?)
65    (define charset-upper-case?)
66    (define charset-lower-case?)
67    (define charset-whitespace?)
68    (define charset-numeric?)
69    (define charset-hex-numeric?)
70    (let ()
71      (define ((charset-predicate cs) ch) (char-set-contains? cs ch))
72      (set! charset-alphabetic? (charset-predicate char-set:alphabetic))
73      (set! charset-upper-case? (charset-predicate char-set:uppercase))
74      (set! charset-lower-case? (charset-predicate char-set:lowercase))
75      (set! charset-whitespace? (charset-predicate char-set:white-space))
76      (set! charset-numeric? (charset-predicate char-set:digit))
77      (set! charset-hex-numeric? (charset-predicate char-set:hex-digit)) )
78    (define char-hex-numeric? charset-hex-numeric?)
79
80    ;Character range is that of a UTF-8 codepoint, not representable range
81    (define char-code-limit (foreign-value "C_CHAR_BIT_MASK" unsigned-int)))
82  (else
83    (import srfi-13)
84    (import srfi-14)
85    ; "Extended" ASCII
86    (define char-code-limit 256)) )
87
88;; SLIB Code
89
90(import (only (chicken port) call-with-output-string))
91
92(include "slib-compat")
93
94(include "strsrch")
95
96; these shouldn't be literals
97(define *prec:comment-start* 200)
98(define *prec:comment-weight* 220)
99
100(include "prec")
101
102;FIXME fixes what by duplicating `tok:read-through-comment' behavior?
103(set! prec:commentfix (lambda (tk stp match . binds)
104  ;;from tok:read-through-comment
105  (set! match (if (char? match)
106                  (string match)
107                  (prec:de-symbolfy match)))
108  (append
109   (prec:make-nud tk prec:parse-nudcomment stp match (apply append binds))
110   (prec:make-led tk *prec:comment-weight* prec:parse-ledcomment stp match (apply append binds)))))
111
112(define (syntax-begin! #!optional (base '()))   (set! *syn-defs* base))
113(define (syntax-end!)                           (set! *syn-defs* '()))
114(define (syntax-current)                        *syn-defs*)
115(define (syntax-ignore-whitespace)              *syn-ignore-whitespace*)
116
117(include "prec-setup")
118
119;;
120
121(define (prec:infixr tk sop lbp . binds)
122  (let* (
123    (bp (and (not (null? binds)) (number? (car binds)) (car binds)))
124    (binds (if bp (cdr binds) binds))
125    (bp (or bp (max 0 (- lbp 1)))) )
126    (apply prec:infix tk sop lbp bp binds) ) )
127
128;;
129
130(define (make-grammar src #!optional (base '()))
131  (let* (
132    (imd (*parse-grammer-source 'make-grammar src base))
133    (grm (*eval-grammer-form 'make-grammar imd base)) )
134    (syntax-begin! base)
135    (apply prec:define-grammar grm)
136    (syntax-current) ) )
137
138; tok <kind> <args>...
139;
140; <kind>
141;
142; _f                              delim
143;
144; f                               nofix       : sop
145;
146; f_f                             commentfix  : stp match rule1 ...
147;
148; fx fy                           prefix      : sop bp rule1 ...
149; xf yf                           postfix     : sop bp
150; xfx xfy yfx yfy                 infix       : sop lbp bp rule1 ...
151; xfx xfy yfx yfy                 infix       : sop lbp bp rule1 ...
152;
153; xfs                             nary        : sop bp
154; fs                              prestfix    : sop bp rule1 ...
155;
156; fxf                             matchfix    :  sop sep match rule1 ...
157; fyf                             inmatchfix  :  sop sep match lbp rule1 ...
158
159(define (*parse-grammer-source loc src base)
160  (begin) )
161
162(define (*eval-grammer-form loc imd base)
163  (begin) )
164
165) ;slib-prec
Note: See TracBrowser for help on using the repository browser.