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 / parse.scm < prev    next >
Text File  |  1999-05-14  |  25KB  |  804 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: parse.scm,v 14.33 1999/05/15 02:50: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. ;;;; Scheme Parser
  23. ;;; package: (runtime parser)
  24.  
  25. (declare (usual-integrations))
  26.  
  27. (define (initialize-package!)
  28.   (set! char-set/undefined-atom-delimiters (char-set #\[ #\] #\{ #\} #\|))
  29.   (set! char-set/whitespace
  30.     (char-set #\Tab #\Linefeed #\Page #\Return #\Space))
  31.   (set! char-set/non-whitespace (char-set-invert char-set/whitespace))
  32.   (set! char-set/comment-delimiters (char-set #\Newline))
  33.   (set! char-set/special-comment-leaders (char-set #\# #\|))
  34.   (set! char-set/string-delimiters (char-set #\" #\\))
  35.   (set! char-set/atom-delimiters
  36.     (char-set-union char-set/whitespace
  37.             (char-set-union char-set/undefined-atom-delimiters
  38.                     (char-set #\( #\) #\; #\" #\' #\`))))
  39.   (set! char-set/atom-constituents (char-set-invert char-set/atom-delimiters))
  40.   (set! char-set/char-delimiters
  41.     (char-set-union (char-set #\- #\\) char-set/atom-delimiters))
  42.   (set! char-set/symbol-leaders
  43.     (char-set-difference char-set/atom-constituents
  44.                  (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
  45.                        #\+ #\- #\. #\#)))
  46.   (set! char-set/non-digit
  47.     (char-set-difference (char-set-invert (char-set))
  48.                  char-set:numeric))
  49.  
  50.   (set! lambda-optional-tag (object-new-type (microcode-type 'CONSTANT) 3))
  51.   (set! lambda-rest-tag (object-new-type (microcode-type 'CONSTANT) 4))
  52.   (set! lambda-auxiliary-tag (intern "#!aux"))
  53.   (set! dot-symbol (intern "."))
  54.   (set! named-objects
  55.     `((NULL . ,(list))
  56.       (FALSE . ,false)
  57.       (TRUE . ,true)
  58.       (OPTIONAL . ,lambda-optional-tag)
  59.       (REST . ,lambda-rest-tag)
  60.       (AUX . ',lambda-auxiliary-tag)))
  61.  
  62.   (set! *parser-radix* 10)
  63.   (set! *parser-associate-positions?* false)
  64.   (set! *parser-associate-position* parser-associate-positions/default)
  65.   (set! *parser-current-position* parser-current-position/default)
  66.   (set! *parser-canonicalize-symbols?* #t)
  67.   (set! system-global-parser-table (make-system-global-parser-table))
  68.   (set-current-parser-table! system-global-parser-table))
  69.  
  70. (define char-set/undefined-atom-delimiters)
  71. (define char-set/whitespace)
  72. (define char-set/non-whitespace)
  73. (define char-set/comment-delimiters)
  74. (define char-set/special-comment-leaders)
  75. (define char-set/string-delimiters)
  76. (define char-set/atom-delimiters)
  77. (define char-set/atom-constituents)
  78. (define char-set/char-delimiters)
  79. (define char-set/symbol-leaders)
  80. (define char-set/non-digit)
  81.  
  82. (define lambda-optional-tag)
  83. (define lambda-rest-tag)
  84. (define lambda-auxiliary-tag)
  85. (define *parser-radix*)
  86. (define system-global-parser-table)
  87.  
  88. (define (make-system-global-parser-table)
  89.   (let ((table
  90.      (make-parser-table parse-object/atom
  91.                 (collect-list-wrapper parse-object/atom)
  92.                 parse-object/special-undefined
  93.                 collect-list/special-undefined)))
  94.     (for-each (lambda (entry)
  95.         (apply parser-table/set-entry!
  96.                (cons table entry)))
  97.           `(("#" ,parse-object/special ,collect-list/special)
  98.         (,char-set/symbol-leaders ,parse-object/symbol)
  99.         (("#b" "#B") ,parse-object/numeric-prefix)
  100.         (("#o" "#O") ,parse-object/numeric-prefix)
  101.         (("#d" "#D") ,parse-object/numeric-prefix)
  102.         (("#x" "#X") ,parse-object/numeric-prefix)
  103.         (("#i" "#I") ,parse-object/numeric-prefix)
  104.         (("#e" "#E") ,parse-object/numeric-prefix)
  105.         (("#s" "#S") ,parse-object/numeric-prefix)
  106.         (("#l" "#L") ,parse-object/numeric-prefix)
  107.         ("#*" ,parse-object/bit-string)
  108.         ("(" ,parse-object/list-open)
  109.         ("#(" ,parse-object/vector-open)
  110.         (")" ,parse-object/list-close ,collect-list/list-close)
  111.         (,char-set/whitespace
  112.          ,parse-object/whitespace
  113.          ,collect-list/whitespace)
  114.         (,char-set/undefined-atom-delimiters
  115.          ,parse-object/undefined-atom-delimiter
  116.          ,collect-list/undefined-atom-delimiter)
  117.         (";" ,parse-object/comment ,collect-list/comment)
  118.         ("#|"
  119.          ,parse-object/special-comment
  120.          ,collect-list/special-comment)
  121.         ("'" ,parse-object/quote)
  122.         ("`" ,parse-object/quasiquote)
  123.         ("," ,parse-object/unquote)
  124.         ("\"" ,parse-object/string-quote)
  125.         ("#\\" ,parse-object/char-quote)
  126.         (("#f" "#F") ,parse-object/false)
  127.         (("#t" "#T") ,parse-object/true)
  128.         ("#!" ,parse-object/named-constant)
  129.         (("#0" "#1" "#2" "#3" "#4" "#5" "#6" "#7" "#8" "#9")
  130.          ,parse-object/special-prefix ,collect-list/special-prefix)
  131.         ("#=" ,parse-object/define-shared)
  132.         ("##" ,parse-object/reference-shared)
  133.         ("#[" ,parse-object/unhash-printed-representation)
  134.         ;;("#$" ,test-recursive-read)
  135.         ("#@" ,parse-object/unhash)))
  136.     table))
  137.  
  138. ;;;; Top Level
  139.  
  140. (define (parse-object port parser-table)
  141.   ((parsing-operation port) port parser-table))
  142.  
  143. (define (parse-objects port parser-table last-object?)
  144.   (let ((operation (parsing-operation port)))
  145.     (let loop ()
  146.       (let ((object (operation port parser-table)))
  147.     (if (last-object? object)
  148.         '()
  149.         (cons-stream object (loop)))))))
  150.  
  151. (define (parsing-operation port)
  152.   (or (port/operation port 'READ)
  153.       (let ((read-start (port/operation port 'READ-START))
  154.         (read-finish (port/operation port 'READ-FINISH)))
  155.     (lambda (port parser-table)
  156.       (if read-start (read-start port))
  157.       (let ((object
  158.          (within-parser port parser-table parse-object/dispatch)))
  159.         (if read-finish (read-finish port))
  160.         object)))))
  161.  
  162. (define (within-parser port parser-table thunk)
  163.   (if (not (parser-table? parser-table))
  164.       (error:wrong-type-argument parser-table "parser table" 'WITHIN-PARSER))
  165.   (fluid-let
  166.       ((*parser-input-port* port)
  167.        (*parser-parse-object-table* (parser-table/parse-object parser-table))
  168.        (*parser-collect-list-table* (parser-table/collect-list parser-table))
  169.        (*parser-parse-object-special-table*
  170.     (parser-table/parse-object-special parser-table))
  171.        (*parser-collect-list-special-table*
  172.     (parser-table/collect-list-special parser-table))
  173.        (*parser-current-special-prefix* #f)
  174.        ;; Only create it on first entry:
  175.        (*parser-cyclic-context* (or *parser-cyclic-context* (make-context)))
  176.        (*parser-current-position*
  177.     (if (not *parser-associate-positions?*)
  178.         parser-current-position/default
  179.         (current-position-getter port))))
  180.     (cyclic-parser-post-edit (thunk))
  181. ))
  182.  
  183. ;;;; Character Operations
  184.  
  185. (define *parser-input-port*)
  186.  
  187. (define (peek-char)
  188.   (let ((char (peek-char/eof-ok)))
  189.     (if (eof-object? char)
  190.     (parse-error/end-of-file))
  191.     char))
  192.  
  193. (define (peek-char/eof-ok)
  194.   (let loop ()
  195.     (or (input-port/peek-char *parser-input-port*)
  196.     (loop))))
  197.  
  198. (define (read-char)
  199.   (let ((char (read-char/eof-ok)))
  200.     (if (eof-object? char)
  201.     (parse-error/end-of-file))
  202.     char))
  203.  
  204. (define (read-char/eof-ok)
  205.   (let loop ()
  206.     (or (input-port/read-char *parser-input-port*)
  207.     (loop))))
  208.  
  209. (define-integrable (discard-char)
  210.   (input-port/discard-char *parser-input-port*))
  211.  
  212. (define-integrable (read-string delimiters)
  213.   (input-port/read-string *parser-input-port* delimiters))
  214.  
  215. (define-integrable (discard-chars delimiters)
  216.   (input-port/discard-chars *parser-input-port* delimiters))
  217.  
  218. (define (parse-error/end-of-file)
  219.   (parse-error "end of file"))
  220.  
  221. (define (parse-error message #!optional irritant)
  222.   (let ((message (string-append "PARSE-ERROR: " message)))
  223.     (if (default-object? irritant)
  224.     (error message)
  225.     (error message irritant))))
  226.  
  227. ;;;; Dispatch Points
  228.  
  229. (define *parser-parse-object-table*)
  230. (define *parser-collect-list-table*)
  231. (define *parser-parse-object-special-table*)
  232. (define *parser-collect-list-special-table*)
  233.  
  234. (define *parser-current-special-prefix*)
  235.  
  236. (define-integrable (parse-object/dispatch)
  237.   (let ((char (peek-char/eof-ok)))
  238.     (if (eof-object? char)
  239.     char
  240.     ((vector-ref *parser-parse-object-table*
  241.              (or (char-ascii? char) (parse-error/non-ascii)))))))
  242.  
  243. (define-integrable (collect-list/dispatch)
  244.   ((vector-ref *parser-collect-list-table* (peek-ascii))))
  245.  
  246. (define (parse-object/special)
  247.   (discard-char)
  248.   (set! *parser-current-special-prefix* #f)
  249.   ((vector-ref *parser-parse-object-special-table* (peek-ascii))))
  250.  
  251. (define (collect-list/special)
  252.   (discard-char)
  253.   (set! *parser-current-special-prefix* #f)
  254.   ((vector-ref *parser-collect-list-special-table* (peek-ascii))))
  255.  
  256. (define-integrable (peek-ascii)
  257.   (or (char-ascii? (peek-char))
  258.       (parse-error/non-ascii)))
  259.  
  260. (define (parse-error/non-ascii)
  261.   (parse-error "Non-ASCII character encountered" (read-char)))
  262.  
  263. (define (parse-object/special-undefined)
  264.   (parse-error "No such special reader macro" (peek-char))
  265.   (parse-object/dispatch))
  266.  
  267. (define (collect-list/special-undefined)
  268.   (parse-error "No such special reader macro" (peek-char))
  269.   (collect-list/dispatch))
  270.  
  271. ;;;; Recording the position of objects for the compiler
  272.  
  273. (define *parser-associate-position*)
  274. (define *parser-associate-positions?*)
  275. (define *parser-current-position*)
  276.  
  277. (define-macro (define-accretor param-list-1 param-list-2 . body)
  278.   (let ((real-param-list (if (number? param-list-1)
  279.                  param-list-2
  280.                  param-list-1))
  281.     (real-body (if (number? param-list-1)
  282.                body
  283.                (cons param-list-2 body)))
  284.     (offset (if (number? param-list-1)
  285.             param-list-1
  286.             0)))
  287.     `(define ,real-param-list
  288.        (let ((core (lambda () ,@real-body)))
  289.      (if *parser-associate-positions?*
  290.          (recording-object-position ,offset core)
  291.          (core))))))
  292.  
  293. (define (current-position-getter port)
  294.   (cond ((input-port/operation port 'POSITION)
  295.      => (lambda (operation)
  296.           (lambda (offset)
  297.         (- (operation port) offset))))
  298.     ((input-port/operation port 'CHARS-REMAINING)
  299.      => (lambda (chars-rem)
  300.           (let ((len (input-port/operation port 'LENGTH)))
  301.         (if (not len)
  302.             parser-current-position/default
  303.             (let ((total-length (len port)))
  304.               (lambda (offset)
  305.             (- total-length
  306.                (+ (chars-rem port) offset))))))))
  307.     (else
  308.      parser-current-position/default)))     
  309.  
  310. (define (parser-associate-positions/default object position)
  311.   position                ; fnord
  312.   object)
  313.  
  314. (define (parser-current-position/default offset)
  315.   offset                ; fnord
  316.   false)
  317.  
  318. ;; Do not integrate this!!! -- GJR
  319.  
  320. (define (recording-object-position offset parser)
  321.   (let* ((position (*parser-current-position* offset))
  322.      (object (parser)))
  323.     (*parser-associate-position* object position)
  324.     object))
  325.  
  326. ;;;; Symbols/Numbers
  327.  
  328. (define-accretor (parse-object/atom)
  329.   (build-atom (read-atom)))
  330.  
  331. (define-integrable (read-atom)
  332.   (read-string char-set/atom-delimiters))
  333.  
  334. (define (build-atom string)
  335.   (or (parse-number string)
  336.       (intern-string! string)))
  337.  
  338. (define (parse-number string)
  339.   (let ((radix (if (memv *parser-radix* '(2 8 10 16)) *parser-radix* 10)))
  340.     (if (fix:= radix 10)
  341.     (string->number string 10)
  342.     (or (string->number string radix)
  343.         (begin
  344.           (if (string->number string 10)
  345.           (parse-error
  346.            "Radix-10 number syntax with non-standard radix:"
  347.            string))
  348.           #f)))))
  349.  
  350. (define *parser-canonicalize-symbols?*)
  351.  
  352. (define (intern-string! string)
  353.   ;; Special version of `intern' to reduce consing and increase speed.
  354.   (if *parser-canonicalize-symbols?*
  355.       (substring-downcase! string 0 (string-length string)))
  356.   (string->symbol string))
  357.  
  358. (define-accretor (parse-object/symbol)
  359.   (intern-string! (read-atom)))
  360.  
  361. (define-accretor 1 (parse-object/numeric-prefix)
  362.   (let ((number
  363.      (let ((char (read-char)))
  364.        (string-append (string #\# char) (read-atom)))))
  365.     (or (parse-number number)
  366.     (parse-error "Bad number syntax" number))))
  367.  
  368. (define-accretor 1 (parse-object/bit-string)
  369.   (discard-char)
  370.   (let ((string (read-atom)))
  371.     (let ((length (string-length string)))
  372.       (unsigned-integer->bit-string
  373.        length
  374.        (let loop ((index 0) (result 0))
  375.      (if (< index length)
  376.          (loop (1+ index)
  377.            (+ (* result 2)
  378.               (case (string-ref string index)
  379.             ((#\0) 0)
  380.             ((#\1) 1)
  381.             (else  (parse-error "Bad bit-string syntax"
  382.                         (string-append "#*" string))))))
  383.          result))))))
  384.  
  385. ;;;; Lists/Vectors
  386.  
  387. (define-accretor (parse-object/list-open)
  388.   (discard-char)
  389.   (collect-list/top-level))
  390.  
  391. (define-accretor 1 (parse-object/vector-open)
  392.   (discard-char)
  393.   (list->vector (collect-list/top-level)))
  394.  
  395. (define (parse-object/list-close)
  396.   (if (and ignore-extra-list-closes
  397.        (eq? console-input-port *parser-input-port*))
  398.       (discard-char)
  399.       (parse-error "Unmatched close paren" (read-char)))
  400.   (parse-object/dispatch))
  401.  
  402. (define (collect-list/list-close)
  403.   (discard-char)
  404.   (list))
  405.  
  406. (define ignore-extra-list-closes
  407.   true)
  408.  
  409. (define (collect-list/top-level)
  410.   (let ((value (collect-list/dispatch)))
  411.     (if (and (pair? value)
  412.          (eq? dot-symbol (car value)))
  413.     (parse-error "Improperly formed dotted list" value)
  414.     value)))
  415.  
  416. (define ((collect-list-wrapper parse-object))
  417.   (let ((first (parse-object)))            ;forces order.
  418.     (let ((rest (collect-list/dispatch)))
  419.       (if (and (pair? rest)
  420.            (eq? dot-symbol (car rest)))
  421.       (if (and (pair? (cdr rest))
  422.            (null? (cddr rest)))
  423.           (cons first (cadr rest))
  424.           (parse-error "Improperly formed dotted list" (cons first rest)))
  425.       (cons first rest)))))
  426.  
  427. (define dot-symbol)
  428.  
  429. ;;;; Whitespace/Comments
  430.  
  431. (define (parse-object/whitespace)
  432.   (discard-whitespace)
  433.   (parse-object/dispatch))
  434.  
  435. (define (collect-list/whitespace)
  436.   (discard-whitespace)
  437.   (collect-list/dispatch))
  438.  
  439. (define (discard-whitespace)
  440.   (discard-chars char-set/non-whitespace))
  441.  
  442. (define (parse-object/undefined-atom-delimiter)
  443.   (parse-error "Undefined atom delimiter" (read-char))
  444.   (parse-object/dispatch))
  445.  
  446. (define (collect-list/undefined-atom-delimiter)
  447.   (parse-error "Undefined atom delimiter" (read-char))
  448.   (collect-list/dispatch))
  449.  
  450. (define (parse-object/comment)
  451.   (discard-comment)
  452.   (parse-object/dispatch))
  453.  
  454. (define (collect-list/comment)
  455.   (discard-comment)
  456.   (collect-list/dispatch))
  457.  
  458. (define (discard-comment)
  459.   (discard-char)
  460.   (discard-chars char-set/comment-delimiters)
  461.   (discard-char))
  462.  
  463. (define (parse-object/special-comment)
  464.   (discard-special-comment)
  465.   (parse-object/dispatch))
  466.  
  467. (define (collect-list/special-comment)
  468.   (discard-special-comment)
  469.   (collect-list/dispatch))
  470.  
  471. (define (discard-special-comment)
  472.   (discard-char)
  473.   (let loop ()
  474.     (discard-chars char-set/special-comment-leaders)
  475.     (if (char=? #\| (read-char))
  476.     (if (char=? #\# (peek-char))
  477.         (discard-char)
  478.         (loop))
  479.     (begin
  480.       (if (char=? #\| (peek-char))
  481.           (begin
  482.         (discard-char)
  483.         (loop)))
  484.       (loop)))))
  485.  
  486. ;;;; Quoting
  487.  
  488. (define-accretor (parse-object/quote)
  489.   (discard-char)
  490.   (list 'QUOTE (parse-object/dispatch)))
  491.  
  492. (define-accretor (parse-object/quasiquote)
  493.   (discard-char)
  494.   (list 'QUASIQUOTE (parse-object/dispatch)))
  495.  
  496. (define-accretor (parse-object/unquote)
  497.   (discard-char)
  498.   (if (char=? #\@ (peek-char))
  499.       (begin
  500.     (discard-char)
  501.     (list 'UNQUOTE-SPLICING (parse-object/dispatch)))
  502.       (list 'UNQUOTE (parse-object/dispatch))))
  503.  
  504.  
  505. (define-accretor (parse-object/string-quote)
  506.   ;; This version uses a string output port to collect the string fragments
  507.   ;; because string ports store the string efficiently and append the
  508.   ;; string fragments in amortized linear time.
  509.   ;;
  510.   ;; The common case for a string with no escapes is handled efficiently by
  511.   ;; lifting the code out of the loop.
  512.  
  513.   (discard-char)
  514.   (let ((head (read-string char-set/string-delimiters)))
  515.     (if (char=? #\" (read-char))
  516.     head
  517.     (with-string-output-port
  518.      (lambda (port)
  519.        (write-string head port)
  520.        (let loop ()
  521.          (let ((char
  522.             (let ((char (read-char)))
  523.               (cond ((char-ci=? char #\n) #\Newline)
  524.                 ((char-ci=? char #\t) #\Tab)
  525.                 ((char-ci=? char #\v) #\VT)
  526.                 ((char-ci=? char #\b) #\BS)
  527.                 ((char-ci=? char #\r) #\Return)
  528.                 ((char-ci=? char #\f) #\Page)
  529.                 ((char-ci=? char #\a) #\BEL)
  530.                 ((char->digit char 8)
  531.                  (let ((c2 (read-char)))
  532.                    (octal->char char c2 (read-char))))
  533.                 (else char)))))
  534.            (write-char char port)
  535.            (write-string (read-string char-set/string-delimiters) port)
  536.            (if (char=? #\\ (read-char))
  537.            (loop)))))))))
  538.  
  539. (define (octal->char c1 c2 c3)
  540.   (let ((d1 (char->digit c1 8))
  541.     (d2 (char->digit c2 8))
  542.     (d3 (char->digit c3 8)))
  543.     (if (not (and d1 d2 d3))
  544.     (error "Badly formed octal string escape:" (string #\\ c1 c2 c3)))
  545.     (let ((sum (+ (* #o100 d1) (* #o10 d2) d3)))
  546.       (if (>= sum 256)
  547.       (error "Octal string escape exceeds ASCII range:"
  548.          (string #\\ c1 c2 c3)))
  549.       (ascii->char sum))))
  550.  
  551. (define-accretor 1 (parse-object/char-quote)
  552.   (discard-char)
  553.   (if (char=? #\\ (peek-char))
  554.       (read-char)
  555.       (name->char
  556.        (let loop ()
  557.      (cond ((char=? #\\ (peek-char))
  558.         (discard-char)
  559.         (string (read-char)))
  560.            ((char-set-member? char-set/char-delimiters (peek-char))
  561.         (string (read-char)))
  562.            (else
  563.         (let ((string (read-string char-set/char-delimiters)))
  564.           (if (let ((char (peek-char/eof-ok)))
  565.             (and (not (eof-object? char))
  566.                  (char=? #\- char)))
  567.               (begin
  568.             (discard-char)
  569.             (string-append string "-" (loop)))
  570.               string))))))))
  571.  
  572. ;;;; Constants
  573.  
  574. (define-accretor (parse-object/false)
  575.   (discard-char)
  576.   false)
  577.  
  578. (define-accretor (parse-object/true)
  579.   (discard-char)
  580.   true)
  581.  
  582. (define-accretor 1 (parse-object/named-constant)
  583.   (discard-char)
  584.   (let ((object-name (parse-object/dispatch)))
  585.     (cdr (or (assq object-name named-objects)
  586.          (parse-error "No object by this name" object-name)))))
  587.  
  588. (define named-objects)
  589.  
  590. (define (parse-unhash number)
  591.   (if (not (exact-nonnegative-integer? number))
  592.       (parse-error "Invalid unhash syntax" number))
  593.   (let ((object (object-unhash number)))
  594.     ;; This knows that 0 is the hash of #f.
  595.     (if (and (false? object) (not (zero? number)))
  596.     (parse-error "Invalid hash number" number))
  597.     object))
  598.  
  599. (define-accretor 1 (parse-object/unhash)
  600.   (discard-char)
  601.   (let* ((number (parse-object/dispatch))
  602.      (object (parse-unhash number)))
  603.     ;; This may seem a little random, because #@N doesn't just
  604.     ;; return an object.  However, the motivation for this piece of
  605.     ;; syntax is convenience -- and 99.99% of the time the result of
  606.     ;; this syntax will be evaluated, and the user will expect the
  607.     ;; result of the evaluation to be the object she was referring
  608.     ;; to.  If the quotation isn't there, the user just gets
  609.     ;; confused.
  610.     (if (scode-constant? object)
  611.     object
  612.     (make-quotation object))))
  613.  
  614. (define-accretor 1 (parse-object/unhash-printed-representation)
  615.   ;; #[fnord]
  616.   ;; #[fnord-with-hash-number n ... ]
  617.   (discard-char)
  618.   (let* ((name   (parse-object/dispatch)))
  619.     (discard-whitespace)
  620.     (if (char=? #\] (peek-char))
  621.     (begin
  622.       (read-char)
  623.       (parse-error "No hash number in #[" name)))
  624.     (let* ((number (parse-object/dispatch))
  625.        (object (parse-unhash number)))
  626.       ;; now gobble up crap until we find the #\]
  627.       (let loop ()
  628.     (discard-whitespace)
  629.     (if (char=? #\] (peek-char))
  630.         (read-char)
  631.         (begin
  632.           (parse-object/dispatch)
  633.           (loop))))
  634.       object)))
  635.  
  636. ;;;; #<number>
  637.  
  638. (define (parse-object/special-prefix)
  639.   (parse-special-prefix *parser-parse-object-special-table*))
  640.  
  641. (define (collect-list/special-prefix)
  642.   (parse-special-prefix *parser-collect-list-special-table*))
  643.  
  644. (define (parse-special-prefix table)
  645.   (set! *parser-current-special-prefix*
  646.     (string->number (read-string char-set/non-digit) 10))
  647.   ((vector-ref table (peek-ascii))))
  648.  
  649. ;;;; #n= and #n#
  650. ;;;
  651. ;;;  The fluid variable *parser-cyclic-context* contains the context
  652. ;;;  (roughly read operation) in which the #n= and #n# references are
  653. ;;;  defined.  It is basically a table associating <n> with the
  654. ;;;  reference #<n>#.
  655.  
  656. (define *parser-cyclic-context* #f)
  657.  
  658. (define (parse-object/define-shared)
  659.   (discard-char)
  660.   (if (not *parser-current-special-prefix*)
  661.       (parse-error
  662.        "#= not allowed.  Circular structure syntax #<n>= requires <n>"))
  663.   (let* ((index *parser-current-special-prefix*)
  664.      (ref   
  665.       (let ((ref (context/find-reference *parser-cyclic-context*
  666.                          index)))
  667.         ;; The follwing test is not necessary unless we want
  668.         ;; to be CLtL compliant
  669.         (if ref
  670.         (parse-error
  671.          "Cannot redefine circular structure label #<n>=, <n> ="
  672.          index))
  673.         (context/touch! *parser-cyclic-context*)
  674.         (context/define-reference *parser-cyclic-context* index)))
  675.      (text  (parse-object/dispatch)))
  676.     (if (reference? text)
  677.     (parse-error
  678.      (string-append
  679.       "#"  (number->string (reference/index ref))
  680.       "=#" (number->string (reference/index text))
  681.       "# not allowed.  Circular structure labels must not refer to labels."
  682.       )))
  683.     (context/close-reference ref text)
  684.     ref))
  685.  
  686. (define (parse-object/reference-shared)
  687.   (discard-char)
  688.   (if (not *parser-current-special-prefix*)
  689.       (parse-error
  690.        "## not allowed.  Circular structure syntax #<n># requires <n>"))
  691.   (let* ((index  *parser-current-special-prefix*)
  692.      (ref    (context/find-reference *parser-cyclic-context* index)))
  693.     (if ref
  694.     (begin  (context/touch! *parser-cyclic-context*)
  695.         ref)
  696.     (parse-error
  697.      "Must define circular structure label #<n># before use: <n> ="
  698.      index))))
  699.  
  700. (define (cyclic-parser-post-edit datum)
  701.   (if *parser-cyclic-context*
  702.       (context/substitute-cycles *parser-cyclic-context* datum)
  703.       datum))
  704.  
  705. ;;;; Contexts and References
  706.  
  707. (define-structure
  708.   (reference
  709.    (conc-name reference/))
  710.   index
  711.   context
  712.   text
  713.   start-touch-count   ; number of #n? things seen when we saw this #n=
  714.   end-touch-count     ; number of #n? things seen after finishing this one
  715.                       ;  is #f if this is not yet finished
  716.                       ; if difference=0 this one contains no references
  717.   )
  718.  
  719. (define (reference/contains-references? ref)
  720.   (not (eqv? (reference/start-touch-count ref)
  721.          (reference/end-touch-count ref))))
  722.  
  723. (define-structure
  724.   (context
  725.    (conc-name context/)
  726.    (constructor %make-context))
  727.   references        ; some kind of association number->reference
  728.   touches           ; number of #n# or #n= things see so far
  729.   )
  730.  
  731. (define (make-context)   (%make-context '() 0))
  732.  
  733. (define (context/touch! context)
  734.   (set-context/touches! context  (fix:1+ (context/touches context))))
  735.  
  736. (define (context/define-reference context index)
  737.   (let ((ref  (make-reference index
  738.                   context
  739.                   ()
  740.                   (context/touches context)
  741.                   #f)))
  742.     
  743.     (set-context/references!
  744.      context
  745.      (cons (cons index ref) (context/references context)))
  746.     ref))
  747.  
  748. (define (context/close-reference ref text)
  749.   (set-reference/end-touch-count! ref
  750.                   (context/touches (reference/context ref)))
  751.   (set-reference/text! ref text))
  752.  
  753. (define (context/find-reference context index)
  754.   (let ((index.ref (assq index (context/references context))))
  755.     (if index.ref (cdr index.ref) #f)))
  756.  
  757. ;;;  SUBSTITUTE! traverses a tree, replacing all references by their text
  758. ;;;
  759. ;;;  This implementation assumes that #n= and #n# are THE ONLY source
  760. ;;;  of circularity, thus the objects given to SUBSTITUTE! are trees.
  761.  
  762. (define (substitute! thing)
  763.   ;(display "[substitute!]")
  764.   (cond ((pair? thing)    (substitute/pair! thing))
  765.     ((vector? thing)  (substitute/vector! thing))
  766.     ((%record? thing) (substitute/%record! thing))))
  767.  
  768. (define (substitute/pair! pair)
  769.   (if (reference? (car pair))
  770.       (set-car! pair (reference/text (car pair)))
  771.       (substitute! (car pair)))
  772.   (if (reference? (cdr pair))
  773.       (set-cdr! pair (reference/text (cdr pair)))
  774.       (substitute! (cdr pair))))
  775.  
  776. (define (substitute/vector! v)
  777.   (let ((n (vector-length v)))
  778.     (let loop ((i 0))
  779.       (if (not (fix:= i n))
  780.       (let ((elt (vector-ref v i)))
  781.         (if (reference? elt)
  782.         (vector-set! v i (reference/text elt))
  783.         (substitute! elt))
  784.         (loop (fix:1+ i)))))))
  785.     
  786. (define (substitute/%record! r)
  787.   ;; TEST THIS CODE
  788.   (do ((i (fix:- (%record-length r) 1) (fix:- i 1)))
  789.       ((fix:< i 0))
  790.     (let ((elt (%record-ref r i)))
  791.       (if (reference? elt)
  792.       (%record-set! r i (reference/text elt))
  793.       (substitute! elt)))))
  794.  
  795. (define (context/substitute-cycles context datum)
  796.   (for-each (lambda (index.ref)
  797.           (let ((ref (cdr index.ref)))
  798.         (if (reference/contains-references? ref)
  799.             (substitute! (reference/text ref)))))
  800.         (context/references context))
  801.   (cond ((null? (context/references context))     datum)
  802.     ((reference? datum)                     (reference/text datum))
  803.     (else  (substitute! datum)
  804.            datum)))