home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / b116_1 / jacal / grammar < prev    next >
Text File  |  1993-09-23  |  6KB  |  190 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1992, 1993 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;(require 'record)
  6. ;(define grammar-rtd
  7. ;  (make-record-type "grammar"
  8. ;            '(name reader lex-tab read-tab writer write-tab)))
  9. ;(define make-grammar (record-constructor grammar-rtd))
  10. ;(define grammar-name (record-accessor grammar-rtd 'name))
  11. ;(define grammar-reader (record-accessor grammar-rtd 'reader))
  12. ;(define grammar-lex-tab (record-accessor grammar-rtd 'lex-tab))
  13. ;(define grammar-read-tab (record-accessor grammar-rtd 'read-tab))
  14. ;(define grammar-writer (record-accessor grammar-rtd 'writer))
  15. ;(define grammar-write-tab (record-accessor grammar-rtd 'write-tab))
  16.  
  17. (define (make-grammar name reader lex-tab read-tab writer write-tab)
  18.   (cons (cons name reader)
  19.     (cons (cons lex-tab read-tab) (cons writer write-tab))))
  20. (define grammar-name caar)
  21. (define grammar-reader cdar)
  22. (define grammar-lex-tab caadr)
  23. (define grammar-read-tab cdadr)
  24. (define grammar-writer caddr)
  25. (define grammar-write-tab cdddr)
  26.  
  27. (require 'alist)
  28. (define *grammars* '())
  29. (define grammar-associator (alist-associator eq?))
  30. (define (defgrammar name grm)
  31.   (set! *grammars* (grammar-associator *grammars* name grm)))
  32. (define grammar-remover (alist-remover eq?))
  33. (define (rem-grammar name grm)
  34.   (set! *grammars* (grammar-remover *grammars* name grm)))
  35. (define grammar-inquirer (alist-inquirer eq?))
  36. (define (get-grammar name) (grammar-inquirer *grammars* name))
  37. (define (list-of-grammars)
  38.   (define grammars '())
  39.   (alist-for-each (lambda (k v) (set! grammars (cons k grammars))) *grammars*)
  40.   grammars)
  41.  
  42.  
  43. (defgrammar 'scheme
  44.   (make-grammar 'scheme
  45.         (lambda (grm) (read))
  46.         #f
  47.         #f
  48.         (lambda (sexp grm) (write sexp))
  49.         #f))
  50.  
  51. (defgrammar 'null
  52.   (make-grammar 'null
  53.         (lambda (grm) (math:error 'cannot-read-null-grammar))
  54.         #f
  55.         #f
  56.         (lambda (sexp grm) #t)
  57.         #f))
  58.  
  59. ;;; Establish autoload for PRETTY-PRINT.
  60. (defgrammar 'SchemePretty
  61.   (let ((pploaded #f))
  62.     (make-grammar 'SchemePretty
  63.           (lambda (grm) (read))
  64.           #f
  65.           #f
  66.           (lambda (sexp grm)
  67.             (or pploaded (begin (require 'pretty-print)
  68.                     (set! pploaded #t)))
  69.             (pretty-print sexp))
  70.           #f)))
  71.  
  72. (define (read-sexp grm)
  73.   (funcall (grammar-reader grm) grm))
  74. (define (write-sexp sexp grm)
  75.   (funcall (grammar-writer grm) sexp grm))
  76. (define (math:write e grm)
  77.   (if (not (eq? 'null (grammar-name grm)))
  78.       (write-sexp (math->sexp e horner) grm)))
  79.  
  80. (define (write-diag obj) (write obj (current-error-port)))
  81. (define (display-diag obj) (display obj (current-error-port)))
  82. (define (newline-diag)
  83.   (let ((cep (current-error-port)))
  84.     (newline cep) (force-output cep)))
  85.  
  86. ;;;; careful write for displaying internal stuff
  87. (define (math:print obj)
  88.   (cond ((pair? obj)
  89.      (display-diag #\[)
  90.      (math:print (car obj))
  91.      (cond ((null? (cdr obj)))
  92.            ((list? (cdr obj))
  93.         (for-each (lambda (x) (display-diag #\ ) (math:print x))
  94.               (cdr obj)))
  95.            (else (display-diag " . ") (math:print (cdr obj))))
  96.      (display-diag #\]))
  97.     ((poly:var? obj) (display-diag (var:sexp obj)))
  98.     (else (write-diag obj)))
  99.   obj)
  100. (define (tran:translate sym)
  101.   (let ((as (assq sym tran:translations)))
  102.   (if as (cdr as) sym)))
  103. (define (tran:display sym)
  104.   (display (tran:translate sym)))
  105. (define (math:warn . args)
  106.   (display-diag ";;;")
  107.   (let ((ans '()))
  108.     (for-each (lambda (obj)
  109.         (display-diag #\space)
  110.         (if (symbol? obj)
  111.             (let ((symt (tran:translate obj)))
  112.               (display-diag symt)
  113.               (if (symbol? symt) (display-diag #\:)))
  114.             (set! ans (math:print obj))))
  115.           args)
  116.     (newline-diag)
  117.     ans))
  118. (define (math:error . args)
  119.   (newline-diag)
  120.   (apply math:warn args)
  121.   (if math:debug (error "") (math:exit #f)))
  122. (define eval-error math:error)
  123.  
  124. (define (test ans fun . args)
  125.   (let ((res (apply fun args)))
  126.     (if (equal? ans res) #t (math:warn 'trouble-with fun))))
  127.  
  128. ;;; outputs list of strings with as much per line as possible.
  129. (define (block-write-strings l)
  130.   (let* ((column 5)
  131.      (width (- (get-page-width) column))
  132.      (ps (make-string column #\  )))
  133.     (set! column width)
  134.     (for-each (lambda (ap)
  135.         (set! column (+ (string-length ap) column))
  136.         (cond ((and (positive? width) (>= column width))
  137.                (newline)
  138.                (display ps)
  139.                (set! column (string-length ap)))
  140.               (else
  141.                (display " ")
  142.                (set! column (+ column 1))))
  143.         (display ap))
  144.           l)
  145.     (newline)))
  146.  
  147. (define (get-page-height)
  148.   (case page-height
  149.     ((#f) 0)
  150.     ((#t) (output-port-height (current-output-port)))
  151.     (else page-height)))
  152.  
  153. (define (get-page-width)
  154.   (case page-width
  155.     ((#f) 0)
  156.     ((#t) (output-port-width (current-output-port)))
  157.     (else page-width)))
  158.  
  159. (define (paginate-file file)
  160.   (call-with-input-file
  161.       file
  162.     (lambda (infile)
  163.       (call-with-current-continuation
  164.        (lambda (escape)
  165.      (let ((h (get-page-height))
  166.            (l 0))
  167.        (do ((c (read-char infile) (read-char infile)))
  168.            ((eof-object? c) novalue)
  169.          (display c)
  170.          (cond ((not (char=? #\newline c)))
  171.            ((zero? h))
  172.            ((< l h) (set! l (+ 1 l)))
  173.            ((do-more) (set! l 0))
  174.            (else (escape #f))))))))))
  175.  
  176. (define (do-more)
  177.   (define helped #f)
  178.   (tran:display 'more)
  179.   (force-output)
  180.   (let loop ((r (read-char)))
  181.     (cond ((char=? #\  r) #t)
  182.       ((eof-object? r) #t)
  183.       ((char-whitespace? r) (loop (read-char)))
  184.       ((char-ci=? #\q r) #f)
  185.       (helped (loop (read-char)))
  186.       (else (tran:display 'q-to-quit-space-for-more:-)
  187.         (force-output)
  188.         (set! helped #t)
  189.         (loop (read-char))))))
  190.