DataMuseum.dk

top - download

    Length: 24687 (0x606f)
    Types: TextFile
    Names: »parse.scm.70«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/parse.scm.70« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Scheme Parser

(declare (usual-integrations))

(define *get-character)

(define (*eof-action)
  '())

(define *tyi)
(define *tyipeek)
(define *dismiss-character)
(define *read)

(define *get-character-buffer* #!FALSE)
(define *parser-radix* #o12)
\f


;;;; Character Class Tables
;;; This group of variables is in global for speed.

(define *whitespace-bit*
  (access *whitespace-bit* character-package))

(define *alphabetic-bit*
  (access *alphabetic-bit* character-package))

(define *digit-bit*
  (access *digit-bit* character-package))

(define *atom-terminator-bit*
  ((access make-character-predicate-table character-package)
   (lambda (char)
     (disjunction
      (vector-1b-ref *whitespace-bit* char)
      (character-equal? char #/')
      (character-equal? char #/()
      (character-equal? char #/))
      (character-equal? char #/;)
      (character-equal? char #/#)
      (character-equal? char #/")
      (character-equal? char #/|)
      (character-equal? char (access end-of-file character-package))))))

(define *atom-constituent-bit*
  ((access make-character-predicate-table character-package)
   (lambda (char)
     (conjunction
      (< char (access *number-of-characters-in-ascii* character-package))
      (not (vector-1b-ref *atom-terminator-bit* char))))))

(define *parser-named-characters*
  `((NULL . #o0)
    (BELL . #o7)
    (TAB . ,(access tab character-package))
    (LF . ,(access line-feed character-package))
    (FF . ,(access form-feed character-package))
    (CR . ,(access carriage-return character-package))
    (SP . ,(access space character-package))
    (DOT . #o56)))

(define *parser-named-objects*
  `((NULL . ,(list))
    (FALSE . ,(eq? 'TRUE 'FALSE))
    (TRUE . ,(eq? 'TRUE 'TRUE))
    (OPTIONAL . ,(access lambda-optional-tag lambda-package))))
\f


(define *parser-table*)
(define *parse-object-table*)
(define *collect-list-table*)
(define *parse-object-special-table*)
(define *collect-list-special-table*)

(define scheme-parser
  (make-package scheme-parser
		((end-of-file-character
		  (access end-of-file character-package))
		 (close-comment-character
		  (access end-of-line character-package))
		 (whitespace-characters
		  (access whitespace character-package))
		 (numerical-value
		  (access numerical-value character-package))
		 (for-each-character!
		  (access for-each-character character-package))
		 (make-character-dispatch-vector
		  (access make-character-dispatch-vector character-package)))

(define =char? eq?)
(define mem-char memq)
(define intern-character-list
  (make-primitive-procedure 'INTERN-CHARACTER-LIST))

(declare (compilable-primitive-functions (=char? eq?)
					 (mem-char memq)
					 intern-character-list))

;;; This will capture the syntax definitions inside.

(let-syntax ()
\f


;;;; Character Operations

;;; Hairy stuff.  Differs from the traditional TYI/TYIPEEK combination.
;;; TYIPEEK is THIS-CHARACTER.  TYI is THIS-CHARACTER followed by
;;; DISMISS-THIS-CHARACTER, but usually we use them the other way around.
;;; So NEXT-CHARACTER means DISMISS-THIS-CHARACTER followed by THIS-CHARACTER.

;;; These procedures are open coded this way for speed.
;;; Unfortunately we don't yet have real procedure integration.

(define-macro (this-character-pass-eof)
  `(disjunction *get-character-buffer*
		(sequence (set! *get-character-buffer* (*get-character))
			  *get-character-buffer*)))

(define (this-character-pass-eof)
  (this-character-pass-eof))

(define-macro (this-character)
  `(if (=char? (this-character-pass-eof) end-of-file-character)
       (error "End of file within READ")
       *get-character-buffer*))

(define (this-character)
  (this-character))

(define-macro (next-character-pass-eof)
  `(if (set! *get-character-buffer* (*get-character))
       *get-character-buffer*
       (error "Dismissed unseen character" 'CALL-A-WIZARD)))

(define (next-character-pass-eof)
  (next-character-pass-eof))

(define-macro (next-character)
  `(if (=char? (next-character-pass-eof) end-of-file-character)
       (error "End of file within READ")
       *get-character-buffer*))

(define (next-character)
  (next-character))

(define-macro (dismiss-this-character)
  `(if (not (set! *get-character-buffer* #!FALSE))
       (error "Dismissed unseen character" 'CALL-A-WIZARD)))

(define (dismiss-this-character)
  (dismiss-this-character))

(set! *tyipeek
      (named-lambda (*tyipeek)
	(if (=char? (this-character-pass-eof) end-of-file-character)
	    (*eof-action)
	    *get-character-buffer*)))

(set! *tyi
      (named-lambda (*tyi)
	(if (=char? (this-character-pass-eof) end-of-file-character)
	    (sequence (set! *get-character-buffer* #!FALSE)
		      (*eof-action))
	    (set! *get-character-buffer* #!FALSE))))

(set! *dismiss-character
      (named-lambda (*dismiss-character)
	(if (not (set! *get-character-buffer* #!FALSE))
	    (*get-character))))
\f


(define-macro (atom-terminator? char)
  `(vector-1b-ref *atom-terminator-bit* ,char))

(define (atom-terminator? char)
  (atom-terminator? char))

(define-macro (atom-constituent? char)
  `(vector-1b-ref *atom-constituent-bit* ,char))

(define (atom-constituent? char)
  (atom-constituent? char))

(define-macro (whitespace? char)
  `(vector-1b-ref *whitespace-bit* ,char))

(define (whitespace? char)
  (whitespace? char))

(define-macro (alphabetic? char)
  `(vector-1b-ref *alphabetic-bit* ,char))

(define (alphabetic? char)
  (alphabetic? char))

(define-macro (digit? char)
  `(vector-1b-ref *digit-bit* ,char))

(define (digit? char)
  (digit? char))
\f


;;;; Table dispatches

(define-macro (parse-object)
  `((vector-ref *parse-object-table* (this-character-pass-eof))))

(define (parse-object)
  (parse-object))

(set! *read parse-object)

(define-macro (dismiss-and-parse-object)
  `((vector-ref *parse-object-table* (next-character-pass-eof))))

(define (dismiss-and-parse-object)
  (dismiss-and-parse-object))

(define-macro (collect-list)
  `((vector-ref *collect-list-table* (this-character))))

(define (collect-list)
  (collect-list))

(define-macro (dismiss-and-collect-list)
  `((vector-ref *collect-list-table* (next-character))))

(define (dismiss-and-collect-list)
  (dismiss-and-collect-list))
\f


;;;; Atoms

;;; There are two major dispatch tables, one for parsing at top level,
;;; the other for parsing the elements of a list.  Most of the entries
;;; for each table are have similar actions.

;;; Default is atomic object.  Parsing an atomic object does not
;;; consume its terminator.  Thus different terminators [such as open
;;; paren, close paren, and whitespace], can have different effects on
;;; parser.

(define ((collect-list-wrapper object-parser))
  (let ((value (object-parser)))			;forces order.
    (cons value (collect-list))))

(define (parse-atom)
  (build-atom (accumulate-atom (this-character-pass-eof))))

(define parse-atom-in-list
  (collect-list-wrapper parse-atom))

;;; Names beginning with alphabetic characters are handled specially
;;; to speed up the parsing of symbols.

(define (parse-symbol)
  (intern-character-list (accumulate-atom (this-character-pass-eof))))

(define parse-symbol-in-list
  (collect-list-wrapper parse-symbol))

(define (build-atom char-list)
  (disjunction (parse-number char-list)
	       (intern-character-list char-list)))

(define (accumulate-atom char)
  (cons (character-upcase char)
	(if (atom-terminator? (next-character-pass-eof))
	    '()
	    (accumulate-atom *get-character-buffer*))))	;Speed up hack.
\f


;;;; Lists

(define (parse-list)
  (dismiss-and-collect-list))

(define parse-list-in-list
  (collect-list-wrapper parse-list))

(define (parse-vector)
  (list->vector (parse-list)))

(define parse-vector-in-list
  (collect-list-wrapper parse-vector))

;;; Ignore close parens typed at top level.

(define (parse-close-list)
  (dismiss-and-parse-object))

(define (parse-close-list-in-list)
  (dismiss-this-character)
  '())

(define (dotted-list-tail)
  ;; atom with initial dot?
  (if (atom-constituent? (next-character))
      (let ((first (build-atom (cons #/. (accumulate-atom (this-character))))))
        (cons first (collect-list)))

      ;; (A . B) -- get B and ignore whitespace following it.
      (let ((tail (parse-object)))
	(let ignore-whitespace ((char (this-character)))
	     (cond ((=char? char #/))
		    (dismiss-this-character))
		   ((whitespace? char)
		    (ignore-whitespace (next-character)))
		   (else
		    (error "Illegal character in ignored stream" char))))
        tail)))
\f


;;;; Whitespace and Comments

(define (parse-whitespace)
  (dismiss-and-parse-object))

(define (parse-whitespace-in-list)
  (dismiss-and-collect-list))

(define (parse-end-of-file)
  (*eof-action))

(define (parse-end-of-file-in-list)
  (error "End of file within READ"))

(define (parse-comment)
  (let flush-comment ((char (next-character-pass-eof)))
    (cond ((=char? char close-comment-character)
	   (dismiss-and-parse-object))
	  ((=char? char end-of-file-character)
	   (parse-object))
	  (else
	   (flush-comment (next-character-pass-eof))))))

(define (parse-comment-in-list)
  (let flush-comment ((char (next-character)))
    (cond ((=char? char close-comment-character)
	   (dismiss-and-collect-list))
	  (else
	   (flush-comment (next-character))))))

(define (parse-special-comment)
  (let special-comment-loop ((char (next-character)))
       (if (=char? char #/|)
	   (let ((next-char (next-character)))
	     (if (=char? next-char #/#)
		 (dismiss-and-parse-object)
		 (special-comment-loop next-char)))
	   (special-comment-loop (next-character)))))

(define (parse-special-comment-in-list)
  (let special-comment-loop ((char (next-character)))
       (if (=char? char #/|)
	   (let ((next-char (next-character)))
	     (if (=char? next-char #/#)
		 (dismiss-and-collect-list)
		 (special-comment-loop next-char)))
	   (special-comment-loop (next-character)))))
\f


;;;; Quoteification

(define (parse-quote)
  (cons 'QUOTE
	(cons (dismiss-and-parse-object)
	      '())))

(define parse-quote-in-list
  (collect-list-wrapper parse-quote))

(define (parse-quasiquote)
  (cons 'QUASIQUOTE
	(cons (dismiss-and-parse-object)
	      '())))

(define parse-quasiquote-in-list
  (collect-list-wrapper parse-quasiquote))

(define (parse-quasiunquote)
  (if (=char? (next-character) #/@)
      (cons 'QUASIQUOTE-SPREADER
	    (cons (dismiss-and-parse-object)
		  '()))
      (cons 'QUASIQUOTE-UNQUOTER
	    (cons (parse-object)
		  '()))))

(define parse-quasiunquote-in-list
  (collect-list-wrapper parse-quasiunquote))

(define (parse-string)
  (list->string
   (let accumulate-string ((char (next-character)))
	(if (=char? char #/")
	    (let ((next-char (next-character-pass-eof)))
	      (if (=char? next-char #/")
		  (cons next-char
			(accumulate-string (next-character)))
		  '()))
	    (cons char (accumulate-string (next-character)))))))

(define parse-string-in-list
  (collect-list-wrapper parse-string))

(define (parse-special-atom)
  (intern-character-list
   (cons #/|
	 (let accumulate-special-atom ((char (next-character)))
	      (cons char
		    (if (=char? char #/|)
			(let ((next-char (next-character-pass-eof)))
			  (if (=char? next-char #/|)
			      (accumulate-special-atom (next-character))
			      '()))
			(accumulate-special-atom (next-character))))))))

(define parse-special-atom-in-list
  (collect-list-wrapper parse-special-atom))
\f


;;;; Abstract Object Syntax

(define (parse-character-value)
  (let ((char (next-character)))
    (dismiss-this-character)
    char))

(define parse-character-value-in-list
  (collect-list-wrapper parse-character-value))

(define (parse-named-character)
  (let ((character-name (dismiss-and-parse-object)))
    (cdr (disjunction (assq character-name *parser-named-characters*)
		      (error "No character by this name" 'READ
			     character-name)))))

(define parse-named-character-in-list
  (collect-list-wrapper parse-named-character))

(define (parse-named-object)
  (let ((object-name (dismiss-and-parse-object)))
    (cdr (disjunction (assq object-name *parser-named-objects*)
		      (error "No object by this name" 'READ object-name)))))

(define parse-named-object-in-list
  (collect-list-wrapper parse-named-object))
\f


;;;; Radix Management

(define ((establish-temporary-radix new-radix))
  (fluid-let ((*parser-radix* new-radix))
    (disjunction
     (build-special-integer (accumulate-atom (next-character-pass-eof)))
     (error "Bad syntax for special integer" 'READ))))

(define parse-base-2-integer
  (establish-temporary-radix 2))

(define parse-base-2-integer-in-list
  (collect-list-wrapper parse-base-2-integer))

(define parse-base-8-integer
  (establish-temporary-radix 8))

(define parse-base-8-integer-in-list
  (collect-list-wrapper parse-base-8-integer))

(define parse-base-10-integer
  (establish-temporary-radix 10))

(define parse-base-10-integer-in-list
  (collect-list-wrapper parse-base-10-integer))

(define parse-base-16-integer
  (establish-temporary-radix 16))

(define parse-base-16-integer-in-list
  (collect-list-wrapper parse-base-16-integer))

(define (parse-radix-change)
  (establish-permanent-radix)
  (parse-object))

(define (parse-radix-change-in-list)
  (establish-permanent-radix)
  (collect-list))

(define (establish-permanent-radix)
  (let ((new-radix (dismiss-and-parse-object)))
    (if (conjunction (integer? new-radix) (> new-radix 1))
        (set! *parser-radix* new-radix)
        (error "Bad radix" 'READ new-radix))))
\f


;;;; Numbers
;;; [+/-][n*][.][n*][E/e[+/-][n*]]

(define (parse-number char-list)
  (cond ((=char? (car char-list) #/-)
         (build-signed-number (cdr char-list) -1))
        ((=char? (car char-list) #/+)
         (build-signed-number (cdr char-list) +1))
        (else
         (build-signed-number char-list +1))))

(define (build-signed-number char-list sign)
  (conjunction char-list
	       (cond ((digit? (car char-list))
		      (let ((v (build-unsigned-number char-list 0)))
			(conjunction v (* v sign))))
		     ((conjunction (=char? (car char-list) #/.)
				   (not (null? (cdr char-list)))
				   (digit? (cadr char-list)))
		      (let ((v (build-float (cdr char-list) 0)))
			(conjunction v (* v sign))))
		     (else #!FALSE))))			;makes +/- symbols

(define (build-unsigned-number char-list value)
  (cond ((null? char-list)
	 value)
	((=char? (car char-list) #/.)			; 123. is a "float"
	 (build-float (cdr char-list) value))
	((digit? (car char-list))
	 (build-unsigned-number (cdr char-list)
				(+ (* *parser-radix* value)
				   (numerical-value (car char-list)))))
	((mem-char (car char-list) '(#/E #/e))
	 (build-scientific (cdr char-list) value 0 0))
	(else #!FALSE)))

(define (build-float char-list integer-part)
  (define (float-loop char-list fraction place-value)
    ;; fraction is the numerator and radix^place-value is the denominator.
    (cond ((null? char-list)
	   (+ integer-part
	      (/ fraction (integer-expt *parser-radix* place-value))))
	  ((digit? (car char-list))
	   (float-loop (cdr char-list)
		       (+ (* *parser-radix* fraction)
			  (numerical-value (car char-list)))
		       (1+ place-value)))
	  ((mem-char (car char-list) '(#/E #/e))
	   (build-scientific (cdr char-list)
			     integer-part
			     fraction
			     place-value))
	  (else #!FALSE)))
  (float-loop char-list 0 0))

(define (build-scientific char-list integer-part fraction place-value)
  (conjunction
   (not (null? char-list))
   (let ((v (parse-number char-list)))
     (conjunction
      (not (null? v))
      (+ (* integer-part (expt *parser-radix* v))
	 (* fraction (expt *parser-radix* (- v place-value))))))))
\f


;;;; Special Integers

;;; are constructed when using temporary radices -- this is how we
;;; get the hexadecimal radix to work, for instance.

(define &- (make-primitive-procedure '&-))
(define A-10 (- #/A 10))

(define (build-special-integer char-list)
  (cond ((digit? (car char-list))
	 (build-unsigned-special-integer 
	  (cdr char-list)
	  (&- (car char-list) #/0)))
	((alphabetic? (car char-list))
	 (build-unsigned-special-integer 
	  (cdr char-list)
	  (&- (character-upcase (car char-list)) A-10)))
	((=char? (car char-list) #/-)
	 (conjunction 
	  (not (null? (cdr char-list)))
	  (let ((v (build-unsigned-special-integer (cdr char-list) 0)))
	    (conjunction v (* -1 )))))
	((=char? (car char-list) #/+)
	 (conjunction
	  (not (null? (cdr char-list)))
	  (build-unsigned-special-integer (cdr char-list) 0)))
	(else #!FALSE)))

(define (build-unsigned-special-integer char-list value)
  (cond ((null? char-list)
	 value)
	((digit? (car char-list))
	 (build-unsigned-special-integer 
	  (cdr char-list)
	  (+ (* *parser-radix* value) (&- (car char-list) #/0))))
	((alphabetic? (car char-list))
	 (build-unsigned-special-integer
	  (cdr char-list)
	  (+ (* *parser-radix* value)
	     (&- (character-upcase (car char-list)) A-10))))
	(else #!FALSE)))
\f


;;;; Dispatch Table Construction

(define (parse-undefined-special)
  (error "No such special reader macro" 'READ (this-character)))

(define (parse-special-macro)
  ((vector-ref *parse-object-special-table* (next-character))))

(define (parse-special-macro-in-list)
  ((vector-ref *collect-list-special-table* (next-character))))

(set! *parse-object-table*
      (make-character-dispatch-vector parse-atom))

(set! *collect-list-table*
      (make-character-dispatch-vector parse-atom-in-list))

(set! *parse-object-special-table*
      (make-character-dispatch-vector parse-undefined-special))

(set! *collect-list-special-table*
      (make-character-dispatch-vector parse-undefined-special))

(set! *parser-table*
      (cons (cons *parse-object-table* *collect-list-table*)
	    (cons *parse-object-special-table* *collect-list-special-table*)))

(vector-set! *parse-object-table* #/# parse-special-macro)
(vector-set! *collect-list-table* #/# parse-special-macro-in-list)

(for-each-character!
 (lambda (char)
   (if (alphabetic? char)
       (sequence
	(vector-set! *parse-object-table* char parse-symbol)
	(vector-set! *collect-list-table* char parse-symbol-in-list)))))

(vector-set! *parse-object-table* #/( parse-list)
(vector-set! *collect-list-table* #/( parse-list-in-list)
(vector-set! *parse-object-special-table* #/( parse-vector)
(vector-set! *collect-list-special-table* #/( parse-vector-in-list)
(vector-set! *parse-object-table* #/) parse-close-list)
(vector-set! *collect-list-table* #/) parse-close-list-in-list)
(vector-set! *collect-list-table* #/. dotted-list-tail)

(mapc (lambda (char)
	(vector-set! *parse-object-table* char parse-whitespace)
	(vector-set! *collect-list-table* char parse-whitespace-in-list))
      whitespace-characters)

(vector-set! *parse-object-table* end-of-file-character parse-end-of-file)
(vector-set! *collect-list-table* end-of-file-character
	     parse-end-of-file-in-list)
\f


(vector-set! *parse-object-table* #/; parse-comment)
(vector-set! *collect-list-table* #/; parse-comment-in-list)
(vector-set! *parse-object-special-table* #/| parse-special-comment)
(vector-set! *collect-list-special-table* #/| parse-special-comment-in-list)

(vector-set! *parse-object-table* #/' parse-quote)
(vector-set! *collect-list-table* #/' parse-quote-in-list)
(vector-set! *parse-object-table* #/` parse-quasiquote)
(vector-set! *collect-list-table* #/` parse-quasiquote-in-list)
(vector-set! *parse-object-table* #/, parse-quasiunquote)
(vector-set! *collect-list-table* #/, parse-quasiunquote-in-list)
(vector-set! *parse-object-table* #/" parse-string)
(vector-set! *collect-list-table* #/" parse-string-in-list)
(vector-set! *parse-object-table* #/| parse-special-atom)
(vector-set! *collect-list-table* #/| parse-special-atom-in-list)

(vector-set! *parse-object-special-table* #// parse-character-value)
(vector-set! *collect-list-special-table* #// parse-character-value-in-list)
(vector-set! *parse-object-special-table* #/\ parse-named-character)
(vector-set! *collect-list-special-table* #/\ parse-named-character-in-list)
(vector-set! *parse-object-special-table* #/! parse-named-object)
(vector-set! *collect-list-special-table* #/! parse-named-object-in-list)

(mapc (lambda (char)
	(vector-set! *parse-object-special-table* char parse-base-2-integer)
	(vector-set! *collect-list-special-table* char
		     parse-base-2-integer-in-list))
      '(#/B #/b))

(mapc (lambda (char)
	(vector-set! *parse-object-special-table* char parse-base-8-integer)
	(vector-set! *collect-list-special-table* char
		     parse-base-8-integer-in-list))
      '(#/O #/o))

(mapc (lambda (char)
	(vector-set! *parse-object-special-table* char parse-base-10-integer)
	(vector-set! *collect-list-special-table* char
		     parse-base-10-integer-in-list))
      '(#/D #/d))

(mapc (lambda (char)
	(vector-set! *parse-object-special-table* char parse-base-16-integer)
	(vector-set! *collect-list-special-table* char
		     parse-base-16-integer-in-list))
      '(#/X #/x))

;(mapc (lambda (char)
;	(vector-set! *parse-object-special-table* char parse-radix-change)
;	(vector-set! *collect-list-special-table* char
;		     parse-radix-change-in-list))
;      '(#/R #/r))

;;; end LET-SYNTAX.
)
;;; end SCHEME-PARSER package.
))
\f


;;;; Parser Tables

(define (current-parser-table)
  *parser-table*)

(define (set-current-parser-table! new-table)
  (set! *parse-object-table* (caar new-table))
  (set! *collect-list-table* (cdar new-table))
  (set! *parse-object-special-table* (cadr new-table))
  (set! *collect-list-special-table* (cddr new-table))
  (set! *parser-table* new-table))

(define (with-parser-table new-parser-table thunk)
  (define old-parser-table)
  (dynamic-wind (lambda ()
		  (set! old-parser-table
			(set-current-parser-table! new-parser-table)))
		thunk
		(lambda ()
		  (set! new-parser-table
			(set-current-parser-table! old-parser-table)))))

(define (copy-parser-table table)
  (cons (cons (vector-copy (caar table))
	      (vector-copy (cdar table)))
	(cons (vector-copy (cadr table))
	      (vector-copy (cddr table)))))

(define parser-table-entry)
(define set-parser-table-entry!)
(let ()

(define (decode-parser-character table character receiver)
  (cond ((character? character)
	 (receiver (car table) character))
	((string? character)
	 (cond ((= (string-size character) 1)
		(receiver (car table) (string-ref character 0)))
	       ((conjunction (= (string-size character) 2)
			     (character-equal? (string-ref character 0) #/#))
		(receiver (cdr table) (string-ref character 1)))
	       (else
		(error "Bad character" 'DECODE-PARSER-CHARACTER character))))
	(else
	 (error "Bad character" 'DECODE-PARSER-CHARACTER character))))

(define (ptable-ref table index)
  (cons (vector-ref (car table) index)
	(vector-ref (cdr table) index)))

(define (ptable-set! table index value)
  (vector-set! (car table) index (car value))
  (vector-set! (cdr table) index (cdr value)))

(set! parser-table-entry
      (named-lambda (parser-table-entry table character)
	(decode-parser-character table character ptable-ref)))

(set! set-parser-table-entry!
      (named-lambda (set-parser-table-entry! table character entry)
	(decode-parser-character table character
	  (lambda (sub-table index)
	    (ptable-set! sub-table index entry)))))

)