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 / SGOL.SCM < prev    next >
Text File  |  1992-06-17  |  5KB  |  205 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. ; Lexer for Infix Scheme (JAR's obscure syntax)
  5. ; Bears no relation to Pratt's CGOL
  6.  
  7. ; To do: add ML-ish binding constructs.
  8.  
  9. ;  (sgol-read)  reads an expression
  10. ;
  11. ;  semicolon    terminates input
  12. ;  comment character is # (comment goes to end of line)
  13. ;
  14. ;  f(x, y)  reads as  (f x y)
  15. ;
  16. ;  if x then y else z      reads as  (if x y z)
  17. ;  x and y, x or y, not x  do the obvious thing
  18. ;
  19. ;  x + y    reads as  (+ x y)     - similarly for - * / = < > <= >=
  20. ;
  21. ;  x::y     reads as  (cons x y)     - ML's syntax
  22. ;  x++y     reads as  (append x y)   - whose syntax?  Haskell's?
  23. ;  []            reads as  '()
  24. ;  [a, b, ...]   reads as  (list a b ...)
  25. ;
  26. ;  ()            reads as  the-unit
  27. ;  (x, y, ...)   reads as  (tuple x y ...)
  28. ;
  29. ;  a[i]         reads as  (vector-ref a i)
  30. ;  a[i, j, ...]  reads as  (array-ref a i j ...)
  31. ;
  32. ;  x := y       reads as  (set! x y)
  33. ;  car(x) := y  reads as  (set-car! x y)       - similarly for cdr
  34. ;  x[y] := z    reads as  (vector-set! x y z)  - similarly for array-ref
  35. ;
  36. ;  'foo'   tries to read as 'foo  but usually loses
  37.  
  38.  
  39. (define sgol-lexer-table (make-lexer-table))
  40.  
  41. (set-char-tokenization! (lexer-ttab sgol-lexer-table)
  42.             #\#
  43.             (lambda (c port)
  44.               c        ;ignored
  45.               (gobble-line port)
  46.               (read port))
  47.             #t)
  48.  
  49. (define (gobble-line port)
  50.   (let loop ()
  51.     (let ((c (read-char port)))
  52.       (cond ((eof-object? c) c)
  53.         ((char=? c #\newline) #f)
  54.         (else (loop))))))
  55.  
  56. ;
  57.  
  58. (define (define-sgol-keyword name op)
  59.   (define-keyword sgol-lexer-table name op))
  60.  
  61. (define (define-sgol-punctuation string op)
  62.   (define-punctuation sgol-lexer-table string op))
  63.  
  64. ; Arguments to make-operator are: name lbp rbp nud led
  65.  
  66. (define (open-paren-nud token stream)
  67.   (let ((right (prsmatch close-paren-operator stream)))
  68.     (if (null? right)
  69.     'the-unit            ; ()
  70.     (if (null? (cdr right))
  71.         (car right)            ; (x)
  72.         (cons 'tuple right)))))    ; (x, y, ..., z)
  73.  
  74. ; f(x, y) reads as (f x y)
  75. ; f((x, y)) reads as (f (tuple x y))
  76.  
  77. (define (open-paren-led token left stream)
  78.   (cons left (prsmatch close-paren-operator stream)))
  79.  
  80. (define-sgol-punctuation "("
  81.   (make-operator 'open-paren 200 #f open-paren-nud open-paren-led))
  82.  
  83. (define-sgol-punctuation "," comma-operator)
  84.  
  85. (define close-paren-operator
  86.   (make-operator 'close-paren 5 #f delim-error erb-error))
  87. (define-sgol-punctuation ")" close-paren-operator)
  88.  
  89. ; Boolean operators
  90.  
  91. (define-sgol-keyword 'true '#t)
  92. (define-sgol-keyword 'false '#f)
  93.  
  94. (define-sgol-keyword 'if if-operator)
  95. (define-sgol-keyword 'then then-operator)
  96. (define-sgol-keyword 'else else-operator)
  97.  
  98. (define-sgol-keyword 'not (make-operator 'not 70 70 parse-prefix #f))
  99. (define-sgol-keyword 'and (make-operator 'and 65 #f #f parse-nary))
  100. (define-sgol-keyword 'or  (make-operator 'or  60 #f #f parse-nary))
  101.  
  102. ; Lists
  103.  
  104. (define (open-bracket-nud token stream)
  105.   (let ((elements (prsmatch close-bracket-operator stream)))
  106.     (if (null? elements)
  107.     `'()
  108.     `(list ,@elements))))
  109.  
  110. (define (open-bracket-led token left stream)
  111.   (let ((subscripts (prsmatch close-bracket-operator stream)))
  112.     (if (and (not (null? subscripts))
  113.          (null? (cdr subscripts)))
  114.     `(vector-ref ,left ,@subscripts)
  115.     `(array-ref ,left ,@subscripts))))
  116.  
  117. (define-sgol-punctuation "["
  118.   (make-operator 'open-bracket 200 #f open-bracket-nud open-bracket-led))
  119.  
  120. (define close-bracket-operator
  121.   (make-operator 'close-bracket 5 #f delim-error erb-error))
  122. (define-sgol-punctuation "]" close-bracket-operator)
  123.  
  124. (define-sgol-punctuation "::"
  125.   (make-operator 'cons 75 74 #f parse-infix))
  126.  
  127. (define-sgol-punctuation "++"
  128.   (make-operator 'append 75 74 #f parse-nary))
  129.  
  130. ; Quotation
  131.  
  132. (define-sgol-punctuation "'"
  133.   (make-operator 'quote 5 #f parse-matchfix #f)) ;This isn't right
  134.  
  135. ; Arithmetic
  136.  
  137. (define-sgol-punctuation "+"
  138.   (make-operator '+ 100 100 parse-prefix parse-infix))
  139.  
  140. (define-sgol-punctuation "-"
  141.   (make-operator '- 100 100 parse-prefix parse-infix))
  142.  
  143. (define-sgol-punctuation "*"
  144.   (make-operator '* 120 120 #f parse-infix))  ;should be parse-nary
  145.  
  146. (define-sgol-punctuation "/"
  147.   (make-operator '/ 120 120 #f parse-infix))
  148.  
  149. (define-sgol-punctuation "="
  150.   (make-operator '= 80 80 #f parse-infix))
  151.  
  152. (define-sgol-punctuation ">"
  153.   (make-operator '> 80 80 #f parse-infix))
  154.  
  155. (define-sgol-punctuation "<"
  156.   (make-operator '< 80 80 #f parse-infix))
  157.  
  158. (define-sgol-punctuation ">="
  159.   (make-operator '>= 80 80 #f parse-infix))
  160.  
  161. (define-sgol-punctuation "<="
  162.   (make-operator '<= 80 80 #f parse-infix))
  163.  
  164. (define-sgol-punctuation "!="
  165.   (make-operator '!= 80 80 #f parse-infix))
  166.  
  167. ; Side effects
  168.  
  169. (define (:=-led token left stream)
  170.   (let* ((form (parse-infix token left stream))
  171.      (lhs (cadr form))
  172.      (rhs (caddr form)))
  173.     (if (pair? lhs)
  174.     (case (car lhs)
  175.       ((car) `(set-car! ,@(cdr lhs) ,rhs))
  176.       ((cdr) `(set-cdr! ,@(cdr lhs) ,rhs))
  177.       ((vector-ref) `(vector-set! ,@(cdr lhs) ,rhs))
  178.       ((array-ref) `(array-set! ,@(cdr lhs) ,rhs))
  179.       (else (error "invalid LHS for :=" form)))
  180.     form)))
  181.  
  182. (define-sgol-punctuation ":="
  183.   (make-operator 'set! 70 #f #f :=-led))
  184.  
  185. ; End of input...
  186.  
  187. (define-sgol-punctuation ";" end-of-input-operator)
  188.  
  189. ; Read using Pratt parser with SGOL tokenizer table
  190.  
  191. (define (sgol-read . port-option)
  192.   (toplevel-parse (port->stream (if (null? port-option)
  193.                     (current-input-port)
  194.                     (car port-option))
  195.                 sgol-lexer-table)))
  196.  
  197. ; Read/print loop
  198.  
  199. (define (rpl)
  200.   (let ((thing (sgol-read)))
  201.     (if (not (eq? thing end-of-input-operator))
  202.     (begin (write thing)
  203.            (newline)
  204.            (rpl)))))
  205.