home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / maths / b116_1 / jacal / parse < prev    next >
Text File  |  1993-06-15  |  16KB  |  476 lines
  1. ;;; JACAL: Symbolic Mathematics System.        -*-scheme-*-
  2. ;;; Copyright 1989, 1990, 1991, 1992, 1993 Aubrey Jaffer.
  3. ;;; See the file "COPYING" for terms applying to this program.
  4.  
  5. ;;; This implements a lexer which separates tokens according to
  6. ;;; character class and a Pratt style parser.
  7. ;;; (CGOL:TOP-PARSE sep delimiter) returns one parsed object.
  8. ;;; delimiter must be a character or string.  sep is the separator for
  9. ;;; lists and arguments.
  10.  
  11. ;;; References are:
  12.  
  13. ;;; Pratt, V. R.
  14. ;;; Top Down Operator Precendence.
  15. ;;; SIGACT/SIGPLAN
  16. ;;; Symposium on Principles of Programming Languages,
  17. ;;; Boston, 1973, 41-51
  18.  
  19. ;;; WORKING PAPER 121
  20. ;;; CGOL - an Alternative External Representation For LISP users
  21. ;;; Vaughan R. Pratt
  22. ;;; MIT Artificial Intelligence Lab.
  23. ;;; March 1976
  24.  
  25. ;;; Mathlab Group,
  26. ;;; MACSYMA Reference Manual, Version Ten,
  27. ;;; Laboratory for Computer Science, MIT, 1983
  28.  
  29. (define *syn-rules* #f)
  30. (define *syn-defs* #f)
  31. (define *lex-rules* #f)
  32. (define *lex-defs* #f)
  33.  
  34. (define lex:column 0)
  35. (define lex:peek-char peek-char)
  36. (define (lex:read-char)
  37.   (let ((c (read-char)))
  38.     (if (or (eqv? c #\newline) (eof-object? c))
  39.     (set! lex:column 0)
  40.       (set! lex:column (+ 1 lex:column)))
  41.     c))
  42. (define (lex:bump-column pos)
  43.   (cond ((eqv? #\newline (lex:peek-char))
  44.      (lex:read-char)))        ;to do newline
  45.   (set! lex:column (+ lex:column pos)))
  46. (define (cgol:warn msg)
  47.   (do ((j (+ -1 lex:column) (- j 8)))
  48.       ((> 8 j)
  49.        (do ((i j (- i 1)))
  50.        ((>= 0 i))
  51.      (display-diag #\ )))
  52.     (display-diag slib:tab))
  53.   (display-diag "^ ")
  54.   (display-diag (tran:translate msg))
  55.   (newline-diag))
  56.  
  57. ;(require 'record)
  58. ;(define lex-rtd (make-record-type "lexrec" '(cc sfp)))
  59. ;(define lex:make-rec (record-constructor lex-rtd))
  60. ;(define lex:cc (record-accessor lex-rtd 'cc))
  61. ;(define lex:sfp (record-accessor lex-rtd 'sfp))
  62.  
  63. (define lex:make-rec cons)
  64. (define lex:cc car)
  65. (define lex:sfp cdr)
  66.  
  67. (define lex:tab-get (alist-inquirer char=?))
  68. (define lex:tab-set! (alist-associator char=?))
  69. ;(require 'hash-table)
  70. ;(define lex:tab-get (hash-inquirer char=?))
  71. ;(define lex:tab-set! (hash-associator char=?))
  72. (define (lex:def-class bp chrlst string-fun)
  73.   (for-each
  74.    (lambda (token)
  75.      (let ((oldlexrec (lex:tab-get *lex-defs* token)))
  76.        (set! *lex-defs*
  77.          (lex:tab-set! *lex-defs* token (lex:make-rec bp string-fun)))
  78.        (cond ((or (not oldlexrec) (eqv? (lex:cc oldlexrec) bp)) #t)
  79.          (else (math:warn 'cc-of token 'redefined-to- bp)))))
  80.    chrlst))
  81.  
  82. ;;; CGOL:SXOP-LBP is the left binding power of this sxop.
  83. ;;; CGOL:SXOP-RBP is the right binding power of this sxop.
  84. ;;; CGOL:SXOP-LED is the left denotation (function to call when
  85. ;;; unclaimed token on left).
  86. ;;; CGOL:SXOP-NUD is the null denotation (function to call when no
  87. ;;; unclaimed tokens).
  88.  
  89. ;(define sxop-rtd
  90. ;  (make-record-type "sxop" '(name lame lbp rbp nud led)))
  91. ;(define cgol:make-sxop (record-constructor sxop-rtd))
  92. ;(define cgol:sxop-name (record-accessor sxop-rtd 'name))
  93. ;(define cgol:sxop-lame (record-accessor sxop-rtd 'lame))
  94. ;(define cgol:sxop-lbp (record-accessor sxop-rtd 'lbp))
  95. ;(define cgol:sxop-led (record-accessor sxop-rtd 'led))
  96. ;(define cgol:sxop-rbp (record-accessor sxop-rtd 'rbp))
  97. ;(define cgol:sxop-nud (record-accessor sxop-rtd 'nud))
  98. ;;sxop-match overloaded on sxop-rbp
  99. ;(define cgol:sxop-match cgol:sxop-rbp)
  100.  
  101. ;(define cgol:sxop-set-name! (record-modifier sxop-rtd 'name))
  102. ;(define cgol:sxop-set-lame! (record-modifier sxop-rtd 'lame))
  103. ;(define cgol:sxop-set-lbp! (record-modifier sxop-rtd 'lbp))
  104. ;(define cgol:sxop-set-led! (record-modifier sxop-rtd 'led))
  105. ;(define cgol:sxop-set-rbp! (record-modifier sxop-rtd 'rbp))
  106. ;(define cgol:sxop-set-nud! (record-modifier sxop-rtd 'nud))
  107. ;;sxop-match overloaded on sxop-rbp
  108. ;(define cgol:sxop-set-match! cgol:sxop-set-rbp!)
  109.  
  110. (define (cgol:make-sxop name lame lbp rbp nud led)
  111.   (cons (cons name lame) (cons (cons lbp rbp) (cons nud led))))
  112. (define cgol:sxop-name caar)
  113. (define cgol:sxop-lame cdar)
  114. (define cgol:sxop-lbp caadr)
  115. (define cgol:sxop-rbp cdadr)
  116. (define cgol:sxop-nud caddr)
  117. (define cgol:sxop-led cdddr)
  118. ;;sxop-match overloaded on sxop-rbp
  119. (define cgol:sxop-match cgol:sxop-rbp)
  120.  
  121. (define (cgol:sxop-set-name! pob val) (set-car! (car pob) val))
  122. (define (cgol:sxop-set-lame! pob val) (set-cdr! (car pob) val))
  123. (define (cgol:sxop-set-lbp! pob val) (set-car! (cadr pob) val))
  124. (define (cgol:sxop-set-rbp! pob val) (set-cdr! (cadr pob) val))
  125. (define (cgol:sxop-set-nud! pob val) (set-car! (cddr pob) val))
  126. (define (cgol:sxop-set-led! pob val) (set-cdr! (cddr pob) val))
  127. ;;sxop-match overloaded on sxop-rbp
  128. (define cgol:sxop-set-match! cgol:sxop-set-rbp!)
  129.  
  130. (define cgol:sxop-get (alist-inquirer equal?))
  131. (define cgol:sxop-set! (alist-associator equal?))
  132. ;(define cgol:sxop-get (hash-inquirer equal?))
  133. ;(define cgol:sxop-set! (hash-associator equal?))
  134.  
  135. ;(define cgol:null-sxop #f)
  136.  
  137. (define (cgol:defield tokens value cap accessor modifier)
  138.   (for-each
  139.    (lambda (tok)
  140.      (let* ((token (if (symbol? tok) (symbol->string tok) tok))
  141.         (a (cgol:sxop-get *syn-defs* token)))
  142.        (cond ((not a)
  143.           (set! a (cgol:make-sxop #f #f #f #f #f #f))
  144. ;          (if (equal? "" tok) (set! cgol:null-sxop a))
  145.           (set! *syn-defs* (cgol:sxop-set! *syn-defs* token a))))
  146.        (cond ((eqv? value (accessor a)))
  147.          ((not (accessor a)) (modifier a value))
  148.          (else (math:warn cap 'of- token
  149.                  'redefined-from- (accessor a)
  150.                  'to- value)
  151.            (modifier a value)))))
  152.    (if (pair? tokens)
  153.        tokens
  154.        (list tokens))))
  155.  
  156. (define (cgol:defname tokens value)
  157.   (cgol:defield tokens value "name" cgol:sxop-name cgol:sxop-set-name!))
  158. (define (cgol:deflame tokens value)
  159.   (cgol:defield tokens value "lame" cgol:sxop-lame cgol:sxop-set-lame!))
  160. (define (cgol:deflbp tokens value)
  161.   (cgol:defield tokens value "lbp" cgol:sxop-lbp cgol:sxop-set-lbp!))
  162. (define (cgol:defled tokens value)
  163.   (cgol:defield tokens value "led" cgol:sxop-led cgol:sxop-set-led!))
  164. (define (cgol:defrbp tokens value)
  165.   (cgol:defield tokens value "rbp" cgol:sxop-rbp cgol:sxop-set-rbp!))
  166. ;;sxop-match overloaded on sxop-rbp
  167. (define (cgol:defmatch tokens value)
  168.   (cgol:defield tokens value "match" cgol:sxop-rbp cgol:sxop-set-rbp!))
  169. (define (cgol:defnud tokens value)
  170.   (cgol:defield tokens value "nud" cgol:sxop-nud cgol:sxop-set-nud!))
  171.  
  172. ;;;Calls to set up tables.
  173.  
  174. (define (cgol:delim x lbp)
  175.   (cgol:deflbp x lbp)
  176.   (cgol:defrbp x -2)
  177.   (cgol:defled x #f)
  178.   (cgol:defnud x #f))
  179. (define (cgol:separator x lbp)
  180.   (cgol:deflbp x lbp)
  181.   (cgol:defrbp x -1)
  182.   (cgol:defled x #f)
  183.   (cgol:defnud x #f))
  184. (define (cgol:prefix op sop rbp)
  185.   (cgol:defname op sop)
  186.   (cgol:defrbp op rbp)
  187.   (cgol:defnud op cgol:parse-prefix))
  188. (define (cgol:prefix2 op sop rbp)
  189.   (cgol:defname op sop)
  190.   (cgol:defrbp op rbp)
  191.   (cgol:defnud op cgol:parse-prefix2))
  192. (define (cgol:postfix op sop lbp)
  193.   (cgol:deflame op sop)
  194.   (cgol:deflbp op lbp)
  195.   (cgol:defled op cgol:parse-postfix))
  196. (define (cgol:infix op sop lbp rbp)
  197.   (cgol:deflame op sop)
  198.   (cgol:deflbp op lbp)
  199.   (cgol:defrbp op rbp)
  200.   (cgol:defled op cgol:parse-infix))
  201. (define (cgol:nary op sop bp)
  202.   (cgol:deflame op sop)
  203.   (cgol:deflbp op bp)
  204.   (cgol:defrbp op bp)
  205.   (cgol:defled op cgol:parse-nary))
  206. (define (cgol:nofix op sop)
  207.   (cgol:defname op sop)
  208.   (cgol:defnud op cgol:parse-nofix))
  209. (define (cgol:commentfix op sop)
  210.   (cgol:defname op sop)
  211.   (cgol:deflame op sop)
  212.   (cgol:deflbp op 220)
  213.   (cgol:defrbp op 220)
  214.   (cgol:defnud op cgol:parse-precomment)
  215.   (cgol:defled op cgol:parse-postcomment))
  216. (define (cgol:rest op sop bp)
  217.   (cgol:defname op sop)
  218.   (cgol:defnud op cgol:parse-rest)
  219.   (cgol:defrbp op bp))
  220. (define (cgol:matchfix op sop match)
  221.   (cgol:defname op sop)
  222.   (cgol:delim match 0)
  223.   (cgol:defmatch op match)
  224.   (cgol:defnud op cgol:parse-matchfix))
  225. (define (cgol:inmatchfix op sop match lbp)
  226.   (cgol:deflame op sop)
  227.   (cgol:defmatch op match)
  228.   (cgol:delim match 0)
  229.   (cgol:deflbp op lbp)
  230.   (cgol:defled op cgol:parse-inmatchfix))
  231.  
  232. ;;;; Here is the code which actually lexes and parses.
  233.  
  234. (define cgol:char0 (integer->char 0))
  235. (define (lex:tab-geteof x)
  236.   (lex:tab-get *lex-rules* (if (eof-object? x) cgol:char0 x)))
  237. (define (lex)
  238.   (let* ((char (lex:read-char))
  239.      (rec (lex:tab-geteof char))
  240.      (proc (and rec (lex:cc rec)))
  241.      (clist (list char)))
  242.     (cond
  243.      ((not proc) char)
  244.      ((procedure? proc)
  245.       (do ((cl clist (begin (set-cdr! cl (list (lex:read-char))) (cdr cl))))
  246.       ((proc (lex:peek-char))
  247.        (funcall (or (lex:sfp rec) list->string) clist))))
  248.      ((eqv? 0 proc) (lex))
  249.      (else
  250.       (do ((cl clist (begin (set-cdr! cl (list (lex:read-char))) (cdr cl))))
  251.       ((not (let* ((prec (lex:tab-geteof (lex:peek-char)))
  252.                (cclass (and prec (lex:cc prec))))
  253.           (or (eqv? cclass proc)
  254.               (eqv? cclass (- proc 1)))))
  255.        (funcall (or (lex:sfp rec) list->string) clist)))))))
  256.  
  257. ;;; Now for the way we use LEX.
  258. (define cgol:token #f)
  259. (define cgol:pob #f)
  260. (define (cgol:advance)
  261.   (set! cgol:token (lex))
  262.   (set! cgol:pob (cgol:sxop-get *syn-rules* cgol:token))
  263.   cgol:token)
  264.  
  265. ;;; Now actual parsing.
  266. (define (cgol:nudcall)
  267.   (let* ((obj cgol:token) (pob cgol:pob))
  268.     (cond
  269.      ((cgol:at-sep?) (cgol:warn 'extra-separator)
  270.              (cgol:advance)
  271.              (cgol:nudcall))
  272.      (pob (let ((proc (cgol:sxop-nud pob)))
  273.         (cond (proc (proc pob))
  274.           (else (cgol:advance)
  275.             (let ((name (cgol:sxop-name pob)))
  276.               (or (and (not (procedure? name)) name)
  277.                   (cgol:sxop-lame pob)
  278.                   '?))))))
  279.      (else (cgol:advance)
  280.        (if (string? obj) (string->symbol obj) obj)))))
  281. (define (cgol:ledcall left)
  282.   (let* ((pob cgol:pob))
  283.     (cond
  284.      ((cgol:at-sep?) (cgol:warn 'extra-separator)
  285.              (cgol:advance)
  286.              (cgol:ledcall left))
  287.      (pob (let ((proc (cgol:sxop-led pob)))
  288.          (cond (proc (proc pob left))
  289.                (else (cgol:warn 'not-an-operator)
  290.                  (cgol:advance)
  291.                  left))))
  292.       (else left))))
  293.  
  294. (define (cgol:parse bp)
  295.   (do ((left (cgol:nudcall)
  296.          (cgol:ledcall left)))
  297.       ((or (>= bp 200)            ;to avoid unneccesary lookahead
  298.        (>= bp (if cgol:pob (or (cgol:sxop-lbp cgol:pob) 0) 0)))
  299.        left)))
  300.  
  301. (define (cgol:at-sep?)
  302.   (and cgol:pob (eqv? (cgol:sxop-rbp cgol:pob) -1)))
  303.  
  304. (define (cgol:at-delim?)
  305.   (or (eof-object? cgol:token)
  306.       (and cgol:pob (eqv? (cgol:sxop-rbp cgol:pob) -2))))
  307.  
  308. (define (cgol:parse-list sep bp)
  309.   (let ((f (cgol:parse bp)))
  310.     (cons f (cond ((equal? sep cgol:token)
  311.            (cgol:advance)
  312.            (cond
  313.             ((equal? sep cgol:token) (cgol:warn 'expression-missing)
  314.              (cgol:advance)
  315.              (cons '? (cgol:parse-list sep bp)))
  316.             ((cgol:at-delim?)
  317.              (cgol:warn 'expression-missing)
  318.              '(?))
  319.             (else (cgol:parse-list sep bp))))
  320.           (sep '())
  321.           ((cgol:at-delim?) '())
  322.           (else (cgol:parse-list sep bp))))))
  323.  
  324. (define cgol:arg-separator #f)
  325. (define cgol:arg-lbp 0)
  326. (define (cgol:parse-delimited delim)
  327.   (cond ((cgol:at-sep?)
  328.      (cgol:warn 'expression-missing)
  329.      (cgol:advance)
  330.      (cons '? (cgol:parse-delimited delim)))
  331.     ((cgol:at-delim?)
  332.      (if (eqv? delim cgol:token) #t
  333.          (cgol:warn 'mismatched-delimiter))
  334.      (cgol:advance)
  335.      '())
  336.     (else
  337.      (let ((ans (cgol:parse-list cgol:arg-separator cgol:arg-lbp)))
  338.        (cond ((eqv? delim cgol:token))
  339.          ((cgol:at-delim?)
  340.           (cgol:warn 'mismatched-delimiter))
  341.          (else
  342.           (cgol:warn 'delimiter-expected--ignoring-rest)
  343.           (do () ((cgol:at-delim?)) (cgol:parse cgol:arg-lbp))))
  344.        (cgol:advance)
  345.        ans))))
  346.  
  347. (define (cgol:top-parse sep delim)
  348.   (set! cgol:arg-separator sep)
  349.   (let ((tmp (cgol:sxop-get *syn-rules* cgol:arg-separator)))
  350.     (if tmp (set! cgol:arg-lbp (cgol:sxop-lbp tmp))))
  351.   (cgol:advance)            ;to get first token
  352.   (cond ((eof-object? cgol:token) cgol:token)
  353.     ((equal? cgol:token delim) #f)
  354.     ((cgol:at-sep?) (cgol:warn 'extra-separator) #f)
  355.     ((cgol:at-delim?) (cgol:warn 'extra-delimiter) #f)
  356.     (else
  357.      (let ((ans (cgol:parse 0)))
  358.        (cond ((eof-object? cgol:token))
  359.          ((equal? delim cgol:token))
  360.          (else
  361.           (cgol:warn 'delimiter-expected--ignoring-rest)
  362.           (do () ((or (equal? delim cgol:token)
  363.                   (eof-object? cgol:token)))
  364.             (cgol:advance))))
  365.        ans))))
  366.  
  367. (define (call-or-list1 proc arg)
  368.   (if proc (if (procedure? proc) (proc arg) (list proc arg))
  369.       arg))
  370. (define (call-or-list2 proc arg1 arg2)
  371.   (if proc (if (procedure? proc) (proc arg1 arg2) (list proc arg1 arg2))
  372.       (list arg1 arg2)))
  373. (define (apply-or-cons proc args)
  374.   (if proc (if (procedure? proc) (apply proc args) (cons proc args))
  375.       args))
  376.  
  377. ;;;next level of abstraction
  378.  
  379. (define (cgol:parse-matchfix pob)
  380.   (define name (cgol:sxop-name pob))
  381.   (cgol:advance)
  382.   (cond
  383.    (name
  384.     (apply-or-cons name (cgol:parse-delimited (cgol:sxop-match pob))))
  385.    ((cgol:at-sep?)
  386.     (cgol:warn 'extra-separator)
  387.     (cgol:parse-matchfix pob))
  388.    ((cgol:at-delim?) (cgol:warn 'expression-missing) (cgol:advance) '?)
  389.    (else                ;just parenthesized expression
  390.     (let ((ans (cgol:parse cgol:arg-lbp)))
  391.       (do () ((not (cgol:at-sep?)))
  392.     (cgol:warn 'extra-separator) (cgol:advance))
  393.       (do ((left ans (cgol:ledcall left))) ;restart parse
  394.       ((>= cgol:arg-lbp (if cgol:pob (or (cgol:sxop-lbp cgol:pob) 0) 0))
  395.        (set! ans left)))
  396.       (cond ((equal? (cgol:sxop-match pob) cgol:token) (cgol:advance) ans)
  397.         ((cgol:at-delim?) (cgol:warn 'mismatched-delimiter)
  398.                   (cgol:advance) ans)
  399.         (else (cgol:warn 'delimiter-expected--ignoring-rest)
  400.           (do () ((cgol:at-delim?)) (cgol:parse cgol:arg-lbp))
  401.           (cgol:advance)
  402.           ans))))))
  403. (define (cgol:parse-rest pob)
  404.   (cgol:advance)            ;past this token
  405.   (cons (cgol:sxop-name pob)
  406.     (cond ((cgol:at-delim?) '())
  407.           (else
  408.            (cond ((cgol:at-sep?)
  409.               (cgol:warn 'extra-separator)
  410.               (cgol:advance)))
  411.            (cgol:parse-list #f (cgol:sxop-rbp pob))))))
  412. (define (cgol:parse-inmatchfix pob left)
  413.   (define lame (cgol:sxop-lame pob))
  414.   (cgol:advance)            ;past this token
  415.   (apply-or-cons
  416.    lame (cons left (cgol:parse-delimited (cgol:sxop-match pob)))))
  417. (define (cgol:parse-prefix pob)
  418.   (define name (cgol:sxop-name pob))
  419.   (cgol:advance)            ;past this token
  420.   (cond ((cgol:at-delim?) (or (and (not (procedure? name)) name)
  421.                   (cgol:sxop-lame pob)))
  422.     (else
  423.      (call-or-list1 name (cgol:parse (cgol:sxop-rbp pob))))))
  424. (define (cgol:parse-prefix2 pob)
  425.   (define name (cgol:sxop-name pob))
  426.   (cgol:advance)            ;past this token
  427.   (let ((tok1
  428.      (cond
  429.       ((cgol:at-delim?) (cgol:warn 'expression-missing) '?)
  430.       (else (cgol:parse (cgol:sxop-rbp pob))))))
  431.     (cond ((cgol:at-delim?) (cgol:warn 'expression-missing)
  432.                 (call-or-list2 name tok1 '?))
  433.       (else
  434.        (call-or-list2 name tok1 (cgol:parse (cgol:sxop-rbp pob)))))))
  435. (define (cgol:parse-nofix pob)
  436.   (define name (cgol:sxop-name pob))
  437.   (cgol:advance)            ;past this token
  438.   (apply-or-cons name '()))
  439. (define (cgol:parse-precomment pob)
  440.   (define name (cgol:sxop-name pob))
  441.   (if name (name))
  442.   (cgol:advance)            ;past this token
  443.   (cgol:parse (cgol:sxop-rbp pob)))
  444. (define (cgol:parse-postcomment pob left)
  445.   (define lame (cgol:sxop-lame pob))
  446.   (if lame (lame))
  447.   (cgol:advance)            ;past this token
  448.   left)
  449. (define (cgol:parse-postfix pob left)
  450.   (define lame (cgol:sxop-lame pob))
  451.   (cgol:advance)            ;past this token
  452.   (call-or-list1 lame left))
  453. (define (cgol:parse-infix pob left)
  454.   (define lame (cgol:sxop-lame pob))
  455.   (cgol:advance)
  456.   (cond ((cgol:at-delim?)
  457.      (cgol:warn 'expression-missing)
  458.      (call-or-list2 lame left '?))
  459.     (else
  460.      (call-or-list2 lame left (cgol:parse (cgol:sxop-rbp pob))))))
  461. (define (cgol:parse-nary pob left)
  462.   (define self cgol:token)
  463.   (define lame (cgol:sxop-lame pob))
  464.   (cgol:advance)
  465.   (cond ((cgol:at-delim?)
  466.      (cgol:warn 'expression-missing)
  467.      (call-or-list2 lame left '?))
  468.     (else
  469.      (apply-or-cons
  470.       lame (cons left (cgol:parse-list self (cgol:sxop-rbp pob)))))))
  471.  
  472. (define (cgol:trace)
  473.   (trace cgol:top-parse cgol:parse-delimited cgol:parse-list cgol:parse))
  474. (define (cgol:untrace)
  475.   (untrace cgol:top-parse cgol:parse-delimited cgol:parse-list cgol:parse))
  476.