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

syntax-lambda; repl catches errors

Browse source
This commit is contained in:
ESL 2023-03-22 13:21:48 -04:00
parent b64a58ed34
commit f458d436b9
3 changed files with 2216 additions and 1772 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3783
k.c
View file

File diff suppressed because it is too large Load diff

83
src/k.sf
View file

@ -168,7 +168,8 @@
; <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> -> (lambda* (<arity> <core>) ...) where <arity> -> (<cnt> <rest?>)
; <core> -> (syntax-lambda (<id> ...) <core>)
; <core> -> (letcc <id> <core>)
; <core> -> (withcc <core> <core>)
; <core> -> (begin <core> ...)
@ -229,8 +230,9 @@
; <binding> -> (<symbol> . <value>)
; <value> -> <special> | <core>
; <special> -> <builtin> | <transformer>
; <builtin> -> syntax | define | define-syntax |
; quote | set! | begin | if | lambda | body
; <builtin> -> syntax | quote | set! | set& | begin | if | lambda |
; lambda* | syntax-lambda | letcc | withcc | body |
; define | define-syntax ; top-level only
; <transformer> -> <procedure of exp and env returning exp>
(define-inline (val-core? val) (pair? val))
@ -260,7 +262,7 @@
(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)))
(error* (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
@ -289,6 +291,7 @@
[(if) (xform-if tail env)]
[(lambda) (xform-lambda tail env)]
[(lambda*) (xform-lambda* tail env)]
[(syntax-lambda) (xform-syntax-lambda tail env)]
[(letcc) (xform-letcc tail env)]
[(withcc) (xform-withcc tail env)]
[(body) (xform-body tail env)]
@ -379,15 +382,15 @@
(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))])
(loop (cdr vars) (add-var var nvar ienv) (cons nvar ipars)))]
(let* ([var (car vars)] [nvar (gensym (id->sym var))])
(loop (cdr vars) (add-var var nvar ienv) (cons nvar ipars)))]
[(null? vars)
(list 'lambda (reverse ipars) (xform-body (cdr tail) ienv))]
(list 'lambda (reverse ipars) (xform-body (cdr tail) ienv))]
[else ; improper
(let* ([var vars] [nvar (gensym (id->sym var))]
[ienv (add-var var nvar ienv)])
(list 'lambda (append (reverse ipars) nvar)
(xform-body (cdr tail) ienv)))]))
(list 'lambda (append (reverse ipars) nvar)
(xform-body (cdr tail) ienv)))]))
(x-error "improper lambda body" (cons 'lambda tail))))
(define (xform-lambda* tail env)
@ -395,7 +398,9 @@
(cons 'lambda*
(map (lambda (aexp)
(if (and (list2? aexp)
(or (and (list2? (car aexp)) (fixnum? (caar aexp)) (boolean? (cadar 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))
@ -403,6 +408,21 @@
tail))
(x-error "improper lambda* form" (cons 'lambda* tail))))
(define (xform-syntax-lambda tail env)
(if (and (list2+? tail) (andmap id? (car tail)))
(let ([vars (car tail)] [macenv env] [forms (cdr tail)])
; return a transformer that wraps xformed body in (syntax ...)
(lambda (use useenv)
(if (and (list1+? use) (fx=? (length vars) (length (cdr use))))
(let loop ([vars vars] [exps (cdr use)] [env macenv])
(if (null? vars)
(list 'syntax (xform-body forms env))
(loop (cdr vars) (cdr exps)
(add-binding (car vars)
(xform #t (car exps) useenv) env))))
(x-error "invalif syntax-lambda application" use))))
(x-error "improper syntax-lambda body" (cons 'syntax-lambda tail))))
(define (xform-letcc tail env)
(if (and (list2+? tail) (id? (car tail)))
(let* ([var (car tail)] [nvar (gensym (id->sym var))])
@ -486,6 +506,7 @@
(make-binding 'set& 'set&)
(make-binding 'lambda 'lambda)
(make-binding 'lambda* 'lambda*)
(make-binding 'syntax-lambda 'syntax-lambda)
(make-binding 'letcc 'letcc)
(make-binding 'withcc 'withcc)
(make-binding 'begin 'begin)
@ -785,7 +806,7 @@
;---------------------------------------------------------------------------------------------
(define (c-error msg . args)
(apply error (cons (string-append "compiler: " msg) args)))
(error* (string-append "compiler: " msg) args))
(define (write-serialized-char x port)
(cond [(or (char=? x #\%) (char=? x #\") (char=? x #\\) (char<? x #\space) (char>? x #\~))
@ -1535,6 +1556,16 @@
(define *verbose* #f)
(define *reset* #f)
(define (error* msg args)
(if (procedure? *reset*)
(let ([p (current-error-port)])
(display msg p) (newline p)
(for-each (lambda (arg) (write arg p) (newline p)) args)
(*reset* #f))
(apply error (cons msg args))))
(define (run-tests)
(define start (current-jiffy))
(display "Running tests ...") (newline)
@ -1547,20 +1578,22 @@
(display " ms.") (newline))
(define (repl-eval x)
(let ([xexp (transform #f x)])
(when *verbose* (display "TRANSFORM =>") (newline) (write xexp) (newline))
(if (eq? (car xexp) 'define) (set-car! xexp 'set!))
(when *verbose* (display "COMPILE-TO-STRING =>") (newline))
(let ([cstr (compile-to-string xexp)] [start #f])
(when *verbose*
(display cstr) (newline)
(display "DECODE+EXECUTE =>") (newline)
(set! start (current-jiffy)))
(let* ([thunk (decode cstr)] [res (execute thunk)])
(write res) (newline))
(when *verbose*
(display "Elapsed time: ") (write (* 1000 (/ (- (current-jiffy) start) (jiffies-per-second))))
(display " ms.") (newline)))))
(letcc catch
(set! *reset* catch)
(let ([xexp (transform #f x)])
(when *verbose* (display "TRANSFORM =>") (newline) (write xexp) (newline))
(if (eq? (car xexp) 'define) (set-car! xexp 'set!))
(when *verbose* (display "COMPILE-TO-STRING =>") (newline))
(let ([cstr (compile-to-string xexp)] [start #f])
(when *verbose*
(display cstr) (newline)
(display "DECODE+EXECUTE =>") (newline)
(set! start (current-jiffy)))
(let* ([thunk (decode cstr)] [res (execute thunk)])
(write res) (newline))
(when *verbose*
(display "Elapsed time: ") (write (* 1000 (/ (- (current-jiffy) start) (jiffies-per-second))))
(display " ms.") (newline))))))
(define (repl-eval-top-form x)
(cond

122
src/s.scm
View file

@ -1,28 +1,112 @@
;---------------------------------------------------------------------------------------------
; Scheme library functions
; SCHEME LIBRARY FUNCTIONS
;---------------------------------------------------------------------------------------------
;---------------------------------------------------------------------------------------------
; helpers
;---------------------------------------------------------------------------------------------
(define-syntax define-inline
(syntax-rules ()
[(_ (id v ...) rid expr)
(begin
(define-syntax id
(syntax-rules ()
[(_ v ...) expr] ; NB: do not use the same var twice!
[(_ . r) (rid . r)] ; NB: use syntax-error?
[_ rid]))
(define rid (lambda (v ...) expr)))]))
;---------------------------------------------------------------------------------------------
; Derived expression types
;---------------------------------------------------------------------------------------------
#|
(define-syntax let-syntax
(syntax-rules ()
[(_ ([kw init] ...))
(begin)]
[(_ ([kw init] ...) . forms)
((syntax-lambda (kw ...) . forms)
init ...)]))
(define-syntax syntax-lambda
(let-syntax ([org-sl syntax-lambda])
(syntax-rules ()
[(_ (v ...) form) (org-sl (v ...) form)]
[(_ (v ...) . forms) (org-sl (v ...) (block . forms))])))
(define-syntax letrec-syntax
(syntax-rules ()
[(_ ([key trans] ...) . forms) ; non-splicing!
(body (define-syntax key trans) ... . forms)]))
(define-syntax letrec
(syntax-rules ()
[(_ ([var init] ...) . forms)
(body (define var init) ... . forms)]))
(define-syntax let
(syntax-rules ()
[(_ ([var init] ...) . forms)
((lambda (var ...) . forms) init ...)]
[(_ name ([var init] ...) . forms)
((letrec ((name (lambda (var ...) . forms))) name) init ...)]))
(define-syntax let*
(syntax-rules ()
[(_ () . forms)
(body . forms)]
[(_ (first . more) . forms)
(let (first) (let* more . forms))]))
(define-syntax and
(syntax-rules ()
[(_) #t]
[(_ test) test]
[(_ test . tests) (if test (and . tests) #f)]))
(define-syntax or
(syntax-rules ()
[(_) #f]
[(_ test) test]
[(_ test . tests) (let ([x test]) (if x x (or . tests)))]))
(define-syntax cond
(syntax-rules (else =>)
[(_) #f]
[(_ (else . exps)) (begin . exps)]
[(_ (x) . rest) (or x (cond . rest))]
[(_ (x => proc) . rest) (let ([tmp x]) (cond [tmp (proc tmp)] . rest))]
[(_ (x . exps) . rest) (if x (begin . exps) (cond . rest))]))
(define-syntax case-test
(syntax-rules (else)
[(_ k else) #t]
[(_ k atoms) (memv k 'atoms)]))
(define-syntax case
(syntax-rules ()
[(_ x (test . exprs) ...)
(let ([key x]) (cond ((case-test key test) . exprs) ...))]))
(define-syntax do
(syntax-rules ()
[(_ ((var init . step) ...) ending expr ...)
(let loop ([var init] ...)
(cond ending [else expr ... (loop (begin var . step) ...)]))]))
(define-syntax quasiquote
(syntax-rules (unquote unquote-splicing quasiquote)
[(_ ,x) x]
[(_ (,@x . y)) (append x `y)]
[(_ `x . d) (cons 'quasiquote (quasiquote (x) d))]
[(_ ,x d) (cons 'unquote (quasiquote (x) . d))]
[(_ ,@x d) (cons 'unquote-splicing (quasiquote (x) . d))]
[(_ (x . y) . d) (cons (quasiquote x . d) (quasiquote y . d))]
[(_ #(x ...) . d) (list->vector (quasiquote (x ...) . d))]
[(_ x . d) 'x]))
(define-syntax when
(syntax-rules ()
[(_ test . rest) (if test (begin . rest))]))
(define-syntax unless
(syntax-rules ()
[(_ test . rest) (if (not test) (begin . rest))]))
(define-syntax case-lambda
(syntax-rules ()
[(_ [args . body] ...) (lambda* [args (lambda args . body)] ...)]))
|#
;cond
;case
;and
@ -319,7 +403,11 @@
[(_ . args) (%assoc . args)]
[_ %assoc]))
(define-inline (list-copy x) %residual-list-copy (%lcat x '()))
(define (list-copy obj)
(let loop ([obj obj])
(if (pair? obj)
(cons (car obj) (loop (cdr obj)))
obj)))
; (list-tail l i)
; (last-pair l)