home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / PRATT.SCM < prev    next >
Text File  |  1992-06-17  |  9KB  |  294 lines
  1. ; -*- Mode: Scheme; -*-
  2. ;
  3. ; A simple Pratt-Parser for SIOD: 2-FEB-90, George Carrette, GJC@PARADIGM.COM
  4. ; Siod version 2.4 may be obtained by anonymous FTP to BU.EDU (128.197.2.6)
  5. ; Get the file users/gjc/siod-v2.4-shar
  6. ;
  7. ;                   COPYRIGHT (c) 1990 BY                       
  8. ;     PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.
  9. ;         See the source file SLIB.C for more information. 
  10. ;
  11. ; Based on a theory of parsing presented in:                       
  12. ;                                                                      
  13. ;  Pratt, Vaughan R., ``Top Down Operator Precedence,''         
  14. ;  ACM Symposium on Principles of Programming Languages         
  15. ;  Boston, MA; October, 1973.                                   
  16. ;                                                                      
  17.  
  18. ; The following terms may be useful in deciphering this code:
  19.  
  20. ; NUD -- NUll left Denotation (op has nothing to its left (prefix))
  21. ; LED -- LEft Denotation      (op has something to left (postfix or infix))
  22.  
  23. ; LBP -- Left Binding Power  (the stickiness to the left)
  24. ; RBP -- Right Binding Power (the stickiness to the right)
  25. ;
  26.  
  27. ; Mods for Scheme48 by J Rees 6-14-90
  28.  
  29. ; From: <gjc@mitech.com>
  30. ;
  31. ; Now a neat thing that CGOL had was a way of packaging and scoping
  32. ; different parsing contexts. The maclisp implementation was simple,
  33. ; instead of just NUD and LED and other properties there was a list
  34. ; of property indicators. And a lookup operation.
  35. ;
  36. ; One use of the local-context thing, in parsing the C language
  37. ; you can use a different binding-power for ":" depending on
  38. ; what kind of statement you are parsing, a general statement
  39. ; context where ":" means a label, a "switch" or the "if for value
  40. ; " construct of (a > b) > c : d;
  41.  
  42.  
  43. (define (peek-token stream)
  44.   (stream 'peek #f))
  45.  
  46. (define (read-token stream)
  47.   (stream 'get #f))
  48.    
  49. (define (toplevel-parse stream)
  50.   (if (eq? end-of-input-operator (peek-token stream))
  51.       (read-token stream)
  52.       (parse -1 stream)))
  53.  
  54.  
  55. ; A token is either an operator or atomic (number, identifier, etc.)
  56.  
  57. (define operator-type
  58.   (make-record-type 'operator
  59.             '(name lbp rbp nud led)))
  60.  
  61. (define make-operator
  62.   (let ()
  63.     (define make
  64.       (record-constructor operator-type '(name lbp rbp nud led)))
  65.     (define (make-operator name lbp rbp nud led)
  66.       (make name
  67.         (or lbp default-lbp)
  68.         (or rbp default-rbp)
  69.         (or nud default-nud)
  70.         (or led default-led)))
  71.     make-operator))
  72.  
  73. (define operator? (record-predicate operator-type))
  74.  
  75. (define operator-name (record-accessor operator-type 'name))
  76. (define operator-nud (record-accessor operator-type 'nud))
  77. (define operator-led (record-accessor operator-type 'led))
  78. (define operator-lbp (record-accessor operator-type 'lbp))
  79. (define operator-rbp (record-accessor operator-type 'rbp))
  80.  
  81. (define (default-nud operator stream)
  82.   (if (eq? (operator-led operator) default-led)
  83.       operator
  84.       (error 'not-a-prefix-operator operator)))
  85.  
  86. (define (nudcall token stream)
  87.   (if (operator? token)
  88.       ((operator-nud token) token stream)
  89.       token))
  90.  
  91. (define default-led #f)
  92.  
  93. ;+++ To do: fix this to make juxtaposition work   (f x+y)
  94.  
  95. (define (ledcall token left stream)
  96.   ((or (and (operator? token)
  97.         (operator-led token))
  98.        (error 'not-an-infix-operator token))
  99.    token
  100.    left
  101.    stream))
  102.  
  103. (define default-lbp 200)
  104.  
  105. (define (lbp token)
  106.   (if (operator? token)
  107.       (operator-lbp token)
  108.       default-lbp))
  109.  
  110. (define default-rbp 200)
  111.  
  112. (define (rbp token)
  113.   (if (operator? token)
  114.       (operator-rbp token)
  115.       default-rbp))
  116.  
  117. (define-record-discloser operator-type
  118.   (lambda (obj)
  119.     (list 'operator (operator-name obj))))
  120.  
  121. ; Mumble
  122.  
  123. (define (delim-error token stream)
  124.   (error 'invalid-use-of-delimiter token))
  125.  
  126. (define (erb-error token left stream)
  127.   (error 'too-many-right-parentheses token))
  128.  
  129. (define (premterm-err token stream)
  130.   (error 'premature-termination-of-input token))
  131.  
  132. ; Parse
  133.  
  134. (define *parse-debug* #f)
  135.  
  136. (define (parse rbp-level stream)
  137.   (if *parse-debug* (print `(parse ,rbp-level)))
  138.   (let parse-loop ((translation (nudcall (read-token stream) stream)))
  139.     (if (< rbp-level (lbp (peek-token stream)))
  140.     (parse-loop (ledcall (read-token stream) translation stream))
  141.       (begin (if *parse-debug* (print translation))
  142.          translation))))
  143.  
  144. (define (print s) (write s) (newline))
  145.  
  146. (define (parse-prefix operator stream)
  147.   (list (operator-name operator)
  148.     (parse (rbp operator) stream)))
  149.  
  150. (define (parse-infix operator left stream)
  151.   (list (operator-name operator)
  152.     left
  153.     (parse (rbp operator) stream)))
  154.  
  155. (define (parse-nary operator left stream)
  156.   (cons (operator-name operator) (cons left (prsnary operator stream))))
  157.  
  158. (define (prsnary operator stream)
  159.   (define (loop l)
  160.     (if (eq? operator (peek-token stream))
  161.     (begin (read-token stream)
  162.            (loop (cons (parse (rbp operator) stream) l)))
  163.       (reverse l)))
  164.   (loop (list (parse (rbp operator) stream))))
  165.  
  166. ; Parenthesis matching, with internal commas.
  167. ; Kind of a kludge if you ask me.
  168.  
  169. (define (parse-matchfix operator stream) ; |x|
  170.   (cons (operator-name operator)
  171.     (prsmatch operator stream)))
  172.  
  173. (define (prsmatch close-op stream)
  174.   (if (eq? (peek-token stream) close-op)
  175.       (begin (read-token stream)
  176.          '())
  177.       (let loop ((l (list (parse 10 stream))))
  178.     (if (eq? (peek-token stream) close-op)
  179.         (begin (read-token stream)
  180.            (reverse l))
  181.         (if (eq? (peek-token stream) comma-operator)
  182.         (begin (read-token stream)
  183.                (loop (cons (parse 10 stream) l)))
  184.         (error 'comma-or-match-not-found (read-token stream)))))))
  185.  
  186. (define comma-operator (make-operator 'comma 10 #f delim-error #f))
  187.  
  188. ; if A then B [else C]
  189.  
  190. (define (if-nud token stream)
  191.   (let* ((pred (parse (rbp token) stream))
  192.      (then (if (eq? (peek-token stream) then-operator)
  193.            (parse (rbp (read-token stream)) stream)
  194.            (error 'missing-then pred))))
  195.     (if (eq? (peek-token stream) else-operator)
  196.     `(if ,pred ,then ,(parse (rbp (read-token stream)) stream))
  197.     `(if ,pred ,then))))
  198.  
  199. (define if-operator (make-operator 'if #f 45 if-nud #f))
  200. (define then-operator (make-operator 'then 5 25 delim-error #f))
  201. (define else-operator (make-operator 'else 5 25 delim-error #f))
  202.  
  203. ; Lexer support:
  204.  
  205. (define lexer-type
  206.   (make-record-type 'lexer '(ttab punctab keytab)))
  207.  
  208. (define lexer-ttab    (record-accessor lexer-type 'ttab))
  209. (define lexer-punctab (record-accessor lexer-type 'punctab))
  210. (define lexer-keytab  (record-accessor lexer-type 'keytab))
  211.  
  212. (define make-lexer-table
  213.   (let ((make (record-constructor lexer-type '(ttab punctab keytab))))
  214.     (lambda ()
  215.       (let ((ttab (make-tokenizer-table)))
  216.     (set-up-usual-tokenization! ttab)
  217.     (make ttab (make-table) (make-table))))))
  218.  
  219. (define (lex ltab port)
  220.   (let ((thing (tokenize (lexer-ttab ltab) port)))
  221.     (cond ((eof-object? thing)
  222.        end-of-input-operator)
  223.       ((symbol? thing)
  224.        (or (table-ref (lexer-keytab ltab) thing)
  225.            thing))
  226.       (else thing))))
  227.  
  228. ; Keywords
  229.  
  230. (define (define-keyword ltab name op)
  231.   (table-set! (lexer-keytab ltab) name op))
  232.  
  233. ; Punctuation
  234.  
  235. ; lexnode = (* operator (table-of char (+ lexnode #f)))  -- discrimination tree
  236.  
  237. (define (define-punctuation ltab string op)
  238.   (let ((end (- (string-length string) 1)))
  239.     (let loop ((i 0)
  240.            (table (lexer-punctab ltab)))
  241.       (let* ((c (string-ref string i))
  242.          (lexnode
  243.           (or (table-ref table c)
  244.           (let ((lexnode
  245.              (cons (error-operator (substring string 0 (+ i 1)))
  246.                    (make-table))))
  247.             (table-set! table c lexnode)
  248.             (if (= i 0)
  249.             (set-char-tokenization! (lexer-ttab ltab)
  250.                         c
  251.                         (operator-reader lexnode)
  252.                         #t))
  253.             lexnode))))
  254.     (if (>= i end)
  255.         (set-car! lexnode op)
  256.         (loop (+ i 1) (cdr lexnode)))))))
  257.  
  258. (define (operator-reader lexnode)
  259.   (lambda (c port)
  260.     (let loop ((lexnode lexnode))
  261.       (let ((nextc (peek-char port)))
  262.     (let ((nextnode (table-ref (cdr lexnode) nextc)))
  263.       (if nextnode
  264.           (begin (read-char port)
  265.              (loop nextnode))
  266.           (car lexnode)))))))
  267.  
  268. (define (error-operator string)
  269.   (make-operator 'invalid-operator #f #f
  270.          (lambda rest (error "invalid operator" string))
  271.          #f))
  272.  
  273. ; Mumble
  274.  
  275. (define end-of-input-operator
  276.   (make-operator "end of input" -1 #f premterm-err #f))
  277.  
  278. (define (port->stream port ltab)
  279.   (define (really-get)
  280.     (lex ltab port))
  281.   (define peeked? #f)
  282.   (define peek #f)
  283.   (define (stream op arg)
  284.     (case op
  285.       ((get) (if peeked?
  286.          (begin (set! peeked? #f) peek)
  287.          (really-get)))
  288.       ((peek) (if peeked?
  289.           peek
  290.           (begin (set! peeked? #t)
  291.              (set! peek (really-get))
  292.              peek)))))
  293.   stream)
  294.