home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / lexer.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  16.8 KB  |  656 lines  |  [TEXT/CCL2]
  1. ;;; File: parser/lexer    Author: John
  2.  
  3. ;;; token data structure: a list with the token type in the
  4. ;;; car and other information in the rest of the list.  Symbols
  5. ;;; designate the token type.
  6.  
  7. ;;; Reserved tokens use the name as the type and have no args.
  8. ;;; Reserved tokens:
  9. ;;;  case class data default deriving else hiding if import in infix
  10. ;;;  infixl infixr instance interface let module of renaming then to
  11. ;;;  type where .. :: => = @ \ | ~ <- -> `
  12. ;;; Other tokens:
  13. ;;;  (file string)
  14. ;;;  (newline line indent-column)
  15. ;;;  (conid string)
  16. ;;;  (varid string)
  17. ;;;  (consym string)
  18. ;;;  (varsym string)
  19. ;;;  (comment string) ;;; not used at the moment
  20. ;;;  (integer integer)
  21. ;;;  (float integer fraction exponent) 
  22. ;;;  (string string)
  23. ;;;  (eof)
  24.  
  25.  
  26. ;;; *** All of the stuff for lexing character and string literals is
  27. ;;; *** broken because it assumes that the host Lisp uses the ASCII
  28. ;;; *** encoding for characters and supports at least 255 characters.
  29. ;;; *** I have marked the specific places in the code where these
  30. ;;; *** assumptions are made, but fixing the problem will probably
  31. ;;; *** require more drastic changes anyway -- such as using integers
  32. ;;; *** instead of characters and vectors of integers instead of characters
  33. ;;; *** throughout the compiler.
  34.  
  35. (define *max-char* 255)  ; highest char-code allowed.
  36.  
  37. ;;; This defines the long names of the control chars.  Note that some of
  38. ;;; this duplicates the table above & the reader.
  39.  
  40. (define *control-char-names* '(
  41.   ("NUL" . 0) ("SOH" . 1) ("STX" . 2) ("ETX" . 3)
  42.   ("EOT" . 4) ("ENQ" . 5) ("ACK" . 6) ("BEL" . 7)
  43.   ("BS" . 8) ("HT" . 9) ("LF" . 10) ("VT" . 11)
  44.   ("FF" . 12) ("CR" . 13) ("SO" . 14) ("SI" . 15)
  45.   ("DLE" . 16) ("DC1" . 17) ("DC2" . 18) ("DC3" . 19)
  46.   ("DC4" . 20) ("NAK" . 21) ("SYN" . 22) ("ETB" . 23)
  47.   ("CAN" . 24) ("EM" . 25) ("SUB" . 26) ("ESC" . 27)
  48.   ("FS" . 28) ("GS" . 29) ("RS" . 30) ("US" . 31)
  49.   ("SP" . 32) ("DEL" . 127)))
  50.  
  51. ;;; This defines the short names for a few control chars.  This
  52. ;;; is keyed off the previous table
  53.  
  54. (define *short-control-char-names* '(
  55.    (#\a . "BEL")    (#\b . "BS")    (#\f . "FF")    (#\n . "LF")
  56.    (#\r . "CR") (#\t . "HT") (#\v . "VT")))
  57.  
  58. ;;; This is used in the ^X construct.  Assume that ^X = code for ^A + X-A
  59. ;;; *** This is an invalid assumption.
  60.  
  61. (define *control-A* 1)
  62.  
  63. ;;; This function is the interface between the lexer and the rest
  64. ;;; of the system.  Note that the `file' reported in error messages
  65. ;;; must be bound in an outer context.
  66.  
  67.  
  68. ;;; *** I think this function should be binding these variables and not
  69. ;;; *** just assigning them.
  70.  
  71. (define (lex-port port literate?)
  72.   (lex-port-1 port literate? '#t))
  73.  
  74. (define (lex-port/nolines port)
  75.   (lex-port-1 port '#f '#f))
  76.  
  77. (define (lex-port-1 port literate? has-lines?)
  78.   (setf *lex-literate?* literate?)
  79.   (setf *current-line* (if has-lines? 1 -1000))
  80.   (setf *current-col* 0)
  81.   (setf *on-new-line?* '#t)
  82.   (setf *save-col?* '#f)
  83.   (setf *port* port)
  84.   (setf *tokens* '())
  85.   (setf *char* (read-char *port*))
  86.   (setf *peek-char* (read-char *port*))
  87.   (when (eof-object? *char*)
  88.     (setf *char* '#\space))
  89.   (when (eof-object? *peek-char*)
  90.     (setf *peek-char* '#\space))
  91.   (setf *at-eof/p?* '#f)
  92.   (setf *at-eof?* '#f)
  93.   (when *lex-literate?*
  94.      (process-literate-comments '#t))
  95.   (parse-till-eof)
  96.   (nreverse *tokens*))
  97.  
  98. (define (parse-till-eof)
  99.   (cond (*at-eof?*
  100.      (emit-token 'eof)
  101.      '())
  102.     (else
  103.      (lex-one-token)
  104.      (parse-till-eof))))
  105.  
  106. ;;; There is an assumption that the scanner never peeks beyond a newline.
  107. ;;; In literate mode, this may reveal the wrong thing.
  108.  
  109. (define (advance-char)
  110.   (if (and *lex-literate?* (eqv? *char* #\newline))
  111.       (process-literate-comments '#f)
  112.       (advance-char-1)))
  113.  
  114. (define (advance-char-1)
  115.   (cond ((eqv? *char* #\newline)
  116.      (setf *on-new-line?* '#t)
  117.      (incf (the fixnum *current-line*))
  118.      (setf *current-col* 0))
  119.     ((eqv? *char* #\tab)
  120.      (incf (the fixnum *current-col*) (- 8 (modulo *current-col* 8))))
  121.     (else
  122.      (incf (the fixnum *current-col*))))
  123.   (setf *char* *peek-char*)
  124.   (setf *at-eof?* *at-eof/p?*)
  125.   (setf *peek-char* (read-char *port*))
  126.   (when (eof-object? *peek-char*)
  127.      (setf *at-eof/p?* '#t)
  128.      (setf *peek-char* '#\space))
  129.   *char*)
  130.  
  131. (define (peek-char-2)
  132.   (let ((ch (peek-char *port*)))
  133.     (if (eof-object? ch)
  134.     '#\space
  135.     ch)))
  136.  
  137. (define (lex-one-token)
  138.  (setf *start-line* *current-line*) ; capture the loc at the start of the token
  139.  (setf *start-col* *current-col*)
  140.  (unless *at-eof?*
  141.   (char-case *char*
  142.     (whitechar
  143.      (advance-char)
  144.      (lex-one-token))
  145.     (#\- (char-case *peek-char*
  146.         (#\- (lex-comment))
  147.         (#\} (signal-missing-begin-comment)
  148.          (advance-char)
  149.          (advance-char)
  150.          (lex-one-token))
  151.         (else
  152.          (lex-varsym))))
  153.     (#\{ (cond ((char=? *peek-char* '#\-)
  154.         (advance-char)
  155.         (advance-char)
  156.         (cond ((char=? *char* '#\#)
  157.                (advance-char)
  158.                (emit-token 'begin-annotation))
  159.               (else
  160.                (lex-ncomment)
  161.                (lex-one-token))))
  162.            (else
  163.         (advance-char)
  164.         (emit-token '\{ ))))
  165.     (small (lex-varid))
  166.     (large (lex-conid))
  167.     (#\( (advance-char)
  168.      (emit-token '\())
  169.     (#\: (lex-consym))
  170.     (#\` (advance-char)
  171.      (emit-token '\`))
  172.     ((symbol presymbol) (lex-varsym))
  173.     (digit (lex-numeric))
  174.     (#\' (lex-char))
  175.     (#\" (lex-string))
  176.     (#\) (advance-char)
  177.      (emit-token '\)))
  178.     (#\, (advance-char)
  179.      (emit-token '\,))
  180.     (#\; (advance-char)
  181.      (emit-token '\;))
  182.     (#\[ (advance-char)
  183.      (emit-token '\[))
  184.     (#\] (advance-char)
  185.      (emit-token '\]))
  186.     (#\_ (advance-char)
  187.      (emit-token '\_))
  188.     (#\} (advance-char)
  189.      (emit-token '\}))
  190.     (else
  191.      (signal-invalid-character *char*)
  192.      (advance-char)
  193.      (lex-one-token)))))
  194.  
  195. (define (signal-missing-begin-comment)
  196.   (lexer-error 'missing-begin-comment
  197.            "`-}' appears outside of a nested comment."))
  198.  
  199. (define (signal-invalid-character ch)
  200.   (lexer-error 'invalid-character 
  201.            "Invalid character `~a' appears in source program." ch))
  202.  
  203. (define (advance-past-white)
  204.   (unless *at-eof?*
  205.     (char-case *char*
  206.       (whitechar
  207.         (advance-char)
  208.     (advance-past-white))
  209.       (else
  210.        '()))))
  211.  
  212. (define (process-literate-comments at-start?)
  213.   (unless at-start? (advance-char-1))
  214.   (let ((l (classify-line)))
  215.     (cond ((or *at-eof?* (eq? l 'program))
  216.        '())
  217.       ((eq? l 'blank)
  218.        (skip-literate-comment '#t))
  219.       (else
  220.        (when (not at-start?)
  221.          (lexer-error 'blank-line-needed
  222.             "Literate comments must be preceeded by a blank line"))
  223.        (skip-literate-comment '#f)))))
  224.  
  225. (define (skip-literate-comment prev-blank)
  226.   (skip-past-line)
  227.   (let ((l (classify-line)))
  228.     (cond (*at-eof?*
  229.        '())
  230.       ((eq? l 'comment)
  231.        (skip-literate-comment '#f))
  232.       ((eq? l 'blank)
  233.        (skip-literate-comment '#t))
  234.       (else
  235.        (when (not prev-blank)
  236.          (lexer-error 'blank-line-needed
  237.           "Literate comments must be followed by a blank line"))))))
  238.   
  239. (define (classify-line)
  240.   (if *at-eof?*
  241.       'blank
  242.       (char-case *char*
  243.        (#\>
  244.     (advance-char-1)
  245.     'program)
  246.        (#\newline 'blank)
  247.        (whitechar
  248.     (classify-line-1))
  249.        (else 'comment))))
  250.  
  251. (define (classify-line-1)
  252.   (advance-char-1)
  253.   (char-case *char*
  254.     (#\newline 'blank)
  255.     (whitechar (classify-line-1))
  256.     (else 'comment)))
  257.  
  258. (define (skip-past-line)
  259.   (when (not *at-eof?*)
  260.     (char-case *char*
  261.       (#\newline
  262.        (advance-char-1))
  263.       (else
  264.        (advance-char-1)
  265.        (skip-past-line)))))
  266.       
  267. (define (lex-comment)  ;; a -- style comment
  268.   (advance-char)
  269.   (cond (*at-eof?* (lexer-eof-in-comment *current-line*))
  270.     ((char=? *char* #\newline)
  271.      (lex-one-token))
  272.     (else
  273.      (lex-comment))))
  274.  
  275. (define (lexer-eof-in-comment start-line)
  276.   (signal-eof-in-comment start-line)
  277.   (lex-one-token))  ; will return the eof token
  278.  
  279. (define (signal-eof-in-comment start-line)
  280.   (lexer-error 'eof-in-comment
  281.            "End of file in comment starting at line ~A." start-line))
  282.  
  283. ;;; Here *char* and *peek-char* are the first two chars on a line.
  284.  
  285. (define (scan-symbol)
  286.   (scan-list-of (symbol #\:)))
  287.  
  288. (define (scan-var-con)
  289.   (scan-list-of (large small digit #\' #\_)))
  290.  
  291. (define (lex-ncomment)
  292.   (lex-ncomment-1 *current-line*))
  293.  
  294. (define (lex-ncomment-1 start-line)
  295.  (if *at-eof?*
  296.   (lexer-eof-in-comment start-line)
  297.   (char-case *char*
  298.     (#\- (cond ((char=? *peek-char* #\})
  299.         (advance-char)
  300.         (advance-char))
  301.            (else
  302.         (advance-char)
  303.         (lex-ncomment-1 start-line))))
  304.     (#\{ (cond ((char=? *peek-char* #\-)
  305.         (advance-char)
  306.         (advance-char)
  307.         (lex-ncomment)
  308.         (lex-ncomment-1 start-line))
  309.            (else
  310.         (advance-char)
  311.         (lex-ncomment-1 start-line))))
  312.     (else
  313.      (advance-char)
  314.      (lex-ncomment-1 start-line)))))
  315.  
  316. (define (lex-varid)
  317.   (let ((sym (scan-var-con)))
  318.     (parse-reserved sym varid
  319.        "case" "class"
  320.        "data" "default" "deriving"
  321.        "else"
  322.        "hiding"
  323.        "if" "import" "in" "infix" "infixl" "infixr" "instance" "interface"
  324.        "let"
  325.        "module"
  326.        "of"
  327.        "renaming"
  328.        "then" "to" "type"
  329.        "where")))
  330.  
  331. (define (lex-conid)
  332.   (let ((sym (scan-var-con)))
  333.     (emit-token/string 'conid sym)))
  334.  
  335. (define (lex-consym)
  336.   (let ((sym (scan-symbol)))
  337.     (cond ((string=/list? (cdr sym) ":")
  338.        (emit-token '\:\:))
  339.       (else
  340.        (emit-token/string 'consym sym)))))
  341.  
  342. (define (lex-varsym)
  343.   (let ((sym (scan-symbol)))
  344.     (cond ((and (string=/list? sym "<") (char=? *char* #\-))
  345.        (advance-char)
  346.        (emit-token '\<\-))
  347.       ((and (string=/list? sym "#")
  348.         (char=? *char* #\-)
  349.         (char=? *peek-char* #\}))
  350.        (advance-char)
  351.        (advance-char)
  352.        (emit-token 'end-annotation))
  353.       (else
  354.        (parse-reserved sym varsym
  355.           ".."
  356.           "=>" "="
  357.           "->"
  358.           "@"
  359.           "\\"
  360.           "|"
  361.           "~")))))
  362.  
  363. (define (lex-integer radix)
  364.   (lex-integer-1 radix 0))
  365.  
  366. (define (lex-integer-1 radix psum)
  367.   (declare (type fixnum radix)
  368.        (type integer psum))
  369.   (let ((d  (char->digit *char* radix)))
  370.     (if d
  371.     (begin
  372.       (advance-char)
  373.       (lex-integer-1 radix (+ (* psum radix) (the fixnum d))))
  374.     psum)))
  375.  
  376. (define (lex-fraction int-part denominator)
  377.   (declare (type integer int-part denominator))
  378.   (let ((d  (char->digit *char* 10)))
  379.     (if d
  380.     (begin
  381.       (advance-char)
  382.       (lex-fraction
  383.         (+ (* int-part 10) (the fixnum d)) (* denominator 10)))
  384.     (values int-part denominator))))
  385.  
  386. (define (lex-numeric)
  387.   (let ((int-part (lex-integer 10)))
  388.     (if (and (char=? *char* #\.)
  389.          (char->digit *peek-char* 10))
  390.     (lex-float int-part)
  391.     (emit-token 'integer int-part))))
  392.  
  393. (define (lex-float int-part)
  394.   (advance-char)
  395.   (multiple-value-bind (numerator denominator) (lex-fraction int-part 1)
  396.     (let ((no-exponent
  397.        (lambda () (emit-token 'float numerator denominator 0))))
  398.       (char-case *char*
  399.     (exponent
  400.       (char-case *peek-char*
  401.         (digit
  402.          (advance-char)
  403.          (lex-float/exp numerator denominator 1))
  404.         ((#\+ #\-)
  405.          (cond ((char->digit (peek-char-2) 10)
  406.             (let ((sign (if (char=? *peek-char* '#\+) 1 -1)))
  407.               (advance-char)
  408.               (advance-char)
  409.             (lex-float/exp numerator denominator sign)))
  410.          (else
  411.           (funcall no-exponent))))
  412.       (else
  413.        (funcall no-exponent))))
  414.        (else
  415.     (emit-token 'float numerator denominator 0))))))
  416.  
  417. (define (lex-float/exp numerator denominator sign)
  418.   (let ((exponent (lex-integer 10)))
  419.     (emit-token 'float numerator denominator (* sign exponent))))
  420.  
  421. (define (lex-char)
  422.   (advance-char)
  423.   (let ((c
  424.     (char-case *char*
  425.       (#\' (signal-null-character)
  426.        '#\?)
  427.       (#\\ (lex-escaped-char '#f))
  428.       ((#\space graphic)
  429.        (let ((ch *char*))
  430.      (advance-char)
  431.      ch))
  432.       (else
  433.        (signal-bad-character-constant *char*)
  434.        (advance-char)
  435.        `#\?))))
  436.     (cond ((char=? *char* '#\')
  437.        (advance-char)
  438.        (emit-token 'char c))
  439.       (else
  440.        (signal-missing-char-quote)
  441.        (skip-to-quote-or-eol)))))
  442.  
  443. (define (signal-null-character)
  444.   (lexer-error 'null-character
  445.            "Null character '' is illegal - use '\\'' for a quote."))
  446.  
  447. (define (signal-bad-character-constant ch)
  448.   (lexer-error 'bad-character-constant
  449.            "The character `~a' may not appear in a character literal." ch))
  450.  
  451. (define (signal-missing-char-quote)
  452.   (lexer-error 'missing-char-quote
  453.            "Character constant has more than one character."))
  454.   
  455.  
  456. (define (skip-to-quote-or-eol)
  457.   (if *at-eof?*
  458.       (lex-one-token)
  459.       (char-case *char*
  460.      (#\' (advance-char)
  461.           (lex-one-token))
  462.      (#\newline (advance-char)
  463.             (lex-one-token))
  464.      (else
  465.       (advance-char)
  466.       (skip-to-quote-or-eol)))))
  467.  
  468. (define (lex-string)
  469.   (advance-char)
  470.   (emit-token 'string (list->string (gather-string-chars))))
  471.  
  472. (define (gather-string-chars)
  473.   (char-case *char*
  474.     (#\\
  475.       (let ((ch (lex-escaped-char '#t)))
  476.     (if (eq? ch 'null)
  477.         (gather-string-chars)
  478.         (cons ch (gather-string-chars)))))
  479.     (#\"
  480.       (advance-char)
  481.       '())
  482.     ((graphic #\space)
  483.      (let ((ch *char*))
  484.        (advance-char)
  485.        (cons ch (gather-string-chars))))
  486.     (#\newline
  487.      (signal-missing-string-quote)
  488.      '())
  489.     (else
  490.      (signal-bad-string-constant *char*)
  491.      (advance-char)
  492.      (gather-string-chars))))
  493.  
  494. (define (signal-missing-string-quote)
  495.   (lexer-error 'missing-string-quote
  496.            "String continued over end of line."))
  497.  
  498. (define (signal-bad-string-constant ch)
  499.   (lexer-error 'bad-string-constant
  500.            "The character `~a' may not appear in a string literal." ch))
  501.  
  502.  
  503. (define (convert-stupid-control-character-names)
  504.   (let ((c1 *char*)
  505.     (c2 *peek-char*))
  506.     (advance-char)
  507.     (advance-char)
  508.     (let ((s2 (string c1 c2))
  509.       (s3 (string c1 c2 *char*)))
  510.       (let ((srch3 (assoc s3 *control-char-names*)))
  511.     (cond (srch3
  512.            (advance-char)
  513.            (integer->char (cdr srch3)))
  514.           (else
  515.            (let ((srch2 (assoc s2 *control-char-names*)))
  516.          (cond (srch2
  517.             (integer->char (cdr srch2)))
  518.                (else
  519.             (signal-bad-control-char s3)
  520.             `#\?)))))))))
  521.  
  522. (define (signal-bad-control-char name)
  523.   (lexer-error 'invalid-control-char
  524.            "`~a' is not a recognized control character name." name))
  525.  
  526.  
  527. (define (lex-escaped-char in-string?)
  528.   (advance-char)
  529.   (char-case *char*
  530.     ((#\a #\b #\f #\n #\r #\t #\v)
  531.      (let* ((ccode (cdr (assoc *char* *short-control-char-names*)))
  532.         (ccode1 (cdr (assoc ccode *control-char-names*))))
  533.        (advance-char)
  534.        (integer->char ccode1)))
  535.     ((#\\ #\' #\")
  536.      (let ((ch *char*))
  537.        (advance-char)
  538.        ch))
  539.     (#\&
  540.      (advance-char)
  541.      (cond (in-string? 'null)
  542.        (else
  543.         (signal-bad-&-escape)
  544.         '#\?)))
  545.     (#\^
  546.      ;; *** This code is problematic because it assumes
  547.      ;; *** (1) that you can do the arithmetic on the character codes
  548.      ;; *** (2) that the resulting integer can actually be coerced to
  549.      ;; ***     the right character object in the host Lisp.
  550.      (advance-char)
  551.      (char-case *char*
  552.        ((large #\@ #\[ #\\ #\] #\^ #\_)
  553.     (let ((code (+ (- (char->integer *char*)
  554.               (char->integer '#\A))
  555.                *control-A*)))
  556.       (advance-char)
  557.       (integer->char code)))
  558.        (else
  559.     (signal-bad-^-escape *char*)
  560.     '#\?)))
  561.     (large
  562.      (convert-stupid-control-character-names))
  563.     (digit
  564.      (convert-num-to-char (lex-integer 10)))
  565.     (#\o
  566.      (advance-char)
  567.      (cond ((char->digit *char* 8)
  568.         (convert-num-to-char (lex-integer 8)))
  569.        (else
  570.         (signal-missing-octal-digits)
  571.         '#\?)))
  572.     (#\x
  573.      (advance-char)
  574.      (cond ((char->digit *char* 16)
  575.         (convert-num-to-char (lex-integer 16)))
  576.        (else
  577.         (signal-missing-hex-digits)
  578.         `#\?)))
  579.     (whitechar
  580.      (cond (in-string?
  581.         (lex-gap))
  582.        (else
  583.         (signal-bad-gap)
  584.         `#\?)))
  585.     (else
  586.      (signal-bad-escape *char*)
  587.      `#\?)))
  588.  
  589. (define (signal-bad-&-escape)
  590.   (lexer-error 'bad-&-escape
  591.            "The escape `\\&' is not allowed inside a character literal."))
  592.  
  593. (define (signal-bad-^-escape ch)
  594.   (lexer-error 'bad-^-escape
  595.            "The escape `\\^~a' is not recognized." ch))
  596.  
  597. (define (signal-missing-octal-digits)
  598.   (lexer-error 'missing-octal-digits
  599.            "No digits provided for `\\o' escape."))
  600.  
  601. (define (signal-missing-hex-digits)
  602.   (lexer-error 'missing-hex-digits
  603.            "No digits provided for `\\x' escape."))
  604.  
  605. (define (signal-bad-gap)
  606.   (lexer-error 'invalid-gap
  607.            "Gaps are not allowed inside character literals."))
  608.  
  609. (define (signal-bad-escape ch)
  610.   (lexer-error 'bad-escape
  611.            "The escape `\\~a' is not recognized." ch))
  612.  
  613.  
  614.  
  615. ;;; *** This code is problematic because it assumes that integers
  616. ;;; *** between 0 and 255 map on to characters with the corresponding
  617. ;;; *** ASCII encoding in the host Lisp, and that the host Lisp actually
  618. ;;; *** supports 255 characters.
  619.  
  620. (define (convert-num-to-char num)
  621.   (cond ((and (>= num 0) (>= *max-char* num))
  622.      (integer->char num))
  623.     (else
  624.      (signal-char-out-of-range num)
  625.      '#\?)))
  626.  
  627. (define (signal-char-out-of-range num)
  628.   (lexer-error 'char-out-of-range
  629.            "There is no character corresponding to code ~s." num))
  630.  
  631.  
  632. (define (lex-gap)
  633.   (cond (*at-eof?*
  634.      (signal-eof-in-gap)
  635.      'null)
  636.     (else
  637.      (char-case *char*
  638.        (whitechar
  639.         (advance-char)
  640.         (lex-gap))
  641.        (#\\
  642.         (advance-char)
  643.         'null)
  644.        (else
  645.         (signal-missing-gap)
  646.         'null)))))
  647.   
  648.       
  649. (define (signal-eof-in-gap)
  650.   (lexer-error 'eof-in-gap
  651.            "End of file encountered inside gap."))
  652.  
  653. (define (signal-missing-gap)
  654.   (lexer-error 'missing-gap
  655.            "Missing gap delimiter, or junk inside gap."))
  656.