Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-12-26 21:58:51 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

minor refactoring of the transformer

Browse source
This commit is contained in:
ESL 2023-03-21 18:02:01 -04:00
parent f8c55fd3c9
commit b64a58ed34
2 changed files with 2708 additions and 2478 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5064
k.c
View file

File diff suppressed because it is too large Load diff

122
src/k.sf
View file

@ -259,9 +259,13 @@
(define (add-var var val env) ; adds renamed var as <core>
(extend-xenv env var (make-binding (id->sym var) (list 'ref val))))
(define (x-error msg . args)
(apply error (cons (string-append "transformer: " msg) args)))
; xform receives Scheme s-expressions and returns either Core Scheme <core>
; (always a pair) or special-form, which is either a builtin (a symbol) or
; a transformer (a procedure)
; a transformer (a procedure). Appos? flag is true when the context can
; allow xform to return a transformer; otherwise, only <core> is accepted.
(define (xform appos? sexp env)
(cond [(id? sexp)
@ -273,61 +277,65 @@
(xform appos? (hval sexp env) env)]
[else hval]))]
[(not (pair? sexp))
(xform-quote sexp env)]
(xform-quote (list sexp) env)]
[else
(let* ([head (car sexp)] [tail (cdr sexp)] [hval (xform #t head env)])
(case hval
[(syntax) (car tail)] ; internal use only
[(quote) (xform-quote (car tail) env)]
[(set!) (xform-set! (car tail) (cadr tail) env)]
[(set&) (xform-set& tail env)]
[(begin) (xform-begin tail env)]
[(if) (xform-if tail env)]
[(lambda) (xform-lambda tail env)]
[(lambda*) (xform-lambda* tail env)]
[(letcc) (xform-letcc tail env)]
[(withcc) (xform-withcc tail env)]
[(body) (xform-body tail env)]
[(define) (xform-define (car tail) (cadr tail) env)]
[(define-syntax) (xform-define-syntax (car tail) (cadr tail) env)]
[(quote) (xform-quote tail env)]
[(set!) (xform-set! tail env)]
[(set&) (xform-set& tail env)]
[(begin) (xform-begin tail env)]
[(if) (xform-if tail env)]
[(lambda) (xform-lambda tail env)]
[(lambda*) (xform-lambda* tail env)]
[(letcc) (xform-letcc tail env)]
[(withcc) (xform-withcc tail env)]
[(body) (xform-body tail env)]
[(define) (xform-define tail env)]
[(define-syntax) (xform-define-syntax tail env)]
[else (if (integrable? hval)
(xform-integrable hval tail env)
(if (procedure? hval)
(xform appos? (hval sexp env) env)
(xform-call hval tail env)))]))]))
(define (xform-quote sexp env)
(list 'quote
(let conv ([sexp sexp])
(cond [(id? sexp) (id->sym sexp)]
[(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))]
[(vector? sexp) (list->vector (map conv (vector->list sexp)))]
[else sexp]))))
(define (xform-ref id env)
(let ([den (env id)])
(cond [(symbol? den) (list 'ref den)]
[else (binding-val den)])))
(define (xform-set! id exp env)
(let ([den (env id)] [xexp (xform #f exp env)])
(cond [(symbol? den) (list 'set! den xexp)]
[(binding-special? den) (binding-set-val! den xexp) '(begin)]
[else (let ([val (binding-val den)])
(if (eq? (car val) 'ref)
(list 'set! (cadr val) xexp)
(error 'transform "set! to non-identifier form")))])))
(define (xform-quote tail env)
(if (list1? tail)
(list 'quote
(let conv ([sexp (car tail)])
(cond [(id? sexp) (id->sym sexp)]
[(pair? sexp) (cons (conv (car sexp)) (conv (cdr sexp)))]
[(vector? sexp) (list->vector (map conv (vector->list sexp)))]
[else sexp])))
(x-error "improper quote form" (cons 'quote tail))))
(define (xform-set! tail env)
(if (and (list2? tail) (id? (car tail)))
(let ([den (env (car tail))] [xexp (xform #f (cadr tail) env)])
(cond [(symbol? den) (list 'set! den xexp)]
[(binding-special? den) (binding-set-val! den xexp) '(begin)]
[else (let ([val (binding-val den)])
(if (eq? (car val) 'ref)
(list 'set! (cadr val) xexp)
(x-error "set! to non-identifier form")))]))
(x-error "improper set! form" (cons 'set! tail))))
(define (xform-set& tail env)
(if (list1? tail)
(let ([den (env (car tail))])
(cond [(symbol? den) (list 'set& den)]
[(binding-special? den) (error 'transform "set& of a non-variable")]
[(binding-special? den) (x-error "set& of a non-variable")]
[else (let ([val (binding-val den)])
(if (eq? (car val) 'ref)
(list 'set& (cadr val))
(error 'transform "set& of a non-variable")))]))
(error 'transform "improper set& form")))
(x-error "set& of a non-variable")))]))
(x-error "improper set& form" (cons 'set& tail))))
(define (xform-begin tail env)
(if (list? tail)
@ -335,7 +343,7 @@
(if (and (pair? xexps) (null? (cdr xexps)))
(car xexps) ; (begin x) => x
(cons 'begin xexps)))
(error 'transform "improper begin form")))
(x-error "improper begin form" (cons 'begin! tail))))
(define (xform-if tail env)
(if (list? tail)
@ -343,8 +351,8 @@
(case (length xexps)
[(2) (cons 'if (append xexps '((begin))))]
[(3) (cons 'if xexps)]
[else (error 'transform "malformed if form")]))
(error 'transform "improper if form")))
[else (x-error "malformed if form" (cons 'if tail))]))
(x-error "improper if form" (cons 'if tail))))
(define (xform-call xexp tail env)
(if (list? tail)
@ -352,7 +360,7 @@
(if (and (null? xexps) (eq? (car xexp) 'lambda) (null? (cadr xexp)))
(caddr xexp) ; ((let () x)) => x
(pair* 'call xexp xexps)))
(error 'transform "improper application")))
(x-error "improper application" (cons xexp tail))))
(define (integrable-argc-match? igt n)
(case igt
@ -380,7 +388,7 @@
[ienv (add-var var nvar ienv)])
(list 'lambda (append (reverse ipars) nvar)
(xform-body (cdr tail) ienv)))]))
(error 'transform "improper lambda body" tail)))
(x-error "improper lambda body" (cons 'lambda tail))))
(define (xform-lambda* tail env)
(if (list? tail)
@ -391,22 +399,22 @@
(idslist? (car aexp))))
(list (normalize-arity (car aexp))
(xform #f (cadr aexp) env))
(error 'transform "improper lambda* clause")))
(x-error "improper lambda* clause" aexp)))
tail))
(error 'transform "improper lambda* form")))
(x-error "improper lambda* form" (cons 'lambda* tail))))
(define (xform-letcc tail env)
(if (and (list2+? tail) (id? (car tail)))
(let* ([var (car tail)] [nvar (gensym (id->sym var))])
(list 'letcc nvar
(xform-body (cdr tail) (add-var var nvar env))))
(error 'transform "improper letcc form")))
(x-error "improper letcc form" (cons 'letcc tail))))
(define (xform-withcc tail env)
(if (list2+? tail)
(list 'withcc (xform #f (car tail) env)
(xform-body (cdr tail) env))
(error 'transform "improper withcc form")))
(x-error "improper withcc form" (cons 'withcc tail))))
(define (xform-body tail env)
(if (null? tail)
@ -446,27 +454,27 @@
(map (lambda (lid) '(begin)) lids))))]
[(symbol? (car nids)) ; define
(loop (cdr ids) (cdr inits) (cdr nids)
(cons (xform-set! (car ids) (car inits) env) sets)
(cons (xform-set! (list (car ids) (car inits)) env) sets)
(cons (car nids) lids))]
[else ; define-syntax
(binding-set-val! (env (car ids)) (xform #t (car inits) env))
(loop (cdr ids) (cdr inits) (cdr nids) sets lids)])))
(define (xform-define id exp env) ; top-level only
(if (id? id)
(list 'define (id->sym id) (xform #f exp env))
(error 'transform "define of non-identifier form")))
(define (xform-define tail env) ; top-level only
(if (and (list2? tail) (id? (car tail)))
(list 'define (id->sym (car tail)) (xform #f (cadr tail) env))
(x-error "improper define form" (cons 'define tail))))
(define (xform-define-syntax id exp env) ; top-level only
(if (id? id)
(list 'define-syntax (id->sym id) (xform #t exp env))
(error 'transform "define-syntax of non-identifier form")))
(define (xform-define-syntax tail env) ; top-level only
(if (and (list2? tail) (id? (car tail)))
(list 'define-syntax (id->sym (car tail)) (xform #t (cadr tail) env))
(x-error "improper define-syntax form" (cons 'define-syntax tail))))
; ellipsis denotation is used for comparisons only
(define denotation-of-default-ellipsis
(make-binding '... (lambda (sexp env) (error '... sexp))))
(make-binding '... (lambda (sexp env) (x-error "improper use of ..." sexp))))
(define *transformers*
(list
@ -622,7 +630,7 @@
(lambda (use use-env)
(let loop ([rules rules])
(if (null? rules) (error 'transform "invalid syntax" use))
(if (null? rules) (x-error "invalid syntax" use))
(let* ([rule (car rules)] [pat (car rule)] [tmpl (cadr rule)])
(cond [(match-pattern pat use use-env) =>
(lambda (bindings) (expand-template pat tmpl bindings))]
@ -772,11 +780,13 @@
(define-syntax index-global unbox)
(define-syntax index-set-global! set-box!)
;---------------------------------------------------------------------------------------------
; String representation of S-expressions and code arguments
;---------------------------------------------------------------------------------------------
(define (c-error msg . args)
(apply error (cons (string-append "compiler: " msg) args)))
(define (write-serialized-char x port)
(cond [(or (char=? x #\%) (char=? x #\") (char=? x #\\) (char<? x #\space) (char>? x #\~))
(write-char #\% port)
@ -831,7 +841,7 @@
(write-serialized-size (string-length x) port)
(do ([i 0 (fx+ i 1)]) [(fx=? i (string-length x))]
(write-serialized-char (string-ref x i) port)))]
[else (error 'encode-sexp "cannot encode literal: ~s" x)]))
[else (c-error "cannot encode literal: ~s" x)]))
(define (write-serialized-arg arg port)
(if (and (number? arg) (exact? arg) (fx<=? 0 arg) (fx<=? arg 9))
@ -1152,7 +1162,7 @@
(write-char #\, port))
(write-string igc0 port)
(write-serialized-arg (length args) port)]
[else (error 'codegen "NYI: unsupported integrable type" igty)]))
[else (c-error "unsupported integrable type" igty)]))
(when k (write-char #\] port) (write-serialized-arg k port))]
[call (exp . args)
(cond [(and (eq? (car exp) 'lambda) (list? (cadr exp))