Miroirs/skint
1
0
Fork 0
mirror of https://github.com/false-schemers/skint.git synced 2024-11-16 07:47:54 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions

support for (set& var) primitive (returns box)

Browse source
This commit is contained in:
ESL 2023-03-12 16:54:44 -04:00
parent ec702f5097
commit c72ac73743
4 changed files with 2565 additions and 2014 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
i.c
View file

@ -413,6 +413,11 @@ define_instruction(dseti) {
gonexti();
}
define_instruction(gloc) {
ac = *ip++;
gonexti();
}
define_instruction(gset) {
obj p = *ip++;
gref(p) = ac;

1
i.h
View file

@ -54,6 +54,7 @@ declare_instruction(brnot, "?", 'b', NULL, 0, NULL)
declare_instruction(brt, "~?", 'b', NULL, 0, NULL)
declare_instruction(sseti, ".!", 1, NULL, 0, NULL)
declare_instruction(dseti, ":!", 1, NULL, 0, NULL)
declare_instruction(gloc, "`", 'g', NULL, 0, NULL)
declare_instruction(gset, "@!", 'g', NULL, 0, NULL)
declare_instruction(appl, "K3", 0, NULL, 0, NULL)
declare_instruction(cwmv, "K4", 0, NULL, 0, NULL)

4520
k.c
View file

File diff suppressed because it is too large Load diff

51
src/k.sf
View file

@ -128,12 +128,14 @@
(if (null? rest) x
(cons x (loop (car rest) (cdr rest))))))
(define (andmap p l)
(if (pair? l) (and (p (car l)) (andmap p (cdr l))) #t))
(define (list1? x) (and (pair? x) (null? (cdr x))))
(define (list1+? x) (and (pair? x) (list? (cdr x))))
(define (list2? x) (and (pair? x) (list1? (cdr x))))
(define (list2+? x) (and (pair? x) (list1+? (cdr x))))
;---------------------------------------------------------------------------------------------
; Syntax of the Scheme Core language
;---------------------------------------------------------------------------------------------
@ -141,6 +143,7 @@
; <core> -> (quote <object>)
; <core> -> (ref <id>)
; <core> -> (set! <id> <core>)
; <core> -> (set& <id>)
; <core> -> (lambda <ids> <core>) where <ids> -> (<id> ...) | (<id> ... . <id>) | <id>
; <core> -> (lambda* (<arity> <core>) ...) where <arity> -> (<cnt> <rest?>)
; <core> -> (letcc <id> <core>)
@ -155,6 +158,12 @@
; <core> -> (define <id> <core>)
; <core> -> (define-syntax <id> <transformer>)
(define idslist?
(lambda (x)
(cond [(null? x) #t]
[(pair? x) (and (id? (car x)) (idslist? (cdr x)))]
[else (id? x)])))
(define normalize-arity
(lambda (arity)
(if (and (list2? arity) (fixnum? (car arity)) (boolean? (cadr arity)))
@ -239,9 +248,10 @@
[(not (pair? sexp)) (xform-quote sexp env)]
[else (let* ([head (car sexp)] [tail (cdr sexp)] [hval (xform #t head env)])
(case hval
[(syntax) (car tail)]
[(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)]
@ -277,6 +287,17 @@
(list 'set! (cadr val) xexp)
(error 'transform "set! to non-identifier form")))])))
(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")]
[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")))
(define (xform-begin tail env)
(if (list? tail)
(let ([xexps (map (lambda (sexp) (xform #f sexp env)) tail)])
@ -303,7 +324,7 @@
(error 'transform "improper application")))
(define (xform-lambda tail env)
(if (list? tail)
(if (and (list1+? tail) (idslist? (car tail)))
(let loop ([vars (car tail)] [ienv env] [ipars '()])
(cond [(pair? vars)
(let* ([var (car vars)] [nvar (gensym (id->sym var))])
@ -315,13 +336,15 @@
[ienv (add-var var nvar ienv)])
(list 'lambda (append (reverse ipars) nvar)
(xform-body (cdr tail) ienv)))]))
(error 'transform "improper lambda body")))
(error 'transform "improper lambda body" tail)))
(define (xform-lambda* tail env)
(if (list? tail)
(cons 'lambda*
(map (lambda (aexp)
(if (list2? aexp)
(if (and (list2? aexp)
(or (and (list2? (car aexp)) (fixnum? (caar aexp)) (boolean? (cadar aexp)))
(idslist? (car aexp))))
(list (normalize-arity (car aexp))
(xform #f (cadr aexp) env))
(error 'transform "improper lambda* clause")))
@ -408,6 +431,7 @@
(make-binding 'define-syntax 'define-syntax)
(make-binding 'quote 'quote)
(make-binding 'set! 'set!)
(make-binding 'set& 'set&)
(make-binding 'lambda 'lambda)
(make-binding 'lambda* 'lambda*)
(make-binding 'letcc 'letcc)
@ -792,6 +816,8 @@
(set-union
(if (set-member? id b) '() (list id))
(find-free exp b))]
[set& (id)
(if (set-member? id b) '() (list id))]
[lambda (idsi exp)
(find-free exp (set-union (flatten-idslist idsi) b))]
[lambda* clauses
@ -828,6 +854,8 @@
(set-union
(if (set-member? id v) (list id) '())
(find-sets x v))]
[set& (id)
(if (set-member? id v) (list id) '())]
[lambda (idsi exp)
(find-sets exp (set-minus v (flatten-idslist idsi)))]
[lambda* clauses
@ -903,6 +931,19 @@
(write-char #\@ port) (write-char #\! port)
(write-serialized-arg id port)])
(when k (write-char #\] port) (write-serialized-arg k port))]
[set& (id)
(cond [(posq id l) => ; local
(lambda (n)
(write-char #\. port)
(write-serialized-arg n port))]
[(posq id f) => ; free
(lambda (n)
(write-char #\: port)
(write-serialized-arg n port))]
[else ; global
(write-char #\` port)
(write-serialized-arg id port)])
(when k (write-char #\] port) (write-serialized-arg k port))]
[begin exps
(let loop ([xl exps])
(when (pair? xl)