API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Jan 25th, 2020
263
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 24.30 KB | None | 0 0
raw download clone embed print report
  1.  
  2. ;;----------------------------------------------------------------------
  3. ;; quasiquote, and, or
  4.  
  5. (module qq-and-or '#%kernel
  6. (#%require (for-syntax "stx.rkt" '#%kernel))
  7.  
  8. (define-syntaxes (let*-values let let* letrec)
  9. (let-values ([(lambda-stx) (quote-syntax lambda-stx)]
  10. [(letrec-values-stx) (quote-syntax letrec-values)]
  11. [(check-for-duplicates)
  12. (lambda (new-bindings sel stx)
  13. (define-values (id-in-list?)
  14. (lambda (id l)
  15. (if (null? l)
  16. #f
  17. (if (bound-identifier=? id (car l))
  18. #t
  19. (id-in-list? id (cdr l))))))
  20. (if ((length new-bindings) . > . 5)
  21. (let-values ([(ht) (make-hasheq)])
  22. (letrec-values ([(check) (lambda (l)
  23. (if (null? l)
  24. (void)
  25. (let-values ([(id) (sel (car l))])
  26. (let-values ([(idl) (hash-ref ht (syntax-e id) null)])
  27. (if (id-in-list? id idl)
  28. (raise-syntax-error
  29. #f
  30. "duplicate identifier"
  31. stx
  32. id)
  33. (begin
  34. (hash-set! ht (syntax-e id) (cons id idl))
  35. (check (cdr l))))))))])
  36. (check new-bindings)))
  37. (letrec-values ([(check) (lambda (l accum)
  38. (if (null? l)
  39. (void)
  40. (let-values ([(id) (sel (car l))])
  41. (if (id-in-list? id accum)
  42. (raise-syntax-error
  43. #f
  44. "duplicate identifier"
  45. stx
  46. id)
  47. (check (cdr l) (cons id accum))))))])
  48. (check new-bindings null))))])
  49. (let-values ([(go)
  50. (lambda (stx named? star? target)
  51. (define-values (stx-cadr) (lambda (x) (stx-car (stx-cdr x))))
  52. (define-values (stx-2list?)
  53. (lambda (x)
  54. (if (stx-pair? x)
  55. (if (stx-pair? (stx-cdr x))
  56. (stx-null? (stx-cdr (stx-cdr x)))
  57. #f)
  58. #f)))
  59. (let-values ([(maybe-msg)
  60. (if (not (stx-list? stx))
  61. ""
  62. (let-values ([(tail1) (stx-cdr stx)])
  63. (if (stx-null? tail1)
  64. (if named?
  65. "(missing name or binding pairs)"
  66. "(missing binding pairs)")
  67. (if (stx-null? (stx-cdr tail1))
  68. (if named?
  69. "(missing binding pairs or body)"
  70. "(missing body)")
  71. (if named?
  72. (if (symbol? (syntax-e (stx-car tail1)))
  73. (if (stx-null? (stx-cdr (stx-cdr tail1)))
  74. "(missing body)"
  75. #f)
  76. #f)
  77. #f)))))])
  78. (if maybe-msg
  79. (raise-syntax-error #f (string-append "bad syntax " maybe-msg) stx)
  80. (void)))
  81. (let-values ([(name) (if named?
  82. (let-values ([(n) (stx-cadr stx)])
  83. (if (symbol? (syntax-e n))
  84. n
  85. #f))
  86. #f)])
  87. (let-values ([(bindings) (stx->list (stx-cadr (if name
  88. (stx-cdr stx)
  89. stx)))]
  90. [(body) (stx-cdr (stx-cdr (if name
  91. (stx-cdr stx)
  92. stx)))])
  93. (if (not bindings)
  94. (raise-syntax-error
  95. #f
  96. "bad syntax (not a sequence of identifier--expression bindings)"
  97. stx
  98. (stx-cadr stx))
  99. (let-values ([(new-bindings)
  100. (letrec-values ([(loop)
  101. (lambda (l)
  102. (if (null? l)
  103. null
  104. (let-values ([(binding) (car l)])
  105. (cons
  106. (if (stx-2list? binding)
  107. (if (symbol? (syntax-e (stx-car binding)))
  108. (if name
  109. (cons (stx-car binding)
  110. (stx-cadr binding))
  111. (datum->syntax
  112. lambda-stx
  113. (cons (cons (stx-car binding)
  114. null)
  115. (stx-cdr binding))
  116. binding))
  117. (raise-syntax-error
  118. #f
  119. "bad syntax (not an identifier)"
  120. stx
  121. (stx-car binding)))
  122. (raise-syntax-error
  123. #f
  124. "bad syntax (not an identifier and expression for a binding)"
  125. stx
  126. binding))
  127. (loop (cdr l))))))])
  128. (loop bindings))])
  129. (if star?
  130. (void)
  131. (check-for-duplicates new-bindings
  132. (if name
  133. car
  134. (lambda (v) (stx-car (stx-car v))))
  135. stx))
  136. (datum->syntax
  137. lambda-stx
  138. (if name
  139. (apply list
  140. (list
  141. (quote-syntax letrec-values)
  142. (list
  143. (list
  144. (list name)
  145. (list* (quote-syntax lambda)
  146. (apply list (map car new-bindings))
  147. body)))
  148. name)
  149. (map cdr new-bindings))
  150. (list* target
  151. new-bindings
  152. body))
  153. stx))))))])
  154. (values
  155. (lambda (stx)
  156. (define-values (bad-syntax)
  157. (lambda ()
  158. (raise-syntax-error #f "bad syntax" stx)))
  159. (define-values (l) (syntax->list stx))
  160. (if (not l) (bad-syntax) (void))
  161. (if ((length l) . < . 3) (bad-syntax) (void))
  162. (define-values (bindings) (syntax->list (cadr l)))
  163. (if (not bindings) (raise-syntax-error #f "bad syntax" stx (cadr l)) (void))
  164. (for-each (lambda (binding)
  165. (define-values (l) (syntax->list binding))
  166. (if (if (not l)
  167. #t
  168. (not (= 2 (length l))))
  169. (raise-syntax-error #f "bad syntax" stx binding)
  170. (void))
  171. (define-values (vars) (syntax->list (car l)))
  172. (if (not vars) (raise-syntax-error #f "bad syntax" stx (car l)) (void))
  173. (for-each (lambda (var)
  174. (if (not (symbol? (syntax-e var)))
  175. (raise-syntax-error
  176. #f
  177. "bad syntax (not an identifier)"
  178. stx
  179. var)
  180. (void)))
  181. vars)
  182. (check-for-duplicates vars values stx))
  183. bindings)
  184. (define-values (gen)
  185. (lambda (bindings nested?)
  186. (if (null? bindings)
  187. (if nested?
  188. (cddr l)
  189. (list* (quote-syntax let-values) '() (cddr l)))
  190. ((if nested? list values)
  191. (list* (quote-syntax let-values) (list (car bindings)) (gen (cdr bindings) #t))))))
  192. (datum->syntax #f (gen bindings #f) stx stx))
  193. (lambda (stx) (go stx #t #f (quote-syntax let-values)))
  194. (lambda (stx) (go stx #f #t (quote-syntax let*-values)))
  195. (lambda (stx) (go stx #f #f (quote-syntax letrec-values)))))))
  196.  
  197. (define-values (qq-append)
  198. (lambda (a b)
  199. (if (list? a)
  200. (append a b)
  201. (raise-argument-error 'unquote-splicing "list?" a))))
  202.  
  203. (define-syntaxes (quasiquote)
  204. (let-values ([(here) (quote-syntax here)] ; id with module bindings, but not lexical
  205. [(unquote-stx) (quote-syntax unquote)]
  206. [(unquote-splicing-stx) (quote-syntax unquote-splicing)])
  207. (lambda (in-form)
  208. (if (identifier? in-form)
  209. (raise-syntax-error #f "bad syntax" in-form)
  210. (void))
  211. (let-values
  212. (((form) (if (stx-pair? (stx-cdr in-form))
  213. (if (stx-null? (stx-cdr (stx-cdr in-form)))
  214. (stx-car (stx-cdr in-form))
  215. (raise-syntax-error #f "bad syntax" in-form))
  216. (raise-syntax-error #f "bad syntax" in-form)))
  217. ((normal)
  218. (lambda (x old)
  219. (if (eq? x old)
  220. (if (stx-null? x)
  221. (quote-syntax ())
  222. (list (quote-syntax quote) x))
  223. x)))
  224. ((apply-cons)
  225. (lambda (a d)
  226. (if (stx-null? d)
  227. (list (quote-syntax list) a)
  228. (if (if (pair? d)
  229. (if (free-identifier=? (quote-syntax list) (car d))
  230. #t
  231. (free-identifier=? (quote-syntax list*) (car d)))
  232. #f)
  233. (list* (car d) a (cdr d))
  234. (list (quote-syntax list*) a d))))))
  235. (datum->syntax
  236. here
  237. (normal
  238. (letrec-values
  239. (((qq)
  240. (lambda (x level)
  241. (let-values
  242. (((qq-list)
  243. (lambda (x level)
  244. (let-values
  245. (((old-first) (stx-car x)))
  246. (let-values
  247. (((old-second) (stx-cdr x)))
  248. (let-values
  249. (((first) (qq old-first level)))
  250. (let-values
  251. (((second) (qq old-second level)))
  252. (let-values
  253. ()
  254. (if (if (eq? first old-first)
  255. (eq? second old-second)
  256. #f)
  257. x
  258. (apply-cons
  259. (normal first old-first)
  260. (normal second old-second)))))))))))
  261. (if (stx-pair? x)
  262. (let-values
  263. (((first) (stx-car x)))
  264. (if (if (if (identifier? first)
  265. (free-identifier=? first unquote-stx)
  266. #f)
  267. (stx-list? x)
  268. #f)
  269. (let-values
  270. (((rest) (stx-cdr x)))
  271. (if (let-values
  272. (((g35) (not (stx-pair? rest))))
  273. (if g35 g35 (not (stx-null? (stx-cdr rest)))))
  274. (raise-syntax-error
  275. 'unquote
  276. "expects exactly one expression"
  277. in-form
  278. x)
  279. (void))
  280. (if (zero? level)
  281. (stx-car rest)
  282. (qq-list x (sub1 level))))
  283. (if (if (if (identifier? first)
  284. (free-identifier=? first (quote-syntax quasiquote))
  285. #f)
  286. (stx-list? x)
  287. #f)
  288. (qq-list x (add1 level))
  289. (if (if (if (identifier? first)
  290. (free-identifier=? first unquote-splicing-stx)
  291. #f)
  292. (stx-list? x)
  293. #f)
  294. (raise-syntax-error
  295. 'unquote-splicing
  296. "invalid context within quasiquote"
  297. in-form
  298. x)
  299. (if (if (stx-pair? first)
  300. (if (identifier? (stx-car first))
  301. (if (free-identifier=? (stx-car first)
  302. unquote-splicing-stx)
  303. (stx-list? first)
  304. #F)
  305. #f)
  306. #f)
  307. (let-values
  308. (((rest) (stx-cdr first)))
  309. (if (let-values
  310. (((g34) (not (stx-pair? rest))))
  311. (if g34
  312. g34
  313. (not (stx-null? (stx-cdr rest)))))
  314. (raise-syntax-error
  315. 'unquote
  316. "expects exactly one expression"
  317. in-form
  318. x)
  319. (void))
  320. (let-values
  321. (((uqsd) (stx-car rest))
  322. ((old-l) (stx-cdr x))
  323. ((l) (qq (stx-cdr x) level)))
  324. (if (zero? level)
  325. (let-values
  326. (((l) (normal l old-l)))
  327. (if (stx-null? l)
  328. uqsd
  329. (list (quote-syntax qq-append)
  330. uqsd l)))
  331. (let-values
  332. (((restx) (qq-list rest (sub1 level))))
  333. (let-values
  334. ()
  335. (if (if (eq? l old-l)
  336. (eq? restx rest)
  337. #f)
  338. x
  339. (apply-cons
  340. (apply-cons
  341. (quote-syntax (quote unquote-splicing))
  342. (normal restx rest))
  343. (normal l old-l))))))))
  344. (qq-list x level))))))
  345. (if (if (syntax? x)
  346. (vector? (syntax-e x))
  347. #f)
  348. (let-values
  349. (((l) (vector->list (syntax-e x))))
  350. ;; special case: disallow #(unquote <e>)
  351. (if (stx-pair? l)
  352. (let-values ([(first) (stx-car l)])
  353. (if (identifier? first)
  354. (if (free-identifier=? first unquote-stx)
  355. (raise-syntax-error
  356. 'unquote
  357. "invalid context within quasiquote"
  358. in-form
  359. first)
  360. (void))
  361. (void)))
  362. (void))
  363. (let-values
  364. (((l2) (qq l level)))
  365. (if (eq? l l2)
  366. x
  367. (list (quote-syntax list->vector) l2))))
  368. (if (if (syntax? x) (box? (syntax-e x)) #f)
  369. (let-values
  370. (((v) (unbox (syntax-e x))))
  371. (let-values
  372. (((qv) (qq v level)))
  373. (if (eq? v qv)
  374. x
  375. (list (quote-syntax box) qv))))
  376. (if (if (syntax? x)
  377. (if (struct? (syntax-e x))
  378. (prefab-struct-key (syntax-e x))
  379. #f)
  380. #f)
  381. ;; pre-fab struct
  382. (let-values
  383. (((l) (cdr (vector->list (struct->vector (syntax-e x))))))
  384. (let-values
  385. (((l2) (qq l level)))
  386. (if (eq? l l2)
  387. x
  388. (list (quote-syntax apply)
  389. (quote-syntax make-prefab-struct)
  390. (list (quote-syntax quote)
  391. (prefab-struct-key (syntax-e x)))
  392. l2))))
  393. ;; hash[eq[v]]
  394. (if (if (syntax? x)
  395. (hash? (syntax-e x))
  396. #f)
  397. (letrec-values
  398. (((qq-hash-assocs)
  399. (lambda (x level)
  400. (if (null? x)
  401. x
  402. (let-values
  403. (((pair) (car x)))
  404. (let-values ([(val)
  405. (qq (datum->syntax here (cdr pair)) level)]
  406. [(rest)
  407. (qq-hash-assocs (cdr x) level)])
  408. (if (if (eq? val (cdr pair))
  409. (eq? rest (cdr x))
  410. #f)
  411. x
  412. (apply-cons
  413. (list (quote-syntax list*)
  414. (list (quote-syntax quote)
  415. (datum->syntax here (car pair)))
  416. (if (eq? val (cdr pair))
  417. (list (quote-syntax quote)
  418. val)
  419. val))
  420. (if (eq? rest (cdr x))
  421. (list (quote-syntax quote)
  422. rest)
  423. rest)))))))))
  424. (let-values (((l0) (hash-map (syntax-e x) cons #t)))
  425. (let-values
  426. (((l) (qq-hash-assocs l0 level)))
  427. (if (eq? l0 l)
  428. x
  429. (list (if (hash-eq? (syntax-e x))
  430. (quote-syntax make-immutable-hasheq)
  431. (if (hash-eqv? (syntax-e x))
  432. (quote-syntax make-immutable-hasheqv)
  433. (quote-syntax make-immutable-hash)))
  434. l)))))
  435. x)))))))))
  436. (qq form 0))
  437. form)
  438. in-form)))))
  439.  
  440. (define-syntaxes (and)
  441. (let-values ([(here) (quote-syntax here)])
  442. (lambda (x)
  443. (if (not (stx-list? x))
  444. (raise-syntax-error #f "bad syntax" x)
  445. (void))
  446. (let-values ([(e) (stx-cdr x)])
  447. (if (stx-null? e)
  448. (quote-syntax #t)
  449. (if (if (stx-pair? e)
  450. (stx-null? (stx-cdr e))
  451. #t)
  452. (datum->syntax
  453. here
  454. (list (quote-syntax #%expression)
  455. (stx-car e))
  456. x)
  457. (datum->syntax
  458. here
  459. (list (quote-syntax if)
  460. (stx-car e)
  461. (cons (quote-syntax and)
  462. (stx-cdr e))
  463. (quote-syntax #f))
  464. x)))))))
  465.  
  466. (define-syntaxes (or)
  467. (let-values ([(here) (quote-syntax here)])
  468. (lambda (x)
  469. (if (identifier? x)
  470. (raise-syntax-error #f "bad syntax" x)
  471. (void))
  472. (let-values ([(e) (stx-cdr x)])
  473. (if (stx-null? e)
  474. (quote-syntax #f)
  475. (if (if (stx-pair? e)
  476. (stx-null? (stx-cdr e))
  477. #f)
  478. (datum->syntax
  479. here
  480. (list (quote-syntax #%expression)
  481. (stx-car e))
  482. x)
  483. (if (stx-list? e)
  484. (let-values ([(tmp) 'or-part])
  485. (datum->syntax
  486. here
  487. (list (quote-syntax let) (list
  488. (list
  489. tmp
  490. (stx-car e)))
  491. (list (quote-syntax if)
  492. tmp
  493. tmp
  494. (cons (quote-syntax or)
  495. (stx-cdr e))))
  496. x))
  497. (raise-syntax-error
  498. #f
  499. "bad syntax"
  500. x))))))))
  501.  
  502. (#%provide let*-values
  503. let let* letrec
  504. quasiquote and or))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!