home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
j
/
jacal1a0.zip
/
jacal
/
grammar.scm
< prev
next >
Wrap
Text File
|
1992-12-23
|
4KB
|
128 lines
;;; JACAL: Symbolic Mathematics System. -*-scheme-*-
;;; Copyright 1992 Aubrey Jaffer.
;;; See the file "COPYING" for terms applying to this program.
;(require 'record)
;(define grammar-rtd
; (make-record-type "grammar"
; '(name reader lex-tab read-tab writer write-tab)))
;(define make-grammar (record-constructor grammar-rtd))
;(define grammar-name (record-accessor grammar-rtd 'name))
;(define grammar-reader (record-accessor grammar-rtd 'reader))
;(define grammar-lex-tab (record-accessor grammar-rtd 'lex-tab))
;(define grammar-read-tab (record-accessor grammar-rtd 'read-tab))
;(define grammar-writer (record-accessor grammar-rtd 'writer))
;(define grammar-write-tab (record-accessor grammar-rtd 'write-tab))
(define (make-grammar name reader lex-tab read-tab writer write-tab)
(cons (cons name reader)
(cons (cons lex-tab read-tab) (cons writer write-tab))))
(define grammar-name caar)
(define grammar-reader cdar)
(define grammar-lex-tab caadr)
(define grammar-read-tab cdadr)
(define grammar-writer caddr)
(define grammar-write-tab cdddr)
(require 'alist)
(define *grammars* '())
(define grammar-associator (alist-associator eq?))
(define (defgrammar name grm)
(set! *grammars* (grammar-associator *grammars* name grm)))
(define grammar-remover (alist-remover eq?))
(define (rem-grammar name grm)
(set! *grammars* (grammar-remover *grammars* name grm)))
(define grammar-inquirer (alist-inquirer eq?))
(define (get-grammar name) (grammar-inquirer *grammars* name))
(defgrammar 'scheme
(make-grammar 'scheme
(lambda (grm) (read))
#f
#f
(lambda (sexp grm) (write sexp))
#f))
(defgrammar 'null
(make-grammar 'null
(lambda (grm) (math-error "cannot read null grammar"))
#f
#f
(lambda (sexp grm) #t)
#f))
;;; Establish autoload for PRETTY-PRINT.
(define (pretty-print . args)
(require 'pretty-print) (apply pretty-print args))
(defgrammar 'SchemePretty
(make-grammar 'SchemePretty
(lambda (grm) (read))
#f
#f
(lambda (sexp grm) (pretty-print sexp))
#f))
(define (read-sexp grm)
(funcall (grammar-reader grm) grm))
(define (write-sexp sexp grm)
(funcall (grammar-writer grm) sexp grm))
(define write-diag write) ;for now
(define display-diag display) ;for now
(define newline-diag newline) ;for now
;;;; careful write for displaying internal stuff
(define (math_print obj)
(cond ((pair? obj)
(display-diag #\()
(math_print (car obj))
(cond ((null? obj))
((pair? (cdr obj))
(for-each (lambda (x) (display-diag #\ ) (math_print x))
(cdr obj)))
(else (display-diag " . ") (math_print (cdr obj))))
(display-diag #\)))
((poly_var? obj) (display-diag (var->sexp obj)))
(else (write-diag obj)))
obj)
(define (math:warn . args)
(display-diag ";;;")
(let ((ans '()))
(for-each (lambda (obj)
(display-diag #\space)
(if (string? obj)
(display-diag obj)
(set! ans (math_print obj))))
args)
(newline-diag)
ans))
(define (math-error . args)
(newline-diag)
(apply math:warn args)
(if math_debug (error "") (math_exit #f)))
(define eval-error math-error)
(define (math-assert test . args)
(if (not test) (apply math-error args)))
(define (test ans fun . args)
(let ((res (apply fun args)))
(if (equal? ans res) #t (math:warn "trouble with " fun))))
;;; outputs list of strings with as much per line as possible.
(define (block-write-strings l)
(let* ((column 5)
(width (- (output-port-width (current-output-port)) column))
(ps (make-string column #\ )))
(set! column width)
(for-each (lambda (ap)
(set! column (+ (string-length ap) column))
(cond ((>= column width)
(newline)
(display ps)
(set! column (string-length ap)))
(else
(display " ")
(set! column (+ column 1))))
(display ap))
l)
(newline)))