mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-03 05:20:16 +02:00
Simplify the define-primitive-expander macro
* module/language/tree-il/primitives.scm (primitive-expander): (define-primitive-expander!): New helpers. (define-primitive-expander): Rewrite in terms of syntax-case. (error, make-vector, eqv?, equal?, call-with-prompt) (abort-to-prompt*, abort-to-prompt): Use new helper.
This commit is contained in:
Andy Wingo
parent
79a40cf717
commit
e7cfd6dbab
1 changed files with 90 additions and 118 deletions
|
|
@ -1,6 +1,6 @@
|
||||||
;;; open-coding primitive procedures
|
;;; open-coding primitive procedures
|
||||||
|
|
||||||
;; Copyright (C) 2009-2015, 2017-2018 Free Software Foundation, Inc.
|
;; Copyright (C) 2009-2015, 2017-2019 Free Software Foundation, Inc.
|
||||||
|
|
||||||
;;;; This library is free software; you can redistribute it and/or
|
;;;; This library is free software; you can redistribute it and/or
|
||||||
;;;; modify it under the terms of the GNU Lesser General Public
|
;;;; modify it under the terms of the GNU Lesser General Public
|
||||||
|
|
@ -331,58 +331,37 @@
|
||||||
(define (expand-primitives x)
|
(define (expand-primitives x)
|
||||||
(pre-order expand-primcall x))
|
(pre-order expand-primcall x))
|
||||||
|
|
||||||
;;; I actually did spend about 10 minutes trying to redo this with
|
(define-syntax-rule (define-primitive-expander! sym proc)
|
||||||
;;; syntax-rules. Patches appreciated.
|
(hashq-set! *primitive-expand-table* sym proc))
|
||||||
;;;
|
|
||||||
(define-macro (define-primitive-expander sym . clauses)
|
(define-syntax primitive-expander
|
||||||
(define (inline-args args)
|
(lambda (stx)
|
||||||
(let lp ((in args) (out '()))
|
(define (expand-args args)
|
||||||
(cond ((null? in) `(list ,@(reverse out)))
|
(syntax-case args ()
|
||||||
((symbol? in) `(cons* ,@(reverse out) ,in))
|
(() #''())
|
||||||
((pair? (car in))
|
((a . b) #`(cons #,(expand-expr #'a) #,(expand-args #'b)))
|
||||||
(lp (cdr in)
|
(a (expand-expr #'a))))
|
||||||
(cons (if (eq? (caar in) 'quote)
|
(define (expand-expr body)
|
||||||
`(make-const src ,@(cdar in))
|
(syntax-case body (quote)
|
||||||
`(make-primcall src ',(caar in)
|
(id (identifier? #'id) #'id)
|
||||||
,(inline-args (cdar in))))
|
((quote x) #'(make-const src 'x))
|
||||||
out)))
|
((op . args) #`(make-primcall src 'op #,(expand-args #'args)))
|
||||||
((symbol? (car in))
|
(x (self-evaluating? (syntax->datum #'x)) #'(make-const src x))))
|
||||||
;; assume it's locally bound
|
(define (match-clauses args+body)
|
||||||
(lp (cdr in) (cons (car in) out)))
|
(syntax-case args+body (if)
|
||||||
((self-evaluating? (car in))
|
(() '())
|
||||||
(lp (cdr in) (cons `(make-const src ,(car in)) out)))
|
((args body . args+body)
|
||||||
(else
|
(cons #`(args #,(expand-expr #'body))
|
||||||
(error "what what" (car in))))))
|
(match-clauses #'args+body)))))
|
||||||
(define (consequent exp)
|
(syntax-case stx ()
|
||||||
(cond
|
((_ args+body ...)
|
||||||
((pair? exp)
|
#`(lambda (src . args)
|
||||||
(pmatch exp
|
(match args
|
||||||
((if ,test ,then ,else)
|
#,@(match-clauses #'(args+body ...))
|
||||||
`(if ,test
|
(_ #f)))))))
|
||||||
,(consequent then)
|
|
||||||
,(consequent else)))
|
(define-syntax-rule (define-primitive-expander sym . clauses)
|
||||||
(else
|
(define-primitive-expander! 'sym (primitive-expander . clauses)))
|
||||||
`(make-primcall src ',(car exp)
|
|
||||||
,(inline-args (cdr exp))))))
|
|
||||||
((symbol? exp)
|
|
||||||
;; assume locally bound
|
|
||||||
exp)
|
|
||||||
((number? exp)
|
|
||||||
`(make-const src ,exp))
|
|
||||||
((not exp)
|
|
||||||
;; failed match
|
|
||||||
#f)
|
|
||||||
(else (error "bad consequent yall" exp))))
|
|
||||||
`(hashq-set! *primitive-expand-table*
|
|
||||||
',sym
|
|
||||||
(match-lambda*
|
|
||||||
,@(let lp ((in clauses) (out '()))
|
|
||||||
(if (null? in)
|
|
||||||
(reverse (cons '(_ #f) out))
|
|
||||||
(lp (cddr in)
|
|
||||||
(cons `((src . ,(car in))
|
|
||||||
,(consequent (cadr in)))
|
|
||||||
out)))))))
|
|
||||||
|
|
||||||
;; Oddly, scm-error is just an explicitly 5-argument `throw'. Weird.
|
;; Oddly, scm-error is just an explicitly 5-argument `throw'. Weird.
|
||||||
(define-primitive-expander scm-error (key who message args data)
|
(define-primitive-expander scm-error (key who message args data)
|
||||||
|
|
@ -391,35 +370,33 @@
|
||||||
(define (escape-format-directives str)
|
(define (escape-format-directives str)
|
||||||
(string-join (string-split str #\~) "~~"))
|
(string-join (string-split str #\~) "~~"))
|
||||||
|
|
||||||
(hashq-set!
|
(define-primitive-expander! 'error
|
||||||
*primitive-expand-table*
|
(match-lambda*
|
||||||
'error
|
((src)
|
||||||
(match-lambda*
|
(make-primcall src 'throw
|
||||||
((src)
|
(list (make-const src 'misc-error)
|
||||||
(make-primcall src 'throw
|
(make-const src #f)
|
||||||
(list (make-const src 'misc-error)
|
(make-const src "?")
|
||||||
(make-const src #f)
|
(make-const src #f)
|
||||||
(make-const src "?")
|
(make-const src #f))))
|
||||||
(make-const src #f)
|
((src ($ <const> src2 (? string? message)) . args)
|
||||||
(make-const src #f))))
|
(let ((msg (string-join (cons (escape-format-directives message)
|
||||||
((src ($ <const> src2 (? string? message)) . args)
|
(make-list (length args) "~S")))))
|
||||||
(let ((msg (string-join (cons (escape-format-directives message)
|
(make-primcall src 'throw
|
||||||
(make-list (length args) "~S")))))
|
(list (make-const src 'misc-error)
|
||||||
(make-primcall src 'throw
|
(make-const src #f)
|
||||||
(list (make-const src 'misc-error)
|
(make-const src2 msg)
|
||||||
(make-const src #f)
|
(make-primcall src 'list args)
|
||||||
(make-const src2 msg)
|
(make-const src #f)))))
|
||||||
(make-primcall src 'list args)
|
((src message . args)
|
||||||
(make-const src #f)))))
|
(let ((msg (string-join (cons "~A" (make-list (length args) "~S")))))
|
||||||
((src message . args)
|
(make-primcall src 'throw
|
||||||
(let ((msg (string-join (cons "~A" (make-list (length args) "~S")))))
|
(list (make-const src 'misc-error)
|
||||||
(make-primcall src 'throw
|
(make-const src #f)
|
||||||
(list (make-const src 'misc-error)
|
(make-const src msg)
|
||||||
(make-const src #f)
|
(make-const src "?")
|
||||||
(make-const src msg)
|
(make-primcall src 'list (cons message args))
|
||||||
(make-const src "?")
|
(make-const src #f)))))))
|
||||||
(make-primcall src 'list (cons message args))
|
|
||||||
(make-const src #f)))))))
|
|
||||||
|
|
||||||
(define-primitive-expander zero? (x)
|
(define-primitive-expander zero? (x)
|
||||||
(= x 0))
|
(= x 0))
|
||||||
|
|
@ -470,16 +447,14 @@
|
||||||
(x y) (logand x y)
|
(x y) (logand x y)
|
||||||
(x y z ... last) (logand (logand x y . z) last))
|
(x y z ... last) (logand (logand x y . z) last))
|
||||||
|
|
||||||
(hashq-set!
|
(define-primitive-expander! 'make-vector
|
||||||
*primitive-expand-table*
|
(match-lambda*
|
||||||
'make-vector
|
((src len)
|
||||||
(match-lambda*
|
(make-primcall src 'make-vector (list len (make-const src *unspecified*))))
|
||||||
((src len)
|
((src len init)
|
||||||
(make-primcall src 'make-vector (list len (make-const src *unspecified*))))
|
(make-primcall src 'make-vector (list len init)))
|
||||||
((src len init)
|
((src . args)
|
||||||
(make-primcall src 'make-vector (list len init)))
|
(make-call src (make-primitive-ref src 'make-vector) args))))
|
||||||
((src . args)
|
|
||||||
(make-call src (make-primitive-ref src 'make-vector) args))))
|
|
||||||
|
|
||||||
(define-primitive-expander caar (x) (car (car x)))
|
(define-primitive-expander caar (x) (car (car x)))
|
||||||
(define-primitive-expander cadr (x) (car (cdr x)))
|
(define-primitive-expander cadr (x) (car (cdr x)))
|
||||||
|
|
@ -593,8 +568,8 @@
|
||||||
(make-const src #f)))))))
|
(make-const src #f)))))))
|
||||||
|
|
||||||
(for-each (lambda (prim-name)
|
(for-each (lambda (prim-name)
|
||||||
(hashq-set! *primitive-expand-table* prim-name
|
(define-primitive-expander! prim-name
|
||||||
(chained-comparison-expander prim-name)))
|
(chained-comparison-expander prim-name)))
|
||||||
'(< > <= >= =))
|
'(< > <= >= =))
|
||||||
|
|
||||||
(define (character-comparison-expander char< <)
|
(define (character-comparison-expander char< <)
|
||||||
|
|
@ -607,8 +582,8 @@
|
||||||
|
|
||||||
(for-each (match-lambda
|
(for-each (match-lambda
|
||||||
((char< . <)
|
((char< . <)
|
||||||
(hashq-set! *primitive-expand-table* char<
|
(define-primitive-expander! char<
|
||||||
(character-comparison-expander char< <))))
|
(character-comparison-expander char< <))))
|
||||||
'((char<? . <)
|
'((char<? . <)
|
||||||
(char>? . >)
|
(char>? . >)
|
||||||
(char<=? . <=)
|
(char<=? . <=)
|
||||||
|
|
@ -639,8 +614,8 @@
|
||||||
(make-const src #f)))
|
(make-const src #f)))
|
||||||
(else #f)))
|
(else #f)))
|
||||||
|
|
||||||
(hashq-set! *primitive-expand-table* 'eqv? (maybe-simplify-to-eq 'eqv?))
|
(define-primitive-expander! 'eqv? (maybe-simplify-to-eq 'eqv?))
|
||||||
(hashq-set! *primitive-expand-table* 'equal? (maybe-simplify-to-eq 'equal?))
|
(define-primitive-expander! 'equal? (maybe-simplify-to-eq 'equal?))
|
||||||
|
|
||||||
(define (expand-chained-comparisons prim)
|
(define (expand-chained-comparisons prim)
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
|
@ -659,26 +634,23 @@
|
||||||
(else #f)))
|
(else #f)))
|
||||||
|
|
||||||
(for-each (lambda (prim)
|
(for-each (lambda (prim)
|
||||||
(hashq-set! *primitive-expand-table* prim
|
(define-primitive-expander! prim
|
||||||
(expand-chained-comparisons prim)))
|
(expand-chained-comparisons prim)))
|
||||||
'(< <= = >= > eq?))
|
'(< <= = >= > eq?))
|
||||||
|
|
||||||
(hashq-set! *primitive-expand-table*
|
(define-primitive-expander! 'call-with-prompt
|
||||||
'call-with-prompt
|
(case-lambda
|
||||||
(case-lambda
|
((src tag thunk handler)
|
||||||
((src tag thunk handler)
|
(make-prompt src #f tag thunk handler))
|
||||||
(make-prompt src #f tag thunk handler))
|
(else #f)))
|
||||||
(else #f)))
|
|
||||||
|
|
||||||
(hashq-set! *primitive-expand-table*
|
(define-primitive-expander! 'abort-to-prompt*
|
||||||
'abort-to-prompt*
|
(case-lambda
|
||||||
(case-lambda
|
((src tag tail-args)
|
||||||
((src tag tail-args)
|
(make-abort src tag '() tail-args))
|
||||||
(make-abort src tag '() tail-args))
|
(else #f)))
|
||||||
(else #f)))
|
(define-primitive-expander! 'abort-to-prompt
|
||||||
(hashq-set! *primitive-expand-table*
|
(case-lambda
|
||||||
'abort-to-prompt
|
((src tag . args)
|
||||||
(case-lambda
|
(make-abort src tag args (make-const #f '())))
|
||||||
((src tag . args)
|
(else #f)))
|
||||||
(make-abort src tag args (make-const #f '())))
|
|
||||||
(else #f)))
|
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue