- Timestamp:
- 05/30/20 00:18:26 (8 months ago)
- Location:
- release/5/slib-prec/trunk
- Files:
-
- 4 added
- 1 deleted
- 8 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/slib-prec/trunk/output-grammars.scm
r38553 r38716 1 ;;;; standard-grammar.scm -*- Scheme -*- 2 ;;;; Kon Lovett, Apr '20 3 1 4 ;; JACAL: Symbolic Mathematics System. -*-scheme-*- 2 5 ;; Copyright (C) 1989, 1990, 1991, 1992, 1993, 1995, 1997, 2007, 2009, 2010 Aubrey Jaffer. … … 18 21 ;;;; Here are the templates for 2 dimensional output 19 22 23 (define tps:2d) 24 #; ;cannot use 20 25 (define tps:2d 21 26 '( … … 86 91 )) 87 92 93 (define tps:c) 94 #; ;cannot use 88 95 (define tps:c 89 96 '( … … 108 115 )) 109 116 117 (define tps:std) 118 #; ;cannot use 110 119 (define tps:std 111 120 '( … … 137 146 (^^ 210 #d1211 "^^" #d2210) 138 147 )) 148 149 (define tps:tex) 150 #; ;cannot use 139 151 (define tps:tex 140 152 '( -
release/5/slib-prec/trunk/slib-compat.scm
r38563 r38716 3 3 4 4 (import (only (srfi 1) every last-pair)) 5 (import (only (chicken port) call-with-output-string)) 6 (import (only (chicken pretty-print) pretty-print)) 5 7 6 (import (only (chicken port) call-with-output-string)) 8 (define mod modulo) 9 10 (define (cleanup-handlers!) (begin)) 7 11 8 12 (define (find-if . args) 9 13 (import (only (srfi 1) find)) 10 (apply find args) )14 (apply find args) ) 11 15 12 (define (comlist:nthcdr n lst) 13 (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst)))) 16 (define (remove-if. args) 17 (import (only (srfi 1) remove)) 18 (apply remove args) ) 14 19 15 (define (last lst n) 16 (comlist:nthcdr (- (length lst) n) lst)) 17 18 (import (only (chicken pretty-print) pretty-print)) 20 (define last) 21 (let () 22 (define (comlist:nthcdr n lst) 23 (if (zero? n) lst (comlist:nthcdr (+ -1 n) (cdr lst)))) 24 (set! last (lambda (lst n) (comlist:nthcdr (- (length lst) n) lst))) ) 19 25 20 26 ;;@ FORCE-OUTPUT flushes any pending output on optional arg output port … … 31 37 (else softtype)) ) ) 32 38 33 (define (output-port-width port) 39 (define output-port-width) 40 (define output-port-height) 41 (let () 34 42 (import (only (chicken port) terminal-size)) 35 (let-values (((h w)(terminal-size port))) 36 (if (zero? w) 80 w))) 37 38 (define (output-port-height port) 39 (import (only (chicken port) terminal-size)) 40 (let-values (((h w) (terminal-size port))) 41 (if (zero? h) 25 h))) 43 (set! output-port-width (lambda (port) 44 (let-values (((h w) (terminal-size port))) 45 (if (zero? w) 80 w)))) 46 (set! output-port-height (lambda (port) 47 (let-values (((h w) (terminal-size port))) 48 (if (zero? h) 25 h)))) ) 42 49 43 50 (define provided? 44 51 (let ( 45 (+numeric+ '(inexact ))52 (+numeric+ '(inexact bignum)) 46 53 (+builtins+ '()) ) 47 54 (lambda (x) … … 90 97 (define slib:tab #\tab) 91 98 (define slib:form-feed #\page) 99 100 (define (math:error . args) (apply slib:error 'math: args)) 101 (define (math:warn . args) (apply slib:warn 'math: args)) 102 (define (math:exit b) (cleanup-handlers!) (slib:error "error in math system")) -
release/5/slib-prec/trunk/slib-grammar.scm
r38598 r38716 1 1 ;;;; slib-grammar.scm 2 2 3 ; 3 ;; 4 4 5 (define *grammar-ids* '()) 5 6 … … 27 28 28 29 ;;from jacal unparse.scm 30 29 31 (define (print-using-grammar sexp grm) 30 32 ;(print "[" (grammar-name grm) "] " sexp) 31 33 (pretty-print sexp) 32 #; ; needs most of jacal!34 #; ;FIXME needs most of jacal! 33 35 (template-print sexp (grammar-write-tab grm)) ) 34 36 … … 38 40 (make-grammar name reader read-tab writer write-tab) 39 41 grammar? 40 (name grammar-name )42 (name grammar-name grammar-name-set!) 41 43 (reader grammar-reader grammar-reader-set!) 42 44 (read-tab grammar-read-tab grammar-read-tab-set!) … … 67 69 68 70 ; 69 (define (read-sexp grm icol) ((grammar-reader grm) grm icol))70 (define (write-sexp sexp grm) ((grammar-writer grm) sexp grm))71 (define (read-sexp grm column) ((grammar-reader grm) grm column)) 72 (define (write-sexp sexp grm) ((grammar-writer grm) sexp grm)) 71 73 72 74 (define *tab-stop* 8) … … 87 89 ;; 88 90 89 ; 90 (define (make-grm-parse-reader delim #!optional (port (current-input-port))) 91 (lambda (grm column) 91 (define (make-delimited-parse-grammar-reader delim) 92 (lambda (grm column #!optional (port (current-input-port))) 92 93 (prec:parse 93 94 (grammar-read-tab grm) … … 96 97 port)) ) 97 98 98 (define (read-sexp/delim grm delim port) 99 (unless (grammar? grm) (error 'read-sexp/delim "invalid grammar" grm)) 100 (let ( 101 (tmp (grammar-reader grm)) ) 102 (grammar-reader-set! grm (make-grm-parse-reader delim port)) 103 (let ( 104 (res (read-sexp grm 0)) ) 105 (grammar-reader-set! grm tmp) 106 res ) ) ) 99 ;; 100 101 (define (grammar-copy! grm1 grm2) 102 (grammar-name-set! grm1 (grammar-name grm2)) 103 (grammar-reader-set! grm1 (grammar-reader grm2)) 104 (grammar-read-tab-set! grm1 (grammar-read-tab grm2)) 105 (grammar-writer-set! grm1 (grammar-writer grm2)) 106 (grammar-read-tab-set! grm1 (grammar-write-tab grm2)) ) 107 108 (define temporary-grammar 109 (let ((+grammar-cache+ (make-grammar #f #f #f #f #f))) 110 (lambda (grm) 111 (grammar-copy! +grammar-cache+ grm) 112 +grammar-cache+ ) ) ) 113 114 (define (read-delimited-sexp port delim grm column) 115 (unless (grammar? grm) (error 'read-delimited-sexp "invalid grammar" grm)) 116 (let ((tmp (temporary-grammar grm))) 117 (grammar-reader-set! tmp (make-delimited-parse-grammar-reader delim)) 118 (parameterize ((current-input-port port)) 119 (read-sexp tmp column) ) ) ) -
release/5/slib-prec/trunk/slib-prec-grammar.scm
r38598 r38716 7 7 (;export 8 8 ; 9 active-grammar 10 active- grammar-set!9 active-grammar active-grammar-set! 10 active-input-grammar active-output-grammar active-echo-grammar 11 11 read-syntax-setup! 12 12 ; … … 33 33 clear-grammars 34 34 ; 35 make-delimited-parse-grammar-reader 35 36 read-sexp 36 37 write-sexp … … 41 42 (import (chicken base)) 42 43 (import (chicken type)) 43 (import slib-prec )44 (import slib-prec-parse) 44 45 45 46 ;;; 46 47 47 (define mod modulo) 48 (include "slib-compat") 49 (include "slib-grammar") 48 50 49 (include "slib-compat") 50 51 (define (math:error . args) (apply slib:error 'math: args)) 52 (define (math:warn . args) (apply slib:warn 'math: args)) 53 (define (math:exit b) #;(cleanup-handlers!) (slib:error "error in math system")) 54 55 (include "slib-grammar") 51 ;; 56 52 57 53 (define *input-grammar*) 58 54 (define *output-grammar*) 59 55 (define *echo-grammar*) 60 61 (include "output-grammars")62 (include "input-grammars")63 64 (defgrammar 'null65 (make-grammar66 'null67 (lambda (grm) (math:error 'cannot-read-null-grammar))68 #f69 (lambda (sexp grm) #t)70 #f))71 72 (defgrammar 'scheme73 (make-grammar74 'scheme75 (lambda (grm) (read))76 #f77 (lambda (sexp grm) (write sexp) (force-output))78 #f))79 80 ;;; Establish autoload for PRETTY-PRINT.81 (defgrammar 'schemepretty82 (make-grammar83 'schemepretty84 (lambda (grm)85 (read) )86 #f87 (lambda (sexp grm)88 (import (chicken pretty-print))89 (pretty-print sexp)90 (force-output) )91 #f))92 56 93 57 (define (active-grammar-set! input output #!optional (echo 'null)) … … 96 60 (set! *echo-grammar* echo) ) 97 61 98 (define (active-grammar) (values *input-grammar* *output-grammar* *echo-grammar*)) 62 (define (active-grammar) 63 (values *input-grammar* *output-grammar* *echo-grammar*) ) 64 65 (define (active-input-grammar) (receive (i o e) (active-grammar) i)) 66 (define (active-output-grammar) (receive (i o e) (active-grammar) o)) 67 (define (active-echo-grammar) (receive (i o e) (active-grammar) e)) 99 68 100 69 ;; … … 103 72 (import (only (chicken base) parentheses-synonyms)) 104 73 (import (only (chicken read-syntax) set-sharp-read-syntax! set-parameterized-read-syntax!)) 105 (parentheses-synonyms #f)106 74 (set-sharp-read-syntax! #\{ 107 75 (lambda (port) 108 (read-sexp/delim (get-grammar/id 0) #\} port))) 76 (parameterize ((parentheses-synonyms #f)) 77 (read-delimited-sexp port #\} (get-grammar/id 0) 0)))) 109 78 (set-parameterized-read-syntax! #\{ 110 79 (lambda (port id) 111 (read-sexp/delim (get-grammar/id id) #\} port))) ) 112 113 ;; 114 115 ;init by id-# grammar lookup 116 (define-constant DEFAULT-GRAMMARS '( 117 standard disp2d tex 118 null scheme schemepretty)) 119 (grammar-id-name-setup! DEFAULT-GRAMMARS) 80 (parameterize ((parentheses-synonyms #f)) 81 (read-delimited-sexp port #\} (get-grammar/id id) 0)))) ) 120 82 121 83 ) ;slib-prec-grammar -
release/5/slib-prec/trunk/slib-prec.egg
r38563 r38716 13 13 (test-dependencies test) 14 14 (components 15 (extension slib-prec-read-syntax 16 (types-file) 17 (component-dependencies slib-prec-grammar) 18 (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings")) 15 19 (extension slib-prec-grammar 16 20 (types-file) 17 (component-dependencies slib-prec) 18 ;no -local since must allow assignment to imported value bindings; ex: `*input-grammar*' 19 (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks-for-toplevel-bindings")) 21 (component-dependencies slib-prec-parse) 22 (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings")) 23 (extension slib-prec-parse 24 (types-file) 25 ;suspect -strict-types might be an issue 26 (csc-options "-O3" "-d1" "-local" "-D" "utf8" "-no-procedure-checks-for-toplevel-bindings")) 27 (extension slib-basic-grammars 28 (types-file) 29 (component-dependencies slib-prec-parse slib-prec-grammar) 30 (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings")) 31 (extension slib-standard-grammar 32 (types-file) 33 (component-dependencies slib-prec-parse slib-prec-grammar) 34 (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings")) 35 (extension slib-tex-grammar 36 (types-file) 37 (component-dependencies slib-prec-parse slib-prec-grammar) 38 (csc-options "-O3" "-d1" "-local" "-strict-types" "-no-procedure-checks-for-toplevel-bindings")) 20 39 (extension slib-prec 21 40 (types-file) 22 ;no -local since must allow assignment to imported value bindings; ex: `*syn-defs*' 23 ;suspect -strict-types might be an issue 24 (csc-options "-O3" "-d1" "-D" "utf8" "-no-procedure-checks-for-toplevel-bindings")) ) ) 41 (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")) ) ) -
release/5/slib-prec/trunk/slib-prec.scm
r38563 r38716 10 10 11 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) 12 read-sexp-from-string) 41 13 42 14 (import scheme) 15 (import (chicken module)) 43 16 (import (chicken base)) 17 18 (import slib-prec-parse) 19 (reexport slib-prec-parse) 20 21 (import slib-prec-grammar) 22 (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)) ) 44 34 45 35 ;;; 46 36 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 37 #| 128 38 ;; 129 39 … … 162 72 (define (*eval-grammer-form loc imd base) 163 73 (begin) ) 74 |# 164 75 165 76 ) ;slib-prec -
release/5/slib-prec/trunk/tests/run.scm
r38553 r38716 71 71 ;;; Do Test 72 72 73 (run-tests) 73 (run-test) 74 ;(run-tests) -
release/5/slib-prec/trunk/tests/slib-prec-test.scm
r38598 r38716 6 6 7 7 (import slib-prec) 8 (import slib-prec-grammar) 8 9 ;; 9 10 10 11 ;;; … … 14 15 (import utf8-srfi-13) 15 16 17 ;; Operator Aliaes 18 19 (define ^ expt) 20 16 21 ;; 17 22 18 (active-grammar-set! 'standard 'disp2d 'schemepretty) 19 (define ^ expt) 23 ;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)) 26 (clear-grammar-ids) 27 (grammar-id-name-setup! DEFAULT-GRAMMARS) 28 ;(grammar-id-name-setup! `(,@DEFAULT-GRAMMARS)) 20 29 21 ( define (active-input-grammar) (receive (i o e) (active-grammar) i))30 (active-grammar-set! 'standard #f 'schemepretty) 22 31 23 32 ;; 24 33 25 34 (test-group "Grammer IDs" 26 (test 6(count-of-grammar-ids))35 (test (length DEFAULT-GRAMMARS) (count-of-grammar-ids)) 27 36 (test 'standard (grammar-id-name 0)) 28 37 (test 'scheme (grammar-id-name 4)) … … 31 40 ;; 32 41 33 (define (read-sexp/string str #!optional (grm (active-input-grammar)) (icol 0))34 (import (only (chicken port) with-input-from-string))35 (with-input-from-string str (lambda () (read-sexp grm icol))) )36 37 42 (define-syntax test-parse 38 43 (syntax-rules () 39 44 ((test-parse ?out ?in) 40 (test ?in ?out (read-sexp /string ?in)) )45 (test ?in ?out (read-sexp-from-string ?in)) ) 41 46 ((test-parse ?msg ?out ?in) 42 (test ?msg ?out (read-sexp /string ?in)) ) ) )47 (test ?msg ?out (read-sexp-from-string ?in)) ) ) ) 43 48 44 49 (test-group "Jacal Grammar (English)" … … 52 57 (test-parse "N/D (ratio) => (/ N D)" '(/ (* (+ 1 2) 1) 5) "(1 + 2) * 1/5") 53 58 54 (test 15 (eval (read-sexp /string "(1 + 2) * 5;")))55 (test 15.0 (eval (read-sexp /string "(1.0 + 2) * 5")))56 (test 3/5 (eval (read-sexp /string "(1 + 2) * 1/5")))59 (test 15 (eval (read-sexp-from-string "(1 + 2) * 5;"))) 60 (test 15.0 (eval (read-sexp-from-string "(1.0 + 2) * 5"))) 61 (test 3/5 (eval (read-sexp-from-string "(1 + 2) * 1/5"))) 57 62 58 (test 8 (eval (read-sexp /string "2**3")))63 (test 8 (eval (read-sexp-from-string "2**3"))) 59 64 ) 60 65 … … 80 85 (test #(1) #0{[1]}) ;(vector 1) 81 86 (test #(1) #1{[1]}) ;(vector 1) 82 (test #(1) #2{[1]}) ;(vector 1)83 87 ) 84 88 |#
Note: See TracChangeset
for help on using the changeset viewer.