PageRenderTime 1002ms CodeModel.GetById 19ms RepoModel.GetById 54ms app.codeStats 1ms

/parsec.ss

http://github.com/yinwang0/ydiff
Scheme | 1046 lines | 645 code | 269 blank | 132 comment | 1 complexity | 1bdd78ec6e37658f186985ab25e059d3 MD5 | raw file
Possible License(s): GPL-3.0
  1. ;; ydiff - a language-aware tool for comparing programs
  2. ;; Copyright (C) 2011 Yin Wang (yinwang0@gmail.com)
  3. ;; This program is free software: you can redistribute it and/or modify
  4. ;; it under the terms of the GNU General Public License as published by
  5. ;; the Free Software Foundation, either version 3 of the License, or
  6. ;; (at your option) any later version.
  7. ;; This program is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  10. ;; GNU General Public License for more details.
  11. ;; You should have received a copy of the GNU General Public License
  12. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  13. (load "utils.ss")
  14. (define *left-recur-detection* #f)
  15. ;-------------------------------------------------------------
  16. ; parser combinator library
  17. ;-------------------------------------------------------------
  18. ;; s-expression settings
  19. ;; please override for other languages.
  20. (define *delims* (list "(" ")" "[" "]" "{" "}" "'" "`" ","))
  21. (define *line-comment* (list ";"))
  22. (define *comment-start* "")
  23. (define *comment-end* "")
  24. (define *operators* '())
  25. (define *quotation-marks* '(#\" #\'))
  26. (define *lisp-char* (list "#\\" "?\\"))
  27. (define *significant-whitespaces* '())
  28. ;-------------------------------------------------------------
  29. ; data types
  30. ;-------------------------------------------------------------
  31. (struct Node (start end) #:transparent)
  32. (struct Expr Node (type elts) #:transparent)
  33. (struct Token Node (text) #:transparent)
  34. (struct Comment Node (text) #:transparent)
  35. (struct Str Node (text) #:transparent)
  36. (struct Char Node (text) #:transparent)
  37. (struct Newline Node () #:transparent)
  38. (struct Phantom Node () #:transparent)
  39. (define node-type
  40. (lambda (node)
  41. (and (Expr? node) (Expr-type node))))
  42. (define get-start
  43. (lambda (node)
  44. (Node-start node)))
  45. (define get-end
  46. (lambda (node)
  47. (Node-end node)))
  48. (define get-symbol
  49. (lambda (node)
  50. (cond
  51. [(Token? node)
  52. (string->symbol (Token-text node))]
  53. [else #f])))
  54. (define get-tag
  55. (lambda (e tag)
  56. (let ([matches (filter (lambda (x)
  57. (and (Expr? x)
  58. (eq? (Expr-type x) tag)))
  59. (Expr-elts e))])
  60. (cond
  61. [(null? matches) #f]
  62. [else (car matches)]))))
  63. (define match-tags
  64. (lambda (e tags)
  65. (cond
  66. [(not (Expr? e)) #f]
  67. [(null? tags) e]
  68. [else
  69. (match-tags (get-tag e (car tags)) (cdr tags))])))
  70. ;-------------------------------------------------------------
  71. ; scanner
  72. ;-------------------------------------------------------------
  73. (define whitespace? char-whitespace?)
  74. (define alpha? char-alphabetic?)
  75. (define digit? char-numeric?)
  76. ; Is char c a delimeter?
  77. (define delim?
  78. (lambda (c)
  79. (member (char->string c) *delims*)))
  80. (define id?
  81. (lambda (s)
  82. (cond
  83. [(= 0 (string-length s)) #f]
  84. [(or (alpha? (string-ref s 0))
  85. (eq? #\_ (string-ref s 0)))
  86. (let loop ([i 1])
  87. (cond
  88. [(>= i (string-length s)) #t]
  89. [else
  90. (let ([c (string-ref s i)])
  91. (cond
  92. [(alpha? c) (loop (add1 i))]
  93. [(digit? c) (loop (add1 i))]
  94. [(char=? c #\_) (loop (add1 i))]
  95. [else #f]))]))]
  96. [else #f])))
  97. (define numeral?
  98. (lambda (s)
  99. (cond
  100. [(= 0 (string-length s)) #f]
  101. [(digit? (string-ref s 0)) #t
  102. ;; (let loop ([i 1])
  103. ;; (cond
  104. ;; [(>= i (string-length s)) #t]
  105. ;; [else
  106. ;; (let ([c (string-ref s i)])
  107. ;; (cond
  108. ;; [(digit? c) (loop (add1 i))]
  109. ;; [(char=? c #\.) (loop (add1 i))]
  110. ;; [else #f]))]))
  111. ]
  112. [else #f])))
  113. (define start-with
  114. (lambda (s start prefix)
  115. (let* ([prefix-str (if (char? prefix)
  116. (char->string prefix)
  117. prefix)]
  118. [len (string-length prefix-str)])
  119. (cond
  120. [(= len 0) #f]
  121. [(< (string-length s) (+ start len)) #f]
  122. [(string=? (substring s start (+ start len)) prefix-str)
  123. prefix]
  124. [else #f]))))
  125. (define start-with-one-of
  126. (lambda (s start prefixes)
  127. (cond
  128. [(null? prefixes) #f]
  129. [(start-with s start (car prefixes))
  130. (car prefixes)]
  131. [else
  132. (start-with-one-of s start (cdr prefixes))])))
  133. ; (start-with-one-of "+>>=" 0 (list ">" #\+))
  134. (define find-next
  135. (lambda (s start pred)
  136. (cond
  137. [(<= (string-length s) start) #f]
  138. [(pred s start) start]
  139. [else
  140. (find-next s (add1 start) pred)])))
  141. ; Find the first delim that match the start of s
  142. (define find-delim
  143. (lambda (s start)
  144. (start-with-one-of s start *delims*)))
  145. (define find-operator
  146. (lambda (s start)
  147. (start-with-one-of s start *operators*)))
  148. ; (find-operator ">> x" 0)
  149. (define scan
  150. (lambda (s)
  151. (define scan1
  152. (lambda (s start)
  153. (cond
  154. [(= start (string-length s)) (values 'eof start)]
  155. [(start-with-one-of s start *significant-whitespaces*)
  156. (values (Newline start (add1 start)) (add1 start))]
  157. [(whitespace? (string-ref s start))
  158. (scan1 s (add1 start))]
  159. [(start-with-one-of s start *line-comment*) ; line comment
  160. (let ([line-end (find-next s start
  161. (lambda (s start)
  162. (eq? (string-ref s start) #\newline)))])
  163. (values (Comment start (add1 line-end) (substring s start line-end))
  164. line-end))]
  165. [(start-with s start *comment-start*) ; block comment
  166. (let* ([line-end (find-next s start
  167. (lambda (s start)
  168. (start-with s start *comment-end*)))]
  169. [end (+ line-end (string-length *comment-end*))])
  170. (values (Comment start end (substring s start end)) end))]
  171. [(find-delim s start) =>
  172. (lambda (delim)
  173. (let ([end (+ start (string-length delim))])
  174. (values (Token start end delim) end)))]
  175. [(find-operator s start) =>
  176. (lambda (op)
  177. (let ([end (+ start (string-length op))])
  178. (values (Token start end op) end)))]
  179. [(start-with-one-of s start *quotation-marks*) ; string
  180. (let ([reg-match (or (regexp-match (regexp "^\"(\\\\.|[^\"])*\"")
  181. s start)
  182. (regexp-match (regexp "^\'(\\\\.|[^\'])*\'")
  183. s start))])
  184. (cond
  185. [(not reg-match)
  186. (fatal 'scan "string match error")]
  187. [else
  188. (let* ([len (string-length (car reg-match))]
  189. [end (+ start len)])
  190. (values (Str start end (car reg-match)) end))]))]
  191. ;; => (lambda (q) (scan-string s start q))
  192. [(start-with-one-of s start *lisp-char*) ; scheme/elisp char
  193. (cond
  194. [(<= (string-length s) (+ 2 start))
  195. (error 'scan-string "reached EOF while scanning char")]
  196. [else
  197. (let ([end
  198. (let loop ([end (+ 3 start)])
  199. (cond
  200. [(or (whitespace? (string-ref s end))
  201. (delim? (string-ref s end)))
  202. end]
  203. [else (loop (add1 end))]))])
  204. (values (Char start end (string-ref s (sub1 end))) end))])]
  205. [else ; identifier or number
  206. (let loop ([pos start] [chars '()])
  207. (cond
  208. [(or (<= (string-length s) pos)
  209. (whitespace? (string-ref s pos))
  210. (find-delim s pos)
  211. (find-operator s pos))
  212. (let ([text (list->string (reverse chars))])
  213. (values (Token start pos text) pos))]
  214. [else
  215. (loop (add1 pos) (cons (string-ref s pos) chars))]))])))
  216. (let loop ([start 0] [toks '()])
  217. (letv ([(tok newstart) (scan1 s start)])
  218. (cond
  219. [(eq? tok 'eof)
  220. (reverse toks)]
  221. [else
  222. (loop newstart (cons tok toks))])))))
  223. ;-------------------------------------------------------------
  224. ; parser
  225. ;-------------------------------------------------------------
  226. (define onstack?
  227. (lambda (u v stk)
  228. (let loop ([stk stk] [trace '()])
  229. (cond
  230. [(null? stk) #f]
  231. [(and (eq? u (car (car stk)))
  232. (eq? v (cdr (car stk))))
  233. (reverse (cons (car stk) trace))]
  234. [else
  235. (loop (cdr stk) (cons (car stk) trace))]))))
  236. (define ext
  237. (lambda (u v stk)
  238. (cond
  239. [(not *left-recur-detection*) stk]
  240. [else
  241. (cons (cons u v) stk)])))
  242. (define stack->string
  243. (lambda (stk)
  244. (let ([ps (map
  245. (lambda (x) (format "~a" (car x)))
  246. stk)])
  247. (string-join ps "\n"))))
  248. ; (display (stack->string (onstack? 'x 'y '((u . v) (x . y) (w . t)))))
  249. ;; apply parser on toks, check for left-recurson if
  250. ;; *left-recur-detection* is enabled.
  251. (define apply-check
  252. (lambda (parser toks stk ctx)
  253. (cond
  254. [(and *left-recur-detection*
  255. (onstack? parser toks stk))
  256. => (lambda (t)
  257. (fatal 'apply-check
  258. "left-recursion detected \n"
  259. "parser: " parser "\n"
  260. "start token: " (car toks) "\n"
  261. "stack trace: " (stack->string t)))]
  262. [else
  263. ((parser) toks (ext parser toks stk) ctx)])))
  264. ;------------------ parser combinators --------------------
  265. (define @seq
  266. (lambda ps
  267. (lambda ()
  268. (lambda (toks stk ctx)
  269. (let loop ([ps ps] [toks toks] [nodes '()])
  270. (cond
  271. [(null? ps)
  272. (values (apply append (reverse nodes)) toks)]
  273. [else
  274. (letv ([(t r) (apply-check (car ps) toks stk ctx)])
  275. (cond
  276. [(not t)
  277. (values #f #f)]
  278. [else
  279. (loop (cdr ps) r (cons t nodes))]))]))))))
  280. ;; removes phantoms
  281. (define @...
  282. (lambda ps
  283. (let ([parser ((apply @seq ps))])
  284. (lambda ()
  285. (lambda (toks stk ctx)
  286. (letv ([(t r) (parser toks stk ctx)])
  287. (cond
  288. [(not t) (values #f #f)]
  289. [else
  290. (values (filter (negate Phantom?) t) r)])))))))
  291. ; (((@seq)) (scan "ok"))
  292. (define @or
  293. (lambda ps
  294. (lambda ()
  295. (lambda (toks stk ctx)
  296. (let loop ([ps ps])
  297. (cond
  298. [(null? ps)
  299. (values #f #f)]
  300. [else
  301. (letv ([(t r) (apply-check (car ps) toks stk ctx)])
  302. (cond
  303. [(not t)
  304. (loop (cdr ps))]
  305. [else
  306. (values t r)]))]))))))
  307. ; (((@or ($$ "foo") ($$ "bar"))) (scan "bar foo"))
  308. (define @=
  309. (lambda (type . ps)
  310. (let ([parser ((apply @seq ps))])
  311. (lambda ()
  312. (lambda (toks stk ctx)
  313. (letv ([(t r) (parser toks stk ctx)])
  314. (cond
  315. [(not t) (values #f #f)]
  316. [(not type)
  317. (values (filter (negate Phantom?) t) r)]
  318. [(null? t)
  319. (values (list (Expr (get-start (car toks))
  320. (get-start (car toks))
  321. type '()))
  322. r)]
  323. [else
  324. (values (list (Expr (get-start (car t))
  325. (get-end (last t))
  326. type
  327. (filter (negate Phantom?) t)))
  328. r)])))))))
  329. (define @*
  330. (lambda ps
  331. (let ([parser ((apply @... ps))])
  332. (lambda ()
  333. (lambda (toks stk ctx)
  334. (let loop ([toks toks] [nodes '()])
  335. (cond
  336. [(null? toks)
  337. (values (apply append (reverse nodes)) '())]
  338. [else
  339. (letv ([(t r) (parser toks stk ctx)])
  340. (cond
  341. [(not t)
  342. (values (apply append (reverse nodes)) toks)]
  343. [else
  344. (loop r (cons t nodes))]))])))))))
  345. ; ($eval (@* ($$ "ok")) (scan "ok ok ok"))
  346. ;; similar to @*, but takes only one parser and will not
  347. ;; make a sequence by invoking @seq
  348. (define @*^
  349. (lambda (p)
  350. (lambda ()
  351. (lambda (toks stk ctx)
  352. (let loop ([toks toks] [nodes '()])
  353. (cond
  354. [(null? toks)
  355. (values (apply append (reverse nodes)) '())]
  356. [else
  357. (letv ([(t r) ((p) toks stk ctx)])
  358. (cond
  359. [(not t)
  360. (values (apply append (reverse nodes)) toks)]
  361. [else
  362. (loop r (cons t nodes))]))]))))))
  363. (define @+
  364. (lambda (p)
  365. (@... p (@* p))))
  366. ; (((@+ ($$ "ok"))) (scan "ok ok ok"))
  367. (define @?
  368. (lambda ps
  369. (@or (apply @... ps) $none)))
  370. ; (((@? ($$ "x"))) (scan "x y z"))
  371. ;; negation - will fail if ps parses successfully.
  372. (define @!
  373. (lambda ps
  374. (let ([parser ((apply @... ps))])
  375. (lambda ()
  376. (lambda (toks stk ctx)
  377. (letv ([(t r) (parser toks stk ctx)])
  378. (cond
  379. [(not t) (values (list (car toks)) (cdr toks))]
  380. [else (values #f #f)])))))))
  381. ;; similar to @!, but takes only one parser and will not
  382. ;; make a sequence by invoking @seq
  383. (define @!^
  384. (lambda (p)
  385. (lambda ()
  386. (lambda (toks stk ctx)
  387. (letv ([(t r) ((p) toks stk ctx)])
  388. (cond
  389. [(not t) (values (list (car toks)) (cdr toks))]
  390. [else (values #f #f)]))))))
  391. (define @and
  392. (lambda ps
  393. (lambda ()
  394. (lambda (toks stk ctx)
  395. (let loop ([ps ps] [res '()])
  396. (cond
  397. [(null? ps)
  398. (let ([r1 (car res)])
  399. (values (car r1) (cadr r1)))]
  400. [else
  401. (letv ([(t r) (apply-check (car ps) toks stk ctx)])
  402. (cond
  403. [(not t)
  404. (values #f #f)]
  405. [else
  406. (loop (cdr ps) (cons (list t r) res))]))]))))))
  407. ; (((@and (@or ($$ "[") ($$ "{")) (@! ($$ "{")))) (scan "["))
  408. ;; parses the parsers ps normally, but "globs" the parses and doesn't
  409. ;; put them into the output.
  410. (define $glob
  411. (lambda ps
  412. (let ([parser ((apply @... ps))])
  413. (lambda ()
  414. (lambda (toks stk ctx)
  415. (letv ([(t r) (parser toks stk ctx)])
  416. (cond
  417. [(not t) (values #f #f)]
  418. [else
  419. (values '() r)])))))))
  420. ; (($glob ($$ "foo")) (scan "foo bar"))
  421. ;; similar to $glob, but takes only one parser and will not
  422. ;; make a sequence by invoking @seq
  423. (define $glob^
  424. (lambda (p)
  425. (lambda ()
  426. (lambda (toks stk ctx)
  427. (letv ([(t r) ((p) toks stk ctx)])
  428. (cond
  429. [(not t) (values #f #f)]
  430. [else
  431. (values '() r)]))))))
  432. ;; A phantom is something that takes space but invisible. It is useful
  433. ;; for something whose position is important, but is meaningless to
  434. ;; show up in the AST. It is used mostly for delimeters. $phantom is
  435. ;; seldom used directly. The helper @~ creates a phantom from strings.
  436. (define $phantom
  437. (lambda ps
  438. (let ([parser ((apply @... ps))])
  439. (lambda ()
  440. (lambda (toks stk ctx)
  441. (letv ([(t r) (parser toks stk ctx)])
  442. (cond
  443. [(not t) (values #f #f)]
  444. [else
  445. (cond
  446. [(null? t)
  447. (values '() r)]
  448. [else
  449. (values (list (Phantom (get-start (car t))
  450. (get-end (last t))))
  451. r)])])))))))
  452. ;------------------------ parsers ---------------------------
  453. (define $fail
  454. (lambda ()
  455. (lambda (toks stk ctx)
  456. (values #f #f))))
  457. (define $none
  458. (lambda ()
  459. (lambda (toks stk ctx)
  460. (values '() toks))))
  461. ;; succeeds if the predicate 'proc' returns true for the first token.
  462. (define $pred
  463. (lambda (proc)
  464. (lambda ()
  465. (lambda (toks stk ctx)
  466. (cond
  467. [(null? toks) (values #f #f)]
  468. [(proc (car toks))
  469. (values (list (car toks)) (cdr toks))]
  470. [else
  471. (values #f #f)])))))
  472. (define $eof
  473. ($glob ($pred (lambda (t) (eq? t 'eof)))))
  474. ;; literal parser for tokens. for example ($$ "for")
  475. (define $$
  476. (lambda (s)
  477. ($pred
  478. (lambda (x)
  479. (and (Token? x) (string=? (Token-text x) s))))))
  480. (define @_
  481. (lambda (s)
  482. ($glob ($$ s))))
  483. (define @~
  484. (lambda (s)
  485. ($phantom ($$ s))))
  486. (define join
  487. (lambda (ps sep)
  488. (cond
  489. [(null? (cdr ps)) ps]
  490. [else
  491. (cons (car ps) (cons sep (join (cdr ps) sep)))])))
  492. ;; a list of parser p separated by sep
  493. (define @.@
  494. (lambda (p sep)
  495. (@... p (@* (@... sep p)))))
  496. ;; ($eval (@.@ ($$ "foo") ($$ ","))
  497. ;; (scan "foo, foo, foo"))
  498. ;-------------------------------------------------------------
  499. ; expression parser combinators
  500. ;-------------------------------------------------------------
  501. ;; helper for constructing left-associative infix expression
  502. (define constr-exp-l
  503. (lambda (type fields)
  504. (let loop ([fields (cdr fields)] [ret (car fields)])
  505. (cond
  506. [(null? fields) ret]
  507. [else
  508. (let ([e (Expr (get-start ret)
  509. (get-end (cadr fields))
  510. type (list ret (car fields) (cadr fields)))])
  511. (loop (cddr fields) e))]))))
  512. ;; helper for constructing right-associative infix expression
  513. (define constr-exp-r
  514. (lambda (type fields)
  515. (let ([fields (reverse fields)])
  516. (let loop ([fields (cdr fields)] [ret (car fields)])
  517. (cond
  518. [(null? fields) ret]
  519. [else
  520. (let ([e (Expr (get-start (cadr fields))
  521. (get-end ret)
  522. type (list (cadr fields) (car fields) ret))])
  523. (loop (cddr fields) e))])))))
  524. ;; helper for creating infix operator parser. used by @infix-left and
  525. ;; @infix-right
  526. (define @infix
  527. (lambda (type p op associativity)
  528. (lambda ()
  529. (lambda (toks stk ctx)
  530. (let loop ([rest toks] [ret '()])
  531. (letv ([(tp rp) (((@seq p)) rest stk ctx)])
  532. (cond
  533. [(not tp)
  534. (cond
  535. [(< (length ret) 3)
  536. (values #f #f)]
  537. [else
  538. (let ([fields (reverse (cdr ret))]
  539. [constr (if (eq? associativity 'left)
  540. constr-exp-l
  541. constr-exp-r)])
  542. (values (list (constr type fields))
  543. (cons (car ret) rest)))])]
  544. [else
  545. (letv ([(top rop) (((@seq op)) rp stk ctx)])
  546. (cond
  547. [(not top)
  548. (cond
  549. [(< (length ret) 2)
  550. (values #f #f)]
  551. [else
  552. (let ([fields (reverse (append tp ret))]
  553. [constr (if (eq? associativity 'left)
  554. constr-exp-l
  555. constr-exp-r)])
  556. (values (list (constr type fields))
  557. rp))])]
  558. [else
  559. (loop rop (append (append top tp) ret))]))])))))))
  560. (define @infix-left
  561. (lambda (type p op)
  562. (@infix type p op 'left)))
  563. (define @infix-right
  564. (lambda (type p op)
  565. (@infix type p op 'right)))
  566. ;; ($eval (@infix-right 'binop $multiplicative-expression $additive-operator)
  567. ;; (scan "x + y + z"))
  568. (define @postfix
  569. (lambda (type p op)
  570. (lambda ()
  571. (lambda (toks stk ctx)
  572. (letv ([(t r) (((@... p (@+ op))) toks stk ctx)])
  573. (cond
  574. [(not t)
  575. (values #f #f)]
  576. [else
  577. (values (list (make-postfix type t)) r)]))))))
  578. ;; ($eval (@postfix 'ok ($$ "foo") (@= 'bar ($$ "bar")) 'ok)
  579. ;; (scan "foo bar bar"))
  580. (define make-postfix
  581. (lambda (type ls)
  582. (let loop ([ls (cdr ls)] [ret (car ls)])
  583. (cond
  584. [(null? ls) ret]
  585. [else
  586. (let ([e (Expr (get-start ret)
  587. (get-end (car ls))
  588. type
  589. (list ret (car ls)))])
  590. (loop (cdr ls) e))]))))
  591. (define @prefix
  592. (lambda (type p op)
  593. (lambda ()
  594. (lambda (toks stk ctx)
  595. (letv ([(t r) (((@... (@+ op) p)) toks stk ctx)])
  596. (cond
  597. [(not t)
  598. (values #f #f)]
  599. [else
  600. (values (list (make-prefix type t)) r)]))))))
  601. (define make-prefix
  602. (lambda (type ls)
  603. (cond
  604. [(null? (cdr ls)) (car ls)]
  605. [else
  606. (let ([tail (make-prefix type (cdr ls))])
  607. (Expr (get-start (car ls))
  608. (get-end tail)
  609. type
  610. (list (car ls) tail)))])))
  611. ;; ($eval (@prefix 'prefix $primary-expression $prefix-operator)
  612. ;; (scan "-1"))
  613. ;-------------------------------------------------------------
  614. ; syntactic extensions
  615. ;-------------------------------------------------------------
  616. (define *parse-hash* (make-hasheq))
  617. ;; define an unnamed parser
  618. (define-syntax ::
  619. (syntax-rules ()
  620. [(_ name expr)
  621. (define name
  622. (lambda ()
  623. (lambda (toks stk ctx)
  624. (cond
  625. [(hash-get *parse-hash* name toks)
  626. => (lambda (p)
  627. (values (car p) (cdr p)))]
  628. [else
  629. (letv ([(t r) ((expr) toks stk ctx)])
  630. (hash-put! *parse-hash* name toks (cons t r))
  631. (values t r))]))))]))
  632. ;; define a named parser
  633. (define-syntax ::=
  634. (syntax-rules ()
  635. [(_ name type expr ...)
  636. (define name
  637. (cond
  638. [(symbol? type)
  639. (lambda ()
  640. (lambda (toks stk ctx)
  641. (cond
  642. [(hash-get *parse-hash* name toks)
  643. => (lambda (p)
  644. (values (car p) (cdr p)))]
  645. [else
  646. (letv ([parser (@= type expr ...)]
  647. [(t r) ((parser) toks stk (cons 'name ctx))])
  648. (hash-put! *parse-hash* name toks (cons t r))
  649. (values t r))])))]
  650. [else
  651. (fatal '::= "type must be a symbol, but got: " type)]))]))
  652. ;;---------------- context sensitive parsing ----------------
  653. ;; succeed only in certain context
  654. (define-syntax ::?
  655. (syntax-rules ()
  656. [(_ name effective-ctx expr)
  657. (define name
  658. (lambda ()
  659. (lambda (toks stk ctx)
  660. (cond
  661. [(not (memq 'effective-ctx ctx))
  662. (values #f #f)]
  663. [(hash-get *parse-hash* name toks)
  664. => (lambda (p)
  665. (values (car p) (cdr p)))]
  666. [else
  667. (letv ([(t r) ((expr) toks stk (cons 'name ctx))])
  668. (hash-put! *parse-hash* name toks t r)
  669. (values t r))]))))]))
  670. ;; succeed only in a context that is NOT avoid-ctx
  671. (define-syntax ::!
  672. (syntax-rules ()
  673. [(_ name avoid-ctx expr)
  674. (define name
  675. (lambda ()
  676. (lambda (toks stk ctx)
  677. (cond
  678. [(memq 'avoid-ctx ctx)
  679. (values #f #f)]
  680. [(hash-get *parse-hash* name toks)
  681. => (lambda (p)
  682. (values (car p) (cdr p)))]
  683. [else
  684. (letv ([(t r) ((expr) toks stk (cons 'name ctx))])
  685. (hash-put! *parse-hash* name toks t r)
  686. (values t r))]))))]))
  687. ;; EXAMPLES:
  688. ;; (::= $foo
  689. ;; (@= 'foo (@... $bar ($$ "foo"))))
  690. ;; (::? $bar $baz
  691. ;; ($$ "bar"))
  692. ;; (::= $baz
  693. ;; (@= 'baz (@... $bar ($$ "baz"))))
  694. ;; ($eval $bar (scan "bar foo"))
  695. ;; ($eval $foo (scan "bar foo"))
  696. ;; ($eval $baz (scan "bar baz")) ; only this one succeeds
  697. ;; (::! $avoid-foo $foo
  698. ;; (@= 'avoid-foo ($$ "avoid-foo")))
  699. ;; (::= $foo
  700. ;; (@= 'foo (@... $avoid-foo ($$ "foo"))))
  701. ;; (::= $not-foo
  702. ;; (@= 'not-foo (@... $avoid-foo ($$ "not-foo"))))
  703. ;; ($eval $foo (scan "avoid-foo foo")) ; $avoid-foo fails only in foo
  704. ;; ($eval $not-foo (scan "avoid-foo not-foo"))
  705. ;; execuate parser p on the input tokens
  706. (define $eval
  707. (lambda (p toks)
  708. (set! *parse-hash* (make-hasheq))
  709. (letv ([(t r) ((p) toks '() '())])
  710. (set! *parse-hash* (make-hasheq))
  711. (values t r))))
  712. (define parse1
  713. (lambda (p s)
  714. (letv ([(t r) ($eval p (filter (lambda (x) (not (Comment? x)))
  715. (scan s)))])
  716. t)))
  717. ;-------------------------------------------------------------
  718. ; testing facilities
  719. ;-------------------------------------------------------------
  720. (define test-string
  721. (lambda (s)
  722. (letv ([(t r) ($eval $program
  723. (filter (lambda (x) (not (Comment? x)))
  724. (scan s)))])
  725. (cond
  726. [(null? r) #t]
  727. [(not r) #f]
  728. [else (car r)]))))
  729. (define test-file
  730. (lambda files
  731. (define test1
  732. (lambda (file)
  733. (printf "testing file: ~a ... " file)
  734. (let ([start (current-seconds)])
  735. (flush-output)
  736. (let ([res (test-string (read-file file))])
  737. (cond
  738. [(eq? #t res)
  739. (printf "succeed.~ntime used: ~a seconds~n"
  740. (- (current-seconds) start))
  741. (flush-output)]
  742. [else
  743. (printf "failed at token: ~a~n" res)
  744. (flush-output)])))))
  745. (for-each test1 files)))
  746. ;-------------------------- examples ---------------------------
  747. ; a parser for s-expressions
  748. (:: $open
  749. (@or (@~ "(") (@~ "[")))
  750. (:: $close
  751. (@or (@~ ")") (@~ "]")))
  752. (:: $non-parens
  753. (@and (@! $open) (@! $close)))
  754. (::= $parens 'sexp
  755. (@seq $open (@* $sexp) $close))
  756. (:: $sexp
  757. (@+ (@or $parens $non-parens)))
  758. (:: $program $sexp)
  759. (define parse-sexp
  760. (lambda (s)
  761. (first-val ($eval $program (scan s)))))
  762. ;; (parse-sexp "(lambda (x) x)")
  763. ;; (parse-sexp (read-file "paredit20.el"))
  764. ;;-------------- direct left recursion test ---------------
  765. ;;
  766. ;; (::= $left 'left
  767. ;; (@or (@seq $left ($$ "ok"))
  768. ;; ($$ "ok")))
  769. ;; ($eval $left (scan "ok"))
  770. ;;---------- indirect left-recursion -------------
  771. ;;
  772. ;; (::= $left1 'left1
  773. ;; (@seq $left2 ($$ "ok")))
  774. ;; (::= $left2 'left2
  775. ;; (@or (@seq $left1 ($$ "ok"))
  776. ;; ($$ "ok")))
  777. ;; ($eval $left1 (scan "ok ok"))