Changeset 38563 in project


Ignore:
Timestamp:
04/05/20 22:05:52 (2 months ago)
Author:
Kon Lovett
Message:

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

Location:
release/5/slib-prec/trunk
Files:
1 added
4 deleted
8 edited
1 moved

Legend:

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

    r38553 r38563  
    154154   tps:2d))                             ;write-tab
    155155
    156 (set! *input-grammar* (get-grammar 'standard))
    157 (set! *output-grammar* (get-grammar 'disp2d))
     156;(set! *input-grammar* (get-grammar 'standard))
     157;(set! *output-grammar* (get-grammar 'disp2d))
    158158
    159159;;;; Syntax definitions for TEX GRAMMAR
  • release/5/slib-prec/trunk/prec-setup.scm

    r38562 r38563  
    22;;
    33
    4 ;@
    5 (define tok:decimal-digits "0123456789")
    6 (define tok:upper-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    7 (define tok:lower-case "abcdefghijklmnopqrstuvwxyz")
    8 (define tok:whitespaces
    9   (do ((i (+ -1 (min 256 char-code-limit)) (+ -1 i))
    10        (ws "" (if (char-whitespace? (integer->char i))
    11                   (string-append ws (string (integer->char i)))
    12                   ws)))
    13       ((negative? i) ws)))
     4(cond-expand
     5  (utf8
     6    ;@
     7    (define tok:decimal-digits)
     8    (define tok:upper-case)
     9    (define tok:lower-case)
     10    (define tok:whitespaces)
     11    (let ()
     12      (define (char-list/pred pred?)
     13        (do ((i (- char-code-limit 1) (- i 1))
     14             (ws '() (let ((ch (integer->char i))) (if (pred? ch) (cons ch ws) ws))) )
     15            ((negative? i) ws)) )
     16      (set! tok:decimal-digits (list->string (char-list/pred charset-numeric?)))
     17      (set! tok:upper-case (list->string (char-list/pred charset-upper-case?)))
     18      (set! tok:lower-case (list->string (char-list/pred charset-lower-case?)))
     19      (set! tok:whitespaces (list->string (char-list/pred charset-whitespace?)))))
     20  (else
     21    ;@
     22    (define tok:decimal-digits "0123456789")
     23    (define tok:upper-case "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     24    (define tok:lower-case "abcdefghijklmnopqrstuvwxyz")
     25    (define tok:whitespaces
     26      (do ((i (+ -1 (min 256 char-code-limit)) (+ -1 i))
     27           (ws "" (if (char-whitespace? (integer->char i))
     28                      (string-append ws (string (integer->char i)))
     29                      ws)))
     30          ((negative? i) ws)))
     31    (define charset-whitespace? char-whitespace?)) )
     32
     33; Ignore Whitespace Grammar Syntax Basis
     34(syntax-begin!)
     35
     36; Ignore Whitespace characters.
     37(prec:define-grammar (tok:char-group 0 tok:whitespaces #f))
     38
     39; On MS-DOS systems, <ctrl>-Z (26) needs to be ignored in order to
     40; avoid problems at end of files.
     41(case (software-type)
     42  ((ms-dos)
     43   (if (not (charset-whitespace? (integer->char 26)))
     44       (prec:define-grammar (tok:char-group 0 (integer->char 26) #f))
     45       )))
     46
     47;@ Save these convenient definitions.
     48(define *syn-ignore-whitespace* *syn-defs*)
     49
     50(syntax-end!)
  • release/5/slib-prec/trunk/simetrix.scm

    r38553 r38563  
    2828(define (SI:adjoin unitlst SIms)
    2929  (for-each (lambda (new)
    30               (define pair (assoc (car new) SIms))
    31               (if pair
    32                   (set-cdr! pair (+ (cdr new) (cdr pair)))
    33                   (set! SIms (cons (cons (car new) (cdr new)) SIms))))
    34             unitlst)
     30              (define pair (assoc (car new) SIms))
     31              (if pair
     32                  (set-cdr! pair (+ (cdr new) (cdr pair)))
     33                  (set! SIms (cons (cons (car new) (cdr new)) SIms))))
     34            unitlst)
    3535  SIms)
    3636
     
    4141  (set! unit2 (SI:expand-unit unit2))
    4242  (cond ((and unit1 unit2)
    43         (set! nunits (SI:adjoin unit1 nunits))
    44         (set! nunits (SI:adjoin unit2 nunits))
    45         nunits)
    46         (else #f)))
     43        (set! nunits (SI:adjoin unit1 nunits))
     44        (set! nunits (SI:adjoin unit2 nunits))
     45        nunits)
     46        (else #f)))
    4747
    4848(define (SI:quotient unit1 . units)
    4949  (apply SI:product unit1
    50         (map (lambda (unit) (SI:pow unit -1)) units)))
     50        (map (lambda (unit) (SI:pow unit -1)) units)))
    5151
    5252(define (SI:pow unit expon)
     
    5454  (and punit (number? expon)
    5555       (map (lambda (unit-pair)
    56               (cons (car unit-pair) (* (cdr unit-pair) expon)))
    57             punit)))
     56              (cons (car unit-pair) (* (cdr unit-pair) expon)))
     57            punit)))
    5858
    5959;;; Parse helper functions.
    6060(define (SI:solidus . args)
    6161  (if (and (= 2 (length args))
    62            (number? (car args))
    63            (number? (cadr args)))
     62           (number? (car args))
     63           (number? (cadr args)))
    6464      (/ (car args) (cadr args))
    6565      (apply SI:quotient args)))
     
    6767(define (SI:e arg1 arg2)
    6868  (cond ((and (number? arg1) (number? arg2)
    69               (exact? arg2))
    70         (let ((expo (string->number
    71                       (string-append "1e" (number->string arg2)))))
    72            (and expo (* arg1 expo))))
    73         (else (SI:product arg1 arg2))))
     69              (exact? arg2))
     70        (let ((expo (string->number
     71                      (string-append "1e" (number->string arg2)))))
     72           (and expo (* arg1 expo))))
     73        (else (SI:product arg1 arg2))))
    7474
    7575(define (SI:dot arg1 arg2)
    7676  (cond ((and (number? arg1) (number? arg2)
    77               (exact? arg1) (exact? arg2)
    78               (positive? arg2))
    79         (string->number
    80           (string-append (number->string arg1) "." (number->string arg2))))
    81         (else (SI:product arg1 arg2))))
     77              (exact? arg1) (exact? arg2)
     78              (positive? arg2))
     79        (string->number
     80          (string-append (number->string arg1) "." (number->string arg2))))
     81        (else (SI:product arg1 arg2))))
    8282
    8383(define (SI:minus arg) (and (number? arg) (- arg)))
     
    8585(define (SI:identity . args) (and (= 1 (length args)) (car args)))
    8686
    87 (define (SI:try-split preSI SIm)
    88   (define expo (assoc preSI SI:prefix-exponents))
    89   (define stuff (assoc SIm SI:unit-infos))
    90   (if expo (set! expo (cadr expo)))
    91   (if stuff (set! stuff (cdr stuff)))
    92   (and expo stuff
    93        (let ((equivalence (cadr stuff)))
    94          (and (case (car stuff)         ;restriction
    95                 ((all) (not (zero? (modulo expo 10))))
    96                 ((pos) (and (positive? expo) (not (zero? (modulo expo 10)))))
    97                 ((bin) #t)
    98                 ((pin) (positive? expo))
    99                 ((neg) (and (negative? expo) (not (zero? (modulo expo 10)))))
    100                 ((none) #f)
    101                 (else #f))
    102               (if (and (positive? expo) (zero? (modulo expo 10)))
    103                   (if equivalence
    104                       (let ((eqv (SI:expand-equivalence equivalence)))
    105                         (and eqv
    106                              (SI:adjoin (list (cons 1024 (quotient expo 10)))
    107                                         eqv)))
    108                       (list (cons 1024 (quotient expo 10))
    109                             (cons SIm 1)))
    110                   (if equivalence
    111                       (let ((eqv (SI:expand-equivalence equivalence)))
    112                         (and eqv (SI:adjoin (list (cons 10 expo)) eqv)))
    113                       (list (cons 10 expo) (cons SIm 1))))))))
    114 
    115 (define (SI:try-simple SIm)
    116   (define stuff (assoc SIm SI:unit-infos))
    117   (if stuff (set! stuff (cdr stuff)))
    118   (and stuff (if (cadr stuff)
    119                  (SI:expand-equivalence (cadr stuff))
    120                  (list (cons SIm 1)))))
    121 
    122 (define (SI:expand-unit str)
    123   (if (symbol? str) (set! str (symbol->string str)))
    124   (cond
    125    ((pair? str) str)
    126    ((number? str) (list (cons str 1)))
    127    ((string? str)
    128     (let ((len (string-length str)))
    129       (let ((s1 (and (> len 1)
    130                      (SI:try-split (substring str 0 1) (substring str 1 len))))
    131             (s2 (and (> len 2)
    132                      (SI:try-split (substring str 0 2) (substring str 2 len))))
    133             (sn (and (SI:try-simple str))))
    134         (define cnt (+ (if s1 1 0) (if s2 1 0) (if sn 1 0)))
    135         (if (> cnt 1) (slib:warn 'ambiguous s1 s2 sn))
    136         (or s1 s2 sn))))
    137    (else #f)))
    138 
    139 (define (SI:expand-equivalence str)
    140   (call-with-input-string
    141       str (lambda (sport)
    142             (define result (prec:parse SI:grammar 'EOS 0 sport))
    143             (cond ((eof-object? result) (list (cons 1 0)))
    144                   ((symbol? result) (SI:expand-unit result))
    145                   (else result)))))
    146 
    147 ;;;;@ advertised interface
    148 (define (SI:conversion-factor to-unit from-unit)
    149   (let ((funit (SI:expand-equivalence from-unit))
    150         (tunit (SI:expand-equivalence to-unit)))
    151     (if (and funit tunit)
    152         (let loop ((unit-pairs (SI:quotient funit tunit))
    153                    (flactor 1))
    154           (cond ((null? unit-pairs) flactor)
    155                 ((zero? (round (* 2 (cdar unit-pairs))))
    156                  (loop (cdr unit-pairs) flactor))
    157                 ((number? (caar unit-pairs))
    158                  (loop (cdr unit-pairs)
    159                        ((if (negative? (cdar unit-pairs)) / *)
    160                         flactor
    161                         (expt (caar unit-pairs)
    162                               (abs (cdar unit-pairs))))))
    163                 (else 0)))
    164         (+ (if tunit 0 -1) (if funit 0 -2)))))
    165 
    166 ;;;;                      The parse tables.
    167 
    168 ;;;(trace-all (in-vicinity (program-vicinity) "simetrix.scm"))
    169 
    170 (define SI:grammar
    171   ;Definitions accumulate in top-level variable *SYN-DEFS*.
    172   (let ()
    173     ;ignore dynamic context parameter
    174     (define (list2string dyn lst) (list->string lst))
    175     (define (list2number dyn lst) (string->number (list2string dyn lst)))
    176     (define tok:units-chars (string-append tok:upper-case tok:lower-case "@_"))
    177     ;si grammer
    178     (prec:define-grammar
    179       ;Character classes
    180       (tok:char-group 70 #\^ list2string)
    181       (tok:char-group 49 #\. list2string)
    182       (tok:char-group 50 #\/ list2string)
    183       (tok:char-group 51 #\- list2string)
    184       (tok:char-group 40 tok:decimal-digits list2number)
    185       (tok:char-group 44 tok:units-chars list2string)
    186       ;Operators
    187       (prec:prefix '- SI:minus 130)
    188       (prec:infix "." SI:dot 120 120)
    189       (prec:infix '("e" "E") SI:e 115 125)
    190       (prec:infix '/ SI:solidus 100 150)
    191       (prec:infix '^ SI:pow 160 140)
    192       (prec:matchfix #\( SI:identity #f #\)) )
    193     ;
    194     (syntax-current) #;*syn-defs*))
    195 
    19687;;; Binary prefixes are (zero? (modulo expo 10))
     88#;(define SI:prefix-exponents
     89  '(("Y" 24) ("Z" 21) ("E" 18) ("P" 15)
     90    ("T" 12) ("G" 9) ("M" 6) ("k" 3) ("h" 2) ("da" 1)
     91    ("d" -1) ("c" -2) ("m" -3) ("u" -6) ("n" -9)
     92    ("p" -12) ("f" -15) ("a" -18) ("z" -21) ("y" -24)
     93
     94    ("Ei" 60) ("Pi" 50) ("Ti" 40) ("Gi" 30) ("Mi" 20) ("Ki" 10)
     95    ))
    19796(define SI:prefix-exponents '(
    19897  ;SI Prefix
     
    229128))
    230129
    231 (define-syntax in-units
    232   (syntax-rules ()
    233     ((in-units ?n ?u)
    234       (string-append (number->string ?n) "." ?u) ) ) )
    235 
    236 (define SI:unit-infos `(
    237   ("s" all #f)
    238   ("min" none "60.s")
    239   ("h" none "3600.s")
    240   ("d" none "86400.s")
    241   ("Hz" all "s^-1")
    242   ("Bd" pos "s^-1")
    243   ("m" all #f)
    244   ("L" neg "dm^3")
    245   ("rad" neg #f)
    246   ("sr" neg "rad^2")
    247   ("r" pos ,(in-units (* 8 (atan 1)) "rad"))
    248   ("o" neg ,(in-units (/ 360) "r"))
    249   ("bit" bin #f)
    250   ("B" pin "8.b")
    251   ("g" all #f)
    252   ("t" pos "Mg")
    253   ("u" none "1.66053886e-27.kg")
    254   ("mol" all #f)
    255   ("kat" all "mol/s")
    256   ("K" all #f)
    257   ("oC" neg #f)
    258   ("cd" all #f)
    259   ("lm" all "cd.sr")
    260   ("lx" all "lm/m^2")
    261   ("N" all "m.kg/s^2")
    262   ("Pa" all "N/m^2")
    263   ("J" all "N.m")
    264   ("eV" all "1.60217653e-19.J")
    265   ("W" all "J/s")
    266   ("Np" neg #f)
    267   ("dB" none ,(in-units (/ (log 10) 20) "Np"))
    268   ("A" all #f)
    269   ("C" all "A.s")
    270   ("V" all "W/A")
    271   ("F" all "C/V")
    272   ("Ohm" all "V/A")
    273   ("S" all "A/V")
    274   ("Wb" all "V.s")
    275   ("T" all "Wb/m^2")
    276   ("H" all "Wb/A")
    277   ("Bq" all "s^-1")
    278   ("Gy" all "m^2.s^-2")
    279   ("Sv" all "m^2.s^-2")
    280 ))
     130(define SI:unit-infos
     131  `(
     132    ("s" all #f)
     133    ("min" none "60.s")
     134    ("h" none "3600.s")
     135    ("d" none "86400.s")
     136    ("Hz" all "s^-1")
     137    ("Bd" pos "s^-1")
     138    ("m" all #f)
     139    ("L" neg "dm^3")
     140    ("rad" neg #f)
     141    ("sr" neg "rad^2")
     142    ("r" pos ,(string-append (number->string (* 8 (atan 1))) ".rad"))
     143    ("o" neg ,(string-append (number->string (/ 360)) ".r"))
     144    ("bit" bin #f)
     145    ("B" pin "8.b")
     146    ("g" all #f)
     147    ("t" pos "Mg")
     148    ("u" none "1.66053886e-27.kg")
     149    ("mol" all #f)
     150    ("kat" all "mol/s")
     151    ("K" all #f)
     152    ("oC" neg #f)
     153    ("cd" all #f)
     154    ("lm" all "cd.sr")
     155    ("lx" all "lm/m^2")
     156    ("N" all "m.kg/s^2")
     157    ("Pa" all "N/m^2")
     158    ("J" all "N.m")
     159    ("eV" all "1.60217653e-19.J")
     160    ("W" all "J/s")
     161    ("Np" neg #f)
     162    ("dB" none ,(string-append (number->string (/ (log 10) 20)) ".Np"))
     163    ("A" all #f)
     164    ("C" all "A.s")
     165    ("V" all "W/A")
     166    ("F" all "C/V")
     167    ("Ohm" all "V/A")
     168    ("S" all "A/V")
     169    ("Wb" all "V.s")
     170    ("T" all "Wb/m^2")
     171    ("H" all "Wb/A")
     172    ("Bq" all "s^-1")
     173    ("Gy" all "m^2.s^-2")
     174    ("Sv" all "m^2.s^-2")
     175    ))
     176
     177(define (SI:try-split preSI SIm)
     178  (define expo (assoc preSI SI:prefix-exponents))
     179  (define stuff (assoc SIm SI:unit-infos))
     180  (if expo (set! expo (cadr expo)))
     181  (if stuff (set! stuff (cdr stuff)))
     182  (and expo stuff
     183       (let ((equivalence (cadr stuff)))
     184         (and (case (car stuff)         ;restriction
     185                ((all) (not (zero? (modulo expo 10))))
     186                ((pos) (and (positive? expo) (not (zero? (modulo expo 10)))))
     187                ((bin) #t)
     188                ((pin) (positive? expo))
     189                ((neg) (and (negative? expo) (not (zero? (modulo expo 10)))))
     190                ((none) #f)
     191                (else #f))
     192              (if (and (positive? expo) (zero? (modulo expo 10)))
     193                  (if equivalence
     194                      (let ((eqv (SI:expand-equivalence equivalence)))
     195                        (and eqv
     196                             (SI:adjoin (list (cons 1024 (quotient expo 10)))
     197                                        eqv)))
     198                      (list (cons 1024 (quotient expo 10))
     199                            (cons SIm 1)))
     200                  (if equivalence
     201                      (let ((eqv (SI:expand-equivalence equivalence)))
     202                        (and eqv (SI:adjoin (list (cons 10 expo)) eqv)))
     203                      (list (cons 10 expo) (cons SIm 1))))))))
     204
     205(define (SI:try-simple SIm)
     206  (define stuff (assoc SIm SI:unit-infos))
     207  (if stuff (set! stuff (cdr stuff)))
     208  (and stuff (if (cadr stuff)
     209                 (SI:expand-equivalence (cadr stuff))
     210                 (list (cons SIm 1)))))
     211
     212(define (SI:expand-unit str)
     213  (if (symbol? str) (set! str (symbol->string str)))
     214  (cond
     215   ((pair? str) str)
     216   ((number? str) (list (cons str 1)))
     217   ((string? str)
     218    (let ((len (string-length str)))
     219      (let ((s1 (and (> len 1)
     220                     (SI:try-split (substring str 0 1) (substring str 1 len))))
     221            (s2 (and (> len 2)
     222                     (SI:try-split (substring str 0 2) (substring str 2 len))))
     223            (sn (and (SI:try-simple str))))
     224        (define cnt (+ (if s1 1 0) (if s2 1 0) (if sn 1 0)))
     225        (if (> cnt 1) (slib:warn 'ambiguous s1 s2 sn))
     226        (or s1 s2 sn))))
     227   (else #f)))
     228
     229(define (SI:expand-equivalence str)
     230  (call-with-input-string
     231      str (lambda (sport)
     232            (define result (prec:parse SI:grammar 'EOS 0 sport))
     233            (cond ((eof-object? result) (list (cons 1 0)))
     234                  ((symbol? result) (SI:expand-unit result))
     235                  (else result)))))
     236
     237;;;;@ advertised interface
     238(define (SI:conversion-factor to-unit from-unit)
     239  (let ((funit (SI:expand-equivalence from-unit))
     240        (tunit (SI:expand-equivalence to-unit)))
     241    (if (and funit tunit)
     242        (let loop ((unit-pairs (SI:quotient funit tunit))
     243                   (flactor 1))
     244          (cond ((null? unit-pairs) flactor)
     245                ((zero? (round (* 2 (cdar unit-pairs))))
     246                 (loop (cdr unit-pairs) flactor))
     247                ((number? (caar unit-pairs))
     248                 (loop (cdr unit-pairs)
     249                       ((if (negative? (cdar unit-pairs)) / *)
     250                        flactor
     251                        (expt (caar unit-pairs)
     252                              (abs (cdar unit-pairs))))))
     253                (else 0)))
     254        (+ (if tunit 0 -1) (if funit 0 -2)))))
     255
     256(define SI:grammar #f)
     257
     258;;;;                      The parse tables.
     259;;; Definitions accumulate in top-level variable *SYN-DEFS*.
     260;;(trace-all (in-vicinity (program-vicinity) "simetrix.scm"))
     261
     262(define (list2string dyn lst) (list->string lst))
     263;;; Character classes
     264(prec:define-grammar (tok:char-group 70 #\^ list2string))
     265(prec:define-grammar (tok:char-group 49 #\. list2string))
     266(prec:define-grammar (tok:char-group 50 #\/ list2string))
     267(prec:define-grammar (tok:char-group 51 #\- list2string))
     268(prec:define-grammar (tok:char-group 40 tok:decimal-digits
     269                      (lambda (dyn l) (string->number (list->string l)))))
     270(prec:define-grammar (tok:char-group 44
     271                      (string-append tok:upper-case tok:lower-case "@_")
     272                      list2string))
     273
     274(prec:define-grammar (prec:prefix '- SI:minus 130))
     275(prec:define-grammar (prec:infix "." SI:dot 120 120))
     276(prec:define-grammar (prec:infix '("e" "E") SI:e 115 125))
     277(prec:define-grammar (prec:infix '/ SI:solidus 100 150))
     278(prec:define-grammar (prec:infix '^ SI:pow 160 140))
     279(prec:define-grammar (prec:matchfix #\( SI:identity #f #\)))
     280
     281(set! SI:grammar (syntax-current) #;*syn-defs*)
  • release/5/slib-prec/trunk/slib-compat.scm

    r38553 r38563  
    11;;;; slib-compat.scm  -*- Scheme -*-
    22;;;; Kon Lovett, Apr '20
     3
     4(import (only (srfi 1) every last-pair))
     5
     6(import (only (chicken port) call-with-output-string))
     7
     8(define (find-if . args)
     9  (import (only (srfi 1) find))
     10  (apply find args))
     11
     12(define (comlist:nthcdr n lst)
     13  (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst))))
     14
     15(define (last lst n)
     16  (comlist:nthcdr (- (length lst) n) lst))
     17
     18(import (only (chicken pretty-print) pretty-print))
    319
    420;;@ FORCE-OUTPUT flushes any pending output on optional arg output port
     
    4763  (begin) )
    4864
     65(define (require-if p x)
     66  ;(print "SLIB require-if " #\' p " " x)
     67  (begin) )
     68
     69(define (nconc . args)
     70  (import (only (srfi 1) concatenate!))
     71  (concatenate! args) )
     72
     73(define (print-call-stack out)
     74  (import (only (chicken base) print-call-chain))
     75  (print-call-chain out))
     76
     77(define slib:warn
     78  (lambda args
     79    (let ((cep (current-error-port)))
     80      (if (provided? 'trace) (print-call-stack cep))
     81      (display "Warn: " cep)
     82      (for-each (lambda (x) (display #\space cep) (write x cep)) args))))
     83
     84(define slib:error
     85  (let ((error error))
     86    (lambda args
     87      (if (provided? 'trace) (print-call-stack (current-error-port)))
     88      (apply error args))))
     89
    4990(define slib:tab #\tab)
    50 
    51 (define (slib:warn . args)
    52   (import (only (chicken base) warning))
    53   (apply warning args) )
    54 
    55 (define (slib:error . args)
    56   (import (only (chicken base) error))
    57   (apply error args) )
    58 
    59 (define (math:error . args)
    60   (apply slib:error 'math: args) )
    61 
    62 (define (math:warn . args)
    63   (apply slib:warn 'math: args) )
     91(define slib:form-feed #\page)
  • release/5/slib-prec/trunk/slib-grammar.scm

    r38553 r38563  
    11;;;; slib-grammar.scm
    2 
    3 ;;from jacal grammar.scm
    42
    53;
     
    2624  (for-each grammar-id-name-set! (iota (length names)) names) )
    2725
     26;;
     27
     28;;from jacal unparse.scm
     29(define (print-using-grammar sexp grm)
     30  (print "[" (grammar-name grm) "] " sexp)
     31  #;
     32  (template-print sexp (grammar-write-tab grm)))
     33
     34;#|
    2835; supplies module based struct tag & other identifiers
    2936(define-record grammar name reader read-tab writer write-tab)
     
    6067
    6168;
    62 (define (read-sexp grm icol)  ((grammar-reader grm) grm icol))
     69(define (read-sexp grm icol) ((grammar-reader grm) grm icol))
    6370(define (write-sexp sexp grm) ((grammar-writer grm) sexp grm))
    6471
    65 ;;from jacal unparse.scm
    66 (define (print-using-grammar sexp grm)
    67   (print "[" (grammar-name grm) "] " sexp)
    68   #;
    69   (template-print sexp (grammar-write-tab grm)))
     72(define *tab-stop* 8)
    7073
    71 
    72 (define *tab-stop* 8)
    7374;
    7475(define (flush-input-whitespace port)
     
    8384       col)
    8485    (read-char port)))
     86;|#
     87
     88;;
    8589
    8690;
     
    103107      res ) ) )
    104108
     109;from jacal toploads.scm
     110(define *input-grammar* (get-grammar 'scheme))
     111(define *output-grammar* (get-grammar 'scheme))
     112(define *echo-grammar* (get-grammar 'null))
     113(define tran:translations '())
     114;(define Language #f)
     115(define math:debug #f)
     116(define math:phases #f)
     117(define math:trace #f)
     118;(define linkradicals #f)
     119(define horner #f)
     120(define page-height #f)
     121(define page-width #f)
     122;(define newextstr #f)
     123;(define newlabelstr #f)
     124;(define newlabelsym #f)
     125;(define % #f)
     126;(define *modulus* 0)
     127
    105128;
    106 (define *input-grammar*)
    107 (define *output-grammar*)
    108 (define *echo-grammar*)
     129(define (math:error . args) (apply slib:error 'math: args))
     130(define (math:warn . args) (apply slib:warn 'math: args))
     131(define (math:exit b) #;(cleanup-handlers!) (slib:error "error in math system"))
  • release/5/slib-prec/trunk/slib-prec-grammar.scm

    r38553 r38563  
    4343(import (chicken base))
    4444(import (chicken type))
    45 (import (chicken read-syntax))
    4645(import slib-prec)
    4746
    4847;;;
     48
     49(define mod modulo)
    4950
    5051(include "slib-compat")
     
    8283    #f))
    8384
    84 (define (active-grammar-set! input #!optional (echo 'null) output)
     85(define (active-grammar-set! input output #!optional (echo 'null))
    8586  (set! *input-grammar* (get-grammar input))
    86   (set! *output-grammar* (or output (grammar-write-tab *input-grammar*)))
     87  (set! *output-grammar* output)
    8788  (set! *echo-grammar* echo) )
    8889
     
    9091
    9192(define (read-syntax-setup!)
     93  (import (only (chicken base) parentheses-synonyms))
     94  (import (only (chicken read-syntax) set-sharp-read-syntax! set-parameterized-read-syntax!))
    9295  (parentheses-synonyms #f)
    9396  (set-sharp-read-syntax! #\{
  • release/5/slib-prec/trunk/slib-prec.egg

    r38553 r38563  
    44
    55((synopsis "SLIB precedence-parse")
    6  (version "1.0.0")
     6 (version "0.0.1")
    77 (category data)
    88 (author "Aubrey Jaffer")
  • release/5/slib-prec/trunk/slib-prec.scm

    r38553 r38563  
    1111(;export
    1212  ;
     13  syntax-end!                 ; (set! *syn-defs* '())   => (syntax-end!)
    1314  syntax-begin!               ; (set! *syn-def* ...)    => (syntax-begin! ...)
    1415  syntax-current              ; *syn-def*               => (syntax-current)
     
    6667    (define charset-whitespace?)
    6768    (define charset-numeric?)
    68     #;(define charset-hex-numeric?)
     69    (define charset-hex-numeric?)
    6970    (let ()
    7071      (define ((charset-predicate cs) ch) (char-set-contains? cs ch))
     
    7475      (set! charset-whitespace? (charset-predicate char-set:white-space))
    7576      (set! charset-numeric? (charset-predicate char-set:digit))
    76       #;(set! charset-hex-numeric? (charset-predicate char-set:hex-digit)) )
     77      (set! charset-hex-numeric? (charset-predicate char-set:hex-digit)) )
     78    (define char-hex-numeric? charset-hex-numeric?)
    7779
    7880    ;Character range is that of a UTF-8 codepoint, not representable range
     
    8789
    8890(import (only (chicken port) call-with-output-string))
     91
    8992(include "slib-compat")
    9093
    9194(include "strsrch")
    9295
    93 (include "prec-dyn")
    94 (include "prec-tokenize")
    95 (include "prec-parse")
     96; these shouldn't be literals
     97(define *prec:comment-start* 200)
     98(define *prec:comment-weight* 220)
    9699
    97 (define (syntax-begin! #!optional (base '())) (set! *syn-defs* base))
    98 (define (syntax-end!) (set! *syn-defs* '()))
    99 (define (syntax-current) *syn-defs*)
    100 (define (syntax-ignore-whitespace) *syn-ignore-whitespace*)
     100(include "prec")
    101101
    102 (cond-expand
    103   (utf8
    104     (include "token-setup-utf8"))
    105   (else
    106     (include "token-setup")
    107     (define charset-whitespace? char-whitespace?)) )
     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)))))
    108111
    109 ; Ignore Whitespace Grammar Syntax Basis
    110 (syntax-begin!)
     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*)
    111116
    112 ; Ignore Whitespace characters.
    113 (prec:define-grammar (tok:char-group 0 tok:whitespaces #f))
    114 
    115 ; On MS-DOS systems, <ctrl>-Z (26) needs to be ignored in order to
    116 ; avoid problems at end of files.
    117 (case (software-type)
    118   ((ms-dos)
    119    (if (not (charset-whitespace? (integer->char 26)))
    120        (prec:define-grammar (tok:char-group 0 (integer->char 26) #f))
    121        )))
    122 
    123 ;@ Save these convenient definitions.
    124 (define *syn-ignore-whitespace* *syn-defs*)
    125 
    126 (syntax-end!)
     117(include "prec-setup")
    127118
    128119;;
  • release/5/slib-prec/trunk/tests/slib-prec-test.scm

    r38553 r38563  
    1616;;
    1717
    18 (active-grammar-set! 'standard 'schemepretty)
     18(active-grammar-set! 'standard 'disp2d 'schemepretty)
    1919(define ^ expt)
    2020
Note: See TracChangeset for help on using the changeset viewer.