home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / partab.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  108 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: partab.scm,v 14.5 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1988-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Parser Tables
  23. ;;; package: (runtime parser-table)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define-structure (parser-table (constructor %make-parser-table)
  28.                 (conc-name parser-table/))
  29.   (parse-object false read-only true)
  30.   (collect-list false read-only true)
  31.   (parse-object-special false read-only true)
  32.   (collect-list-special false read-only true))
  33.  
  34. (define-integrable (guarantee-parser-table table procedure)
  35.   (if (not (parser-table? table))
  36.       (error:wrong-type-argument table "parser table" procedure))
  37.   table)
  38.  
  39. (define (make-parser-table parse-object
  40.                collect-list
  41.                parse-object-special
  42.                collect-list-special)
  43.   (%make-parser-table (make-vector 256 parse-object)
  44.               (make-vector 256 collect-list)
  45.               (make-vector 256 parse-object-special)
  46.               (make-vector 256 collect-list-special)))
  47.  
  48. (define (parser-table/copy table)
  49.   (%make-parser-table (vector-copy (parser-table/parse-object table))
  50.               (vector-copy (parser-table/collect-list table))
  51.               (vector-copy (parser-table/parse-object-special table))
  52.               (vector-copy (parser-table/collect-list-special table))))
  53.  
  54. (define-integrable (current-parser-table)
  55.   *current-parser-table*)
  56.  
  57. (define (set-current-parser-table! table)
  58.   (guarantee-parser-table table 'SET-CURRENT-PARSER-TABLE!)
  59.   (set! *current-parser-table* table))
  60.  
  61. (define (with-current-parser-table table thunk)
  62.   (guarantee-parser-table table 'WITH-CURRENT-PARSER-TABLE)
  63.   (fluid-let ((*current-parser-table* table))
  64.     (thunk)))
  65.  
  66. (define *current-parser-table*)
  67.  
  68. (define (parser-table/entry table char receiver)
  69.   (decode-parser-char table char
  70.     (lambda (index parse-object-table collect-list-table)
  71.       (receiver (vector-ref parse-object-table index)
  72.         (vector-ref collect-list-table index)))))
  73.  
  74. (define (parser-table/set-entry! table char
  75.                  parse-object #!optional collect-list)
  76.   (let ((kernel
  77.      (let ((collect-list
  78.         (if (default-object? collect-list)
  79.             (collect-list-wrapper parse-object)
  80.             collect-list)))
  81.        (lambda (char)
  82.          (decode-parser-char table char
  83.            (lambda (index parse-object-table collect-list-table)
  84.          (vector-set! parse-object-table index parse-object)
  85.          (vector-set! collect-list-table index collect-list)))))))
  86.     (cond ((char-set? char) (for-each kernel (char-set-members char)))
  87.       ((pair? char) (for-each kernel char))
  88.       (else (kernel char)))))
  89.  
  90. (define (decode-parser-char table char receiver)
  91.   (cond ((char? char)
  92.      (receiver (char->ascii char)
  93.            (parser-table/parse-object table)
  94.            (parser-table/collect-list table)))
  95.     ((string? char)
  96.      (cond ((= (string-length char) 1)
  97.         (receiver (char->ascii (string-ref char 0))
  98.               (parser-table/parse-object table)
  99.               (parser-table/collect-list table)))
  100.            ((and (= (string-length char) 2)
  101.              (char=? #\# (string-ref char 0)))
  102.         (receiver (char->ascii (string-ref char 1))
  103.               (parser-table/parse-object-special table)
  104.               (parser-table/collect-list-special table)))
  105.            (else
  106.         (error "Bad character" char))))
  107.     (else
  108.      (error "Bad character" char))))