From 3919c17fdca342c31c6bae41f776a60793a7762d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 8 Sep 2014 20:20:08 +0900 Subject: [PATCH] WIP --- extlib/benz | 2 +- piclib/CMakeLists.txt | 14 +- piclib/picrin/array.scm | 31 +- piclib/picrin/base.scm | 580 ++++++++++++---------- piclib/picrin/dictionary.scm | 3 +- piclib/picrin/macro.scm | 8 +- piclib/picrin/record.scm | 19 +- piclib/picrin/syntax-rules.scm | 335 +++++++++++++ piclib/picrin/test.scm | 7 +- piclib/scheme/base.scm | 867 +++++++++++---------------------- piclib/scheme/eval.scm | 16 +- piclib/scheme/file.scm | 11 +- src/eval.c | 29 -- src/file.c | 119 ----- src/init.c | 70 --- src/load.c | 79 --- src/macro.c | 47 -- src/main.c | 47 ++ src/system.c | 136 ------ src/time.c | 49 -- 20 files changed, 1044 insertions(+), 1425 deletions(-) create mode 100644 piclib/picrin/syntax-rules.scm delete mode 100644 src/eval.c delete mode 100644 src/file.c delete mode 100644 src/init.c delete mode 100644 src/load.c delete mode 100644 src/macro.c delete mode 100644 src/system.c delete mode 100644 src/time.c diff --git a/extlib/benz b/extlib/benz index b8b57435..a2848f3e 160000 --- a/extlib/benz +++ b/extlib/benz @@ -1 +1 @@ -Subproject commit b8b5743589ccbed555805d768d5c840aad350499 +Subproject commit a2848f3eafdbe3a4579dd4c8054ab7e3b62e6812 diff --git a/piclib/CMakeLists.txt b/piclib/CMakeLists.txt index 6f79d0fd..008e5ad5 100644 --- a/piclib/CMakeLists.txt +++ b/piclib/CMakeLists.txt @@ -1,14 +1,14 @@ list(APPEND PICLIB_SCHEME_LIBS - ${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/macro.scm - - ${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm - + ${PROJECT_SOURCE_DIR}/piclib/picrin/base.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/record.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/array.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/dictionary.scm - ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm ${PROJECT_SOURCE_DIR}/piclib/picrin/experimental/lambda.scm + ${PROJECT_SOURCE_DIR}/piclib/picrin/syntax-rules.scm + ${PROJECT_SOURCE_DIR}/piclib/picrin/test.scm + + ${PROJECT_SOURCE_DIR}/piclib/scheme/base.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/cxr.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/read.scm @@ -17,6 +17,10 @@ list(APPEND PICLIB_SCHEME_LIBS ${PROJECT_SOURCE_DIR}/piclib/scheme/case-lambda.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/lazy.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/eval.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/inexact.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/load.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/process-context.scm + ${PROJECT_SOURCE_DIR}/piclib/scheme/time.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/r5rs.scm ${PROJECT_SOURCE_DIR}/piclib/scheme/null.scm diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index d12b7848..5ae0c107 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -1,6 +1,5 @@ (define-library (picrin array) - (import (scheme base) - (picrin base) + (import (picrin base) (picrin record)) (define-record-type @@ -11,6 +10,11 @@ (head array-head set-array-head!) (tail array-tail set-array-tail!)) + (define (floor-remainder i j) + (call-with-values (lambda () (floor/ i j)) + (lambda (q r) + r))) + (define (translate ary i) (floor-remainder i (array-size ary))) @@ -39,7 +43,7 @@ (if (null? rest) (make-array 0) (let ((capacity (car rest)) - (ary (create-array (vector) 0 0 0))) + (ary (create-array (make-vector 0) 0 0 0))) (array-reserve! ary capacity) ary))) @@ -90,16 +94,17 @@ (for-each proc (array->list ary))) (define-record-writer ( array) - (call-with-port (open-output-string) - (lambda (port) - (display "#.(array" port) - (array-for-each - (lambda (obj) - (display " " port) - (write obj port)) - array) - (display ")" port) - (get-output-string port)))) + (let ((port (open-output-string))) + (display "#.(array" port) + (array-for-each + (lambda (obj) + (display " " port) + (write obj port)) + array) + (display ")" port) + (let ((str (get-output-string port))) + (close-port port) + str))) (export make-array array diff --git a/piclib/picrin/base.scm b/piclib/picrin/base.scm index 342615bc..7ae1995d 100644 --- a/piclib/picrin/base.scm +++ b/piclib/picrin/base.scm @@ -1,4 +1,307 @@ (define-library (picrin base) + (import (picrin macro)) + + (define-syntax syntax-error + (er-macro-transformer + (lambda (expr rename compare) + (apply error (cdr expr))))) + + (define-syntax define-auxiliary-syntax + (er-macro-transformer + (lambda (expr r c) + (list (r 'define-syntax) (cadr expr) + (list (r 'lambda) '_ + (list (r 'error) "invalid use of auxiliary syntax")))))) + + (define-auxiliary-syntax else) + (define-auxiliary-syntax =>) + (define-auxiliary-syntax _) + (define-auxiliary-syntax ...) + (define-auxiliary-syntax unquote) + (define-auxiliary-syntax unquote-splicing) + + (define-syntax let + (er-macro-transformer + (lambda (expr r compare) + (if (symbol? (cadr expr)) + (begin + (define name (car (cdr expr))) + (define bindings (car (cdr (cdr expr)))) + (define body (cdr (cdr (cdr expr)))) + (list (r 'let) '() + (list (r 'define) name + (cons (r 'lambda) (cons (map car bindings) body))) + (cons name (map cadr bindings)))) + (begin + (set! bindings (cadr expr)) + (set! body (cddr expr)) + (cons (cons (r 'lambda) (cons (map car bindings) body)) + (map cadr bindings))))))) + + (define-syntax cond + (er-macro-transformer + (lambda (expr r compare) + (let ((clauses (cdr expr))) + (if (null? clauses) + #f + (begin + (define clause (car clauses)) + (if (compare (r 'else) (car clause)) + (cons (r 'begin) (cdr clause)) + (if (if (>= (length clause) 2) + (compare (r '=>) (list-ref clause 1)) + #f) + (list (r 'let) (list (list (r 'x) (car clause))) + (list (r 'if) (r 'x) + (list (list-ref clause 2) (r 'x)) + (cons (r 'cond) (cdr clauses)))) + (list (r 'if) (car clause) + (cons (r 'begin) (cdr clause)) + (cons (r 'cond) (cdr clauses))))))))))) + + (define-syntax and + (er-macro-transformer + (lambda (expr r compare) + (let ((exprs (cdr expr))) + (cond + ((null? exprs) + #t) + ((= (length exprs) 1) + (car exprs)) + (else + (list (r 'let) (list (list (r 'it) (car exprs))) + (list (r 'if) (r 'it) + (cons (r 'and) (cdr exprs)) + (r 'it))))))))) + + (define-syntax or + (er-macro-transformer + (lambda (expr r compare) + (let ((exprs (cdr expr))) + (cond + ((null? exprs) + #t) + ((= (length exprs) 1) + (car exprs)) + (else + (list (r 'let) (list (list (r 'it) (car exprs))) + (list (r 'if) (r 'it) + (r 'it) + (cons (r 'or) (cdr exprs)))))))))) + + (define-syntax quasiquote + (er-macro-transformer + (lambda (form rename compare) + + (define (quasiquote? form) + (and (pair? form) (compare (car form) (rename 'quasiquote)))) + + (define (unquote? form) + (and (pair? form) (compare (car form) (rename 'unquote)))) + + (define (unquote-splicing? form) + (and (pair? form) (pair? (car form)) + (compare (car (car form)) (rename 'unquote-splicing)))) + + (define (qq depth expr) + (cond + ;; unquote + ((unquote? expr) + (if (= depth 1) + (car (cdr expr)) + (list (rename 'list) + (list (rename 'quote) (rename 'unquote)) + (qq (- depth 1) (car (cdr expr)))))) + ;; unquote-splicing + ((unquote-splicing? expr) + (if (= depth 1) + (list (rename 'append) + (car (cdr (car expr))) + (qq depth (cdr expr))) + (list (rename 'cons) + (list (rename 'list) + (list (rename 'quote) (rename 'unquote-splicing)) + (qq (- depth 1) (car (cdr (car expr))))) + (qq depth (cdr expr))))) + ;; quasiquote + ((quasiquote? expr) + (list (rename 'list) + (list (rename 'quote) (rename 'quasiquote)) + (qq (+ depth 1) (car (cdr expr))))) + ;; list + ((pair? expr) + (list (rename 'cons) + (qq depth (car expr)) + (qq depth (cdr expr)))) + ;; vector + ((vector? expr) + (list (rename 'list->vector) (qq depth (vector->list expr)))) + ;; simple datum + (else + (list (rename 'quote) expr)))) + + (let ((x (cadr form))) + (qq 1 x))))) + + (define-syntax let* + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (cadr form)) + (body (cddr form))) + (if (null? bindings) + `(,(r 'let) () ,@body) + `(,(r 'let) ((,(caar bindings) + ,@(cdar bindings))) + (,(r 'let*) (,@(cdr bindings)) + ,@body))))))) + + (define-syntax letrec* + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (cadr form)) + (body (cddr form))) + (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) + (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings))) + `(,(r 'let) (,@vars) + ,@initials + ,@body)))))) + + (define-syntax letrec + (er-macro-transformer + (lambda (form rename compare) + `(,(rename 'letrec*) ,@(cdr form))))) + + (define-syntax let*-values + (er-macro-transformer + (lambda (form r c) + (let ((formals (cadr form))) + (if (null? formals) + `(,(r 'let) () ,@(cddr form)) + `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals)) + (,(r 'lambda) (,@(caar formals)) + (,(r 'let*-values) (,@(cdr formals)) + ,@(cddr form))))))))) + + (define-syntax let-values + (er-macro-transformer + (lambda (form r c) + `(,(r 'let*-values) ,@(cdr form))))) + + (define-syntax define-values + (er-macro-transformer + (lambda (form r compare) + (let ((formal (cadr form)) + (exprs (cddr form))) + `(,(r 'begin) + ,@(let loop ((formal formal)) + (if (not (pair? formal)) + (if (symbol? formal) + `((,(r 'define) ,formal #f)) + '()) + `((,(r 'define) ,(car formal) #f) . ,@(loop (cdr formal))))) + (,(r 'call-with-values) (,(r 'lambda) () ,@exprs) + (,(r 'lambda) ,(r 'args) + ,@(let loop ((formal formal) (args (r 'args))) + (if (not (pair? formal)) + (if (symbol? formal) + `((,(r 'set!) ,formal ,args)) + '()) + `((,(r 'set!) ,(car formal) (,(r 'car) ,args)) + ,@(loop (cdr formal) `(,(r 'cdr) ,args)))))))))))) + + (define-syntax do + (er-macro-transformer + (lambda (form r compare) + (let ((bindings (car (cdr form))) + (finish (car (cdr (cdr form)))) + (body (cdr (cdr (cdr form))))) + `(,(r 'let) ,(r 'loop) ,(map (lambda (x) + (list (car x) (cadr x))) + bindings) + (,(r 'if) ,(car finish) + (,(r 'begin) ,@(cdr finish)) + (,(r 'begin) ,@body + (,(r 'loop) ,@(map (lambda (x) + (if (null? (cddr x)) + (car x) + (car (cddr x)))) + bindings))))))))) + + (define-syntax when + (er-macro-transformer + (lambda (expr rename compare) + (let ((test (cadr expr)) + (body (cddr expr))) + `(,(rename 'if) ,test + (,(rename 'begin) ,@body) + #f))))) + + (define-syntax unless + (er-macro-transformer + (lambda (expr rename compare) + (let ((test (cadr expr)) + (body (cddr expr))) + `(,(rename 'if) ,test + #f + (,(rename 'begin) ,@body)))))) + + (define-syntax case + (er-macro-transformer + (lambda (expr r compare) + (let ((key (cadr expr)) + (clauses (cddr expr))) + `(,(r 'let) ((,(r 'key) ,key)) + ,(let loop ((clauses clauses)) + (if (null? clauses) + #f + (begin + (define clause (car clauses)) + `(,(r 'if) ,(if (compare (r 'else) (car clause)) + '#t + `(,(r 'or) + ,@(map (lambda (x) + `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) + (car clause)))) + ,(if (compare (r '=>) (list-ref clause 1)) + `(,(list-ref clause 2) ,(r 'key)) + `(,(r 'begin) ,@(cdr clause))) + ,(loop (cdr clauses))))))))))) + + (define-syntax letrec-syntax + (er-macro-transformer + (lambda (form r c) + (let ((formal (car (cdr form))) + (body (cdr (cdr form)))) + `(let () + ,@(map (lambda (x) + `(,(r 'define-syntax) ,(car x) ,(cadr x))) + formal) + ,@body))))) + + (define-syntax let-syntax + (er-macro-transformer + (lambda (form r c) + `(,(r 'letrec-syntax) ,@(cdr form))))) + + (define-syntax include + (letrec ((read-file + (lambda (filename) + (let ((port (open-input-file filename))) + (dynamic-wind + (lambda () #f) + (lambda () + (let loop ((expr (read port)) (exprs '())) + (if (eof-object? expr) + (reverse exprs) + (loop (read port) (cons expr exprs))))) + (lambda () + (close-port port))))))) + (er-macro-transformer + (lambda (form rename compare) + (let ((filenames (cdr form))) + (let ((exprs (apply append (map read-file filenames)))) + `(,(rename 'begin) ,@exprs))))))) + (export define lambda if @@ -7,6 +310,16 @@ begin define-syntax) + (export let let* letrec letrec* + let-values let*-values define-values + quasiquote unquote unquote-splicing + and or + cond case else => + do when unless + let-syntax letrec-syntax + include + _ ... syntax-error) + (export eq? eqv? equal?) @@ -146,8 +459,13 @@ output-port? textual-port? binary-port? + close-port + open-input-file + open-output-file + open-binary-input-file + open-binary-output-file open-input-string open-output-string get-output-string @@ -188,6 +506,7 @@ make-identifier) (export call-with-current-continuation + call/cc continue dynamic-wind values @@ -216,255 +535,18 @@ write-shared display) - (define-syntax syntax-error - (er-macro-transformer - (lambda (expr rename compare) - (apply error (cdr expr))))) + (export command-line + exit + emergency-exit + file-exists? + delete-file + get-environment-variable + get-environment-variables) - (define-syntax define-auxiliary-syntax - (er-macro-transformer - (lambda (expr r c) - (list (r 'define-syntax) (cadr expr) - (list (r 'lambda) '_ - (list (r 'error) "invalid use of auxiliary syntax")))))) + (export current-second + current-jiffy + jiffies-per-second) - (define-auxiliary-syntax else) - (define-auxiliary-syntax =>) - (define-auxiliary-syntax _) - (define-auxiliary-syntax ...) - (define-auxiliary-syntax unquote) - (define-auxiliary-syntax unquote-splicing) + (export eval) - (define-syntax let - (er-macro-transformer - (lambda (expr r compare) - (if (symbol? (cadr expr)) - (begin - (define name (car (cdr expr))) - (define bindings (car (cdr (cdr expr)))) - (define body (cdr (cdr (cdr expr)))) - (list (r 'let) '() - (list (r 'define) name - (cons (r 'lambda) (cons (map car bindings) body))) - (cons name (map cadr bindings)))) - (begin - (set! bindings (cadr expr)) - (set! body (cddr expr)) - (cons (cons (r 'lambda) (cons (map car bindings) body)) - (map cadr bindings))))))) - - (define-syntax cond - (er-macro-transformer - (lambda (expr r compare) - (let ((clauses (cdr expr))) - (if (null? clauses) - #f - (begin - (define clause (car clauses)) - (if (compare (r 'else) (car clause)) - (cons (r 'begin) (cdr clause)) - (if (if (>= (length clause) 2) - (compare (r '=>) (list-ref clause 1)) - #f) - (list (r 'let) (list (list (r 'x) (car clause))) - (list (r 'if) (r 'x) - (list (list-ref clause 2) (r 'x)) - (cons (r 'cond) (cdr clauses)))) - (list (r 'if) (car clause) - (cons (r 'begin) (cdr clause)) - (cons (r 'cond) (cdr clauses))))))))))) - - (define-syntax and - (er-macro-transformer - (lambda (expr r compare) - (let ((exprs (cdr expr))) - (cond - ((null? exprs) - #t) - ((= (length exprs) 1) - (car exprs)) - (else - (list (r 'let) (list (list (r 'it) (car exprs))) - (list (r 'if) (r 'it) - (cons (r 'and) (cdr exprs)) - (r 'it))))))))) - - (define-syntax or - (er-macro-transformer - (lambda (expr r compare) - (let ((exprs (cdr expr))) - (cond - ((null? exprs) - #t) - ((= (length exprs) 1) - (car exprs)) - (else - (list (r 'let) (list (list (r 'it) (car exprs))) - (list (r 'if) (r 'it) - (r 'it) - (cons (r 'or) (cdr exprs)))))))))) - - (define-syntax quasiquote - (ir-macro-transformer - (lambda (form inject compare) - - (define (quasiquote? form) - (and (pair? form) (compare (car form) 'quasiquote))) - - (define (unquote? form) - (and (pair? form) (compare (car form) 'unquote))) - - (define (unquote-splicing? form) - (and (pair? form) (pair? (car form)) - (compare (car (car form)) 'unquote-splicing))) - - (define (qq depth expr) - (cond - ;; unquote - ((unquote? expr) - (if (= depth 1) - (car (cdr expr)) - (list 'list - (list 'quote (inject 'unquote)) - (qq (- depth 1) (car (cdr expr)))))) - ;; unquote-splicing - ((unquote-splicing? expr) - (if (= depth 1) - (list 'append - (car (cdr (car expr))) - (qq depth (cdr expr))) - (list 'cons - (list 'list - (list 'quote (inject 'unquote-splicing)) - (qq (- depth 1) (car (cdr (car expr))))) - (qq depth (cdr expr))))) - ;; quasiquote - ((quasiquote? expr) - (list 'list - (list 'quote (inject 'quasiquote)) - (qq (+ depth 1) (car (cdr expr))))) - ;; list - ((pair? expr) - (list 'cons - (qq depth (car expr)) - (qq depth (cdr expr)))) - ;; vector - ((vector? expr) - (list 'list->vector (qq depth (vector->list expr)))) - ;; simple datum - (else - (list 'quote expr)))) - - (let ((x (cadr form))) - (qq 1 x))))) - - (define-syntax let* - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (if (null? bindings) - `(,(r 'let) () ,@body) - `(,(r 'let) ((,(caar bindings) - ,@(cdar bindings))) - (,(r 'let*) (,@(cdr bindings)) - ,@body))))))) - - (define-syntax letrec* - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (cadr form)) - (body (cddr form))) - (let ((vars (map (lambda (v) `(,v #f)) (map car bindings))) - (initials (map (lambda (v) `(,(r 'set!) ,@v)) bindings))) - `(,(r 'let) (,@vars) - ,@initials - ,@body)))))) - - (define-syntax letrec - (er-macro-transformer - (lambda (form rename compare) - `(,(rename 'letrec*) ,@(cdr form))))) - - (define-syntax do - (er-macro-transformer - (lambda (form r compare) - (let ((bindings (car (cdr form))) - (finish (car (cdr (cdr form)))) - (body (cdr (cdr (cdr form))))) - `(,(r 'let) ,(r 'loop) ,(map (lambda (x) - (list (car x) (cadr x))) - bindings) - (,(r 'if) ,(car finish) - (,(r 'begin) ,@(cdr finish)) - (,(r 'begin) ,@body - (,(r 'loop) ,@(map (lambda (x) - (if (null? (cddr x)) - (car x) - (car (cddr x)))) - bindings))))))))) - - (define-syntax when - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - (,(rename 'begin) ,@body) - #f))))) - - (define-syntax unless - (er-macro-transformer - (lambda (expr rename compare) - (let ((test (cadr expr)) - (body (cddr expr))) - `(,(rename 'if) ,test - #f - (,(rename 'begin) ,@body)))))) - - (define-syntax case - (er-macro-transformer - (lambda (expr r compare) - (let ((key (cadr expr)) - (clauses (cddr expr))) - `(,(r 'let) ((,(r 'key) ,key)) - ,(let loop ((clauses clauses)) - (if (null? clauses) - #f - (begin - (define clause (car clauses)) - `(,(r 'if) ,(if (compare (r 'else) (car clause)) - '#t - `(,(r 'or) - ,@(map (lambda (x) - `(,(r 'eqv?) ,(r 'key) (,(r 'quote) ,x))) - (car clause)))) - ,(if (compare (r '=>) (list-ref clause 1)) - `(,(list-ref clause 2) ,(r 'key)) - `(,(r 'begin) ,@(cdr clause))) - ,(loop (cdr clauses))))))))))) - - (define-syntax letrec-syntax - (er-macro-transformer - (lambda (form r c) - (let ((formal (car (cdr form))) - (body (cdr (cdr form)))) - `(let () - ,@(map (lambda (x) - `(,(r 'define-syntax) ,(car x) ,(cadr x))) - formal) - ,@body))))) - - (define-syntax let-syntax - (er-macro-transformer - (lambda (form r c) - `(,(r 'letrec-syntax) ,@(cdr form))))) - - (export let let* letrec letrec* - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - let-syntax letrec-syntax - include - _ ... syntax-error)) + (export load)) diff --git a/piclib/picrin/dictionary.scm b/piclib/picrin/dictionary.scm index 1940d676..4ad679e9 100644 --- a/piclib/picrin/dictionary.scm +++ b/piclib/picrin/dictionary.scm @@ -1,6 +1,5 @@ (define-library (picrin dictionary) - (import (scheme base) - (picrin base)) + (import (picrin base)) (define (dictionary-map proc dict) (let ((kvs '())) diff --git a/piclib/picrin/macro.scm b/piclib/picrin/macro.scm index c17c7555..22bdf097 100644 --- a/piclib/picrin/macro.scm +++ b/piclib/picrin/macro.scm @@ -1,5 +1,3 @@ -;;; Hygienic Macros - (define-library (picrin macro) (import (picrin base)) @@ -109,8 +107,8 @@ (rename sym))))) (f (walk inject expr) inject compare)))) - (define (strip-syntax form) - (walk ungensym form)) + ;; (define (strip-syntax form) + ;; (walk ungensym form)) (define-syntax define-macro (er-macro-transformer @@ -136,5 +134,5 @@ rsc-macro-transformer er-macro-transformer ir-macro-transformer - strip-syntax + ;; strip-syntax define-macro)) diff --git a/piclib/picrin/record.scm b/piclib/picrin/record.scm index 00bb3d62..6784524b 100644 --- a/piclib/picrin/record.scm +++ b/piclib/picrin/record.scm @@ -1,6 +1,6 @@ (define-library (picrin record) (import (picrin base) - (scheme base)) + (picrin macro)) ;; define-record-writer @@ -8,14 +8,15 @@ (record-set! record-type 'writer writer)) (define-syntax define-record-writer - (syntax-rules () - ((_ (type obj) body ...) - (set-record-writer! type - (lambda (obj) - body ...))) - ((_ type writer) - (set-record-writer! type - writer)))) + (er-macro-transformer + (lambda (form r compare) + (let ((formal (cadr form))) + (if (pair? formal) + `(,(r 'set-record-writer!) ,(car formal) + (,(r 'lambda) (,(cadr formal)) + ,@(cddr form))) + `(,(r 'set-record-writer!) ,formal + ,@(cddr form))))))) ;; define-record-type diff --git a/piclib/picrin/syntax-rules.scm b/piclib/picrin/syntax-rules.scm new file mode 100644 index 00000000..1f206ac6 --- /dev/null +++ b/piclib/picrin/syntax-rules.scm @@ -0,0 +1,335 @@ +(define-library (picrin syntax-rules) + (import (picrin base) + (picrin macro)) + + (define (walk proc expr) + (cond + ((null? expr) + '()) + ((pair? expr) + (cons (walk proc (car expr)) + (walk proc (cdr expr)))) + ((vector? expr) + (list->vector (map proc (vector->list expr)))) + (else + (proc expr)))) + + (define (flatten expr) + (let ((list '())) + (walk + (lambda (x) + (set! list (cons x list))) + expr) + (reverse list))) + + (define (reverse* l) + ;; (reverse* '(a b c d . e)) => (e d c b a) + (let loop ((a '()) + (d l)) + (if (pair? d) + (loop (cons (car d) a) (cdr d)) + (cons d a)))) + + (define (every? pred l) + (if (null? l) + #t + (and (pred (car l)) (every? pred (cdr l))))) + + (define-syntax syntax-rules + (er-macro-transformer + (lambda (form r compare) + (define _define (r 'define)) + (define _let (r 'let)) + (define _if (r 'if)) + (define _begin (r 'begin)) + (define _lambda (r 'lambda)) + (define _set! (r 'set!)) + (define _not (r 'not)) + (define _and (r 'and)) + (define _car (r 'car)) + (define _cdr (r 'cdr)) + (define _cons (r 'cons)) + (define _pair? (r 'pair?)) + (define _null? (r 'null?)) + (define _symbol? (r 'symbol?)) + (define _vector? (r 'vector?)) + (define _eqv? (r 'eqv?)) + (define _string=? (r 'string=?)) + (define _map (r 'map)) + (define _vector->list (r 'vector->list)) + (define _list->vector (r 'list->vector)) + (define _quote (r 'quote)) + (define _quasiquote (r 'quasiquote)) + (define _unquote (r 'unquote)) + (define _unquote-splicing (r 'unquote-splicing)) + (define _syntax-error (r 'syntax-error)) + (define _call/cc (r 'call/cc)) + (define _er-macro-transformer (r 'er-macro-transformer)) + + (define (var->sym v) + (let loop ((cnt 0) + (v v)) + (if (symbol? v) + (string->symbol + (string-append (symbol->string v) "/" (number->string cnt))) + (loop (+ 1 cnt) (car v))))) + + (define push-var list) + + (define (compile-match ellipsis literals pattern) + (letrec ((compile-match-base + (lambda (pattern) + (cond ((member pattern literals compare) + (values + `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern))) + #f + (exit #f)) + '())) + ((compare pattern (r '_)) (values #f '())) + ((and ellipsis (compare pattern ellipsis)) + (values `(,_syntax-error "invalid pattern") '())) + ((symbol? pattern) + (values `(,_set! ,(var->sym pattern) expr) (list pattern))) + ((pair? pattern) + (compile-match-list pattern)) + ((vector? pattern) + (compile-match-vector pattern)) + ((string? pattern) + (values + `(,_if (,_not (,_string=? ',pattern expr)) + (exit #f)) + '())) + (else + (values + `(,_if (,_not (,_eqv? ',pattern expr)) + (exit #f)) + '()))))) + + (compile-match-list + (lambda (pattern) + (let loop ((pattern pattern) + (matches '()) + (vars '()) + (accessor 'expr)) + (cond ;; (hoge) + ((not (pair? (cdr pattern))) + (let*-values (((match1 vars1) (compile-match-base (car pattern))) + ((match2 vars2) (compile-match-base (cdr pattern)))) + (values + `(,_begin ,@(reverse matches) + (,_if (,_pair? ,accessor) + (,_begin + (,_let ((expr (,_car ,accessor))) + ,match1) + (,_let ((expr (,_cdr ,accessor))) + ,match2)) + (exit #f))) + (append vars (append vars1 vars2))))) + ;; (hoge ... rest args) + ((and ellipsis (compare (cadr pattern) ellipsis)) + (let-values (((match-r vars-r) (compile-match-list-reverse pattern))) + (values + `(,_begin ,@(reverse matches) + (,_let ((expr (,_let loop ((a ()) + (d ,accessor)) + (,_if (,_pair? d) + (loop (,_cons (,_car d) a) (,_cdr d)) + (,_cons d a))))) + ,match-r)) + (append vars vars-r)))) + (else + (let-values (((match1 vars1) (compile-match-base (car pattern)))) + (loop (cdr pattern) + (cons `(,_if (,_pair? ,accessor) + (,_let ((expr (,_car ,accessor))) + ,match1) + (exit #f)) + matches) + (append vars vars1) + `(,_cdr ,accessor)))))))) + + (compile-match-list-reverse + (lambda (pattern) + (let loop ((pattern (reverse* pattern)) + (matches '()) + (vars '()) + (accessor 'expr)) + (cond ((and ellipsis (compare (car pattern) ellipsis)) + (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern)))) + (values + `(,_begin ,@(reverse matches) + (,_let ((expr ,accessor)) + ,match1)) + (append vars vars1)))) + (else + (let-values (((match1 vars1) (compile-match-base (car pattern)))) + (loop (cdr pattern) + (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches) + (append vars vars1) + `(,_cdr ,accessor)))))))) + + (compile-match-ellipsis + (lambda (pattern) + (let-values (((match vars) (compile-match-base pattern))) + (values + `(,_let loop ((expr expr)) + (,_if (,_not (,_null? expr)) + (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars) + (,_let ((expr (,_car expr))) + ,match) + ,@(map + (lambda (var) + `(,_set! ,(var->sym (push-var var)) + (,_cons ,(var->sym var) ,(var->sym (push-var var))))) + vars) + (loop (,_cdr expr))))) + (map push-var vars))))) + + (compile-match-vector + (lambda (pattern) + (let-values (((match vars) (compile-match-base (vector->list pattern)))) + (values + `(,_if (,_vector? expr) + (,_let ((expr (,_vector->list expr))) + ,match) + (exit #f)) + vars))))) + + (let-values (((match vars) (compile-match-base (cdr pattern)))) + (values `(,_let ((expr (,_cdr expr))) + ,match + #t) + vars)))) + +;;; compile expand + (define (compile-expand ellipsis reserved template) + (letrec ((compile-expand-base + (lambda (template ellipsis-valid) + (cond ((member template reserved eq?) + (values (var->sym template) (list template))) + ((symbol? template) + (values `(rename ',template) '())) + ((pair? template) + (compile-expand-list template ellipsis-valid)) + ((vector? template) + (compile-expand-vector template ellipsis-valid)) + (else + (values `',template '()))))) + + (compile-expand-list + (lambda (template ellipsis-valid) + (let loop ((template template) + (expands '()) + (vars '())) + (cond ;; (... hoge) + ((and ellipsis-valid + (pair? template) + (compare (car template) ellipsis)) + (if (and (pair? (cdr template)) (null? (cddr template))) + (compile-expand-base (cadr template) #f) + (values '(,_syntax-error "invalid template") '()))) + ;; hoge + ((not (pair? template)) + (let-values (((expand1 vars1) + (compile-expand-base template ellipsis-valid))) + (values + `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1))) + (append vars vars1)))) + ;; (a ... rest syms) + ((and ellipsis-valid + (pair? (cdr template)) + (compare (cadr template) ellipsis)) + (let-values (((expand1 vars1) + (compile-expand-base (car template) ellipsis-valid))) + (loop (cddr template) + (cons + `(,_unquote-splicing + (,_map (,_lambda ,(map var->sym vars1) ,expand1) + ,@(map (lambda (v) (var->sym (push-var v))) vars1))) + expands) + (append vars (map push-var vars1))))) + (else + (let-values (((expand1 vars1) + (compile-expand-base (car template) ellipsis-valid))) + (loop (cdr template) + (cons + `(,_unquote ,expand1) + expands) + (append vars vars1)))))))) + + (compile-expand-vector + (lambda (template ellipsis-valid) + (let-values (((expand1 vars1) + (compile-expand-base (vector->list template) ellipsis-valid))) + (values + `(,_list->vector ,expand1) + vars1))))) + + (compile-expand-base template ellipsis))) + + (define (check-vars vars-pattern vars-template) + ;;fixme + #t) + + (define (compile-rule ellipsis literals rule) + (let ((pattern (car rule)) + (template (cadr rule))) + (let*-values (((match vars-match) + (compile-match ellipsis literals pattern)) + ((expand vars-expand) + (compile-expand ellipsis (flatten vars-match) template))) + (if (check-vars vars-match vars-expand) + (list vars-match match expand) + 'mismatch)))) + + (define (expand-clauses clauses rename) + (cond ((null? clauses) + `(,_quote (syntax-error "no matching pattern"))) + ((compare (car clauses) 'mismatch) + `(,_syntax-error "invalid rule")) + (else + (let ((vars (list-ref (car clauses) 0)) + (match (list-ref (car clauses) 1)) + (expand (list-ref (car clauses) 2))) + `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) + (,_let ((result (,_call/cc (,_lambda (exit) ,match)))) + (,_if result + ,expand + ,(expand-clauses (cdr clauses) rename)))))))) + + (define (normalize-form form) + (if (and (list? form) (>= (length form) 2)) + (let ((ellipsis '...) + (literals (cadr form)) + (rules (cddr form))) + + (when (symbol? literals) + (set! ellipsis literals) + (set! literals (car rules)) + (set! rules (cdr rules))) + + (if (and (symbol? ellipsis) + (list? literals) + (every? symbol? literals) + (list? rules) + (every? (lambda (l) (and (list? l) (= (length l) 2))) rules)) + (if (member ellipsis literals compare) + `(syntax-rules #f ,literals ,@rules) + `(syntax-rules ,ellipsis ,literals ,@rules)) + #f)) + #f)) + + (let ((form (normalize-form form))) + (if form + (let ((ellipsis (list-ref form 1)) + (literals (list-ref form 2)) + (rules (list-tail form 3))) + (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) + rules))) + `(,_er-macro-transformer + (,_lambda (expr rename cmp) + ,(expand-clauses clauses r))))) + + `(,_syntax-error "malformed syntax-rules")))))) + + (export syntax-rules)) diff --git a/piclib/picrin/test.scm b/piclib/picrin/test.scm index 17a1e41c..d1dfbc9d 100644 --- a/piclib/picrin/test.scm +++ b/piclib/picrin/test.scm @@ -1,7 +1,6 @@ (define-library (picrin test) - (import (scheme base) - (scheme process-context) - (picrin base)) + (import (picrin base) + (picrin syntax-rules)) (define test-counter 0) (define counter 0) @@ -77,7 +76,7 @@ (length fails)) (define (test-exit) - (exit (zero? (test-failure-count)))) + (exit (= (test-failure-count) 0))) (define-syntax test-syntax-error (syntax-rules () diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index 8bf533aa..5303bf84 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -1,429 +1,56 @@ (define-library (scheme base) (import (picrin base) - (picrin macro)) + (picrin macro) + (picrin record) + (picrin syntax-rules)) - (export define - set! - lambda - quote - if - begin - define-syntax) + (export else => _ ...) - ;; core syntax + ;; 4.1.2. Literal expressions - (import (scheme file)) + (export quote) - (define-syntax include - (letrec ((read-file - (lambda (filename) - (let ((port (open-input-file filename))) - (dynamic-wind - (lambda () #f) - (lambda () - (let loop ((expr (read port)) (exprs '())) - (if (eof-object? expr) - (reverse exprs) - (loop (read port) (cons expr exprs))))) - (lambda () - (close-port port))))))) - (er-macro-transformer - (lambda (form rename compare) - (let ((filenames (cdr form))) - (let ((exprs (apply append (map read-file filenames)))) - `(,(rename 'begin) ,@exprs))))))) + ;; 4.1.4. Procedures - (export let let* letrec letrec* - quasiquote unquote unquote-splicing - and or - cond case else => - do when unless - let-syntax letrec-syntax - include - _ ... syntax-error) + (export lambda) + ;; 4.1.5. Conditionals - ;; utility functions + (export if) - (define (walk proc expr) - (cond - ((null? expr) - '()) - ((pair? expr) - (cons (walk proc (car expr)) - (walk proc (cdr expr)))) - ((vector? expr) - (list->vector (map proc (vector->list expr)))) - (else - (proc expr)))) + ;; 4.1.6. Assignments - (define (flatten expr) - (let ((list '())) - (walk - (lambda (x) - (set! list (cons x list))) - expr) - (reverse list))) + (export set!) - (define (reverse* l) - ;; (reverse* '(a b c d . e)) => (e d c b a) - (let loop ((a '()) - (d l)) - (if (pair? d) - (loop (cons (car d) a) (cdr d)) - (cons d a)))) + ;; 4.1.7. Inclusion - (define (every? pred l) - (if (null? l) - #t - (and (pred (car l)) (every? pred (cdr l))))) + (export include) + ;; 4.2.1. Conditionals - ;; extra syntax + (export cond + case + and + or + when + unless) - (define-syntax let*-values - (er-macro-transformer - (lambda (form r c) - (let ((formals (cadr form))) - (if (null? formals) - `(,(r 'let) () ,@(cddr form)) - `(,(r 'call-with-values) (,(r 'lambda) () ,@(cdar formals)) - (,(r 'lambda) (,@(caar formals)) - (,(r 'let*-values) (,@(cdr formals)) - ,@(cddr form))))))))) + ;; 4.2.2. Binding constructs - (define-syntax let-values - (er-macro-transformer - (lambda (form r c) - `(,(r 'let*-values) ,@(cdr form))))) + (export let + let* + letrec + letrec* + let-values + let*-values) - (define uniq - (let ((counter 0)) - (lambda (x) - (let ((sym (string->symbol (string-append "var$" (number->string counter))))) - (set! counter (+ counter 1)) - sym)))) + ;; 4.2.3. Sequencing - (define-syntax define-values - (ir-macro-transformer - (lambda (form inject compare) - (let* ((formal (cadr form)) - (formal* (walk uniq formal)) - (exprs (cddr form))) - `(begin - ,@(map - (lambda (var) `(define ,var #f)) - (flatten formal)) - (call-with-values (lambda () ,@exprs) - (lambda ,formal* - ,@(map - (lambda (var val) `(set! ,var ,val)) - (flatten formal) - (flatten formal*))))))))) + (export begin) - (export let-values - let*-values - define-values) - - (define-syntax syntax-rules - (er-macro-transformer - (lambda (form r compare) - (define _define (r 'define)) - (define _let (r 'let)) - (define _if (r 'if)) - (define _begin (r 'begin)) - (define _lambda (r 'lambda)) - (define _set! (r 'set!)) - (define _not (r 'not)) - (define _and (r 'and)) - (define _car (r 'car)) - (define _cdr (r 'cdr)) - (define _cons (r 'cons)) - (define _pair? (r 'pair?)) - (define _null? (r 'null?)) - (define _symbol? (r 'symbol?)) - (define _vector? (r 'vector?)) - (define _eqv? (r 'eqv?)) - (define _string=? (r 'string=?)) - (define _map (r 'map)) - (define _vector->list (r 'vector->list)) - (define _list->vector (r 'list->vector)) - (define _quote (r 'quote)) - (define _quasiquote (r 'quasiquote)) - (define _unquote (r 'unquote)) - (define _unquote-splicing (r 'unquote-splicing)) - (define _syntax-error (r 'syntax-error)) - (define _call/cc (r 'call/cc)) - (define _er-macro-transformer (r 'er-macro-transformer)) - - (define (var->sym v) - (let loop ((cnt 0) - (v v)) - (if (symbol? v) - (string->symbol - (string-append (symbol->string v) "/" (number->string cnt))) - (loop (+ 1 cnt) (car v))))) - - (define push-var list) - - (define (compile-match ellipsis literals pattern) - (letrec ((compile-match-base - (lambda (pattern) - (cond ((member pattern literals compare) - (values - `(,_if (,_and (,_symbol? expr) (cmp expr (rename ',pattern))) - #f - (exit #f)) - '())) - ((compare pattern (r '_)) (values #f '())) - ((and ellipsis (compare pattern ellipsis)) - (values `(,_syntax-error "invalid pattern") '())) - ((symbol? pattern) - (values `(,_set! ,(var->sym pattern) expr) (list pattern))) - ((pair? pattern) - (compile-match-list pattern)) - ((vector? pattern) - (compile-match-vector pattern)) - ((string? pattern) - (values - `(,_if (,_not (,_string=? ',pattern expr)) - (exit #f)) - '())) - (else - (values - `(,_if (,_not (,_eqv? ',pattern expr)) - (exit #f)) - '()))))) - - (compile-match-list - (lambda (pattern) - (let loop ((pattern pattern) - (matches '()) - (vars '()) - (accessor 'expr)) - (cond ;; (hoge) - ((not (pair? (cdr pattern))) - (let*-values (((match1 vars1) (compile-match-base (car pattern))) - ((match2 vars2) (compile-match-base (cdr pattern)))) - (values - `(,_begin ,@(reverse matches) - (,_if (,_pair? ,accessor) - (,_begin - (,_let ((expr (,_car ,accessor))) - ,match1) - (,_let ((expr (,_cdr ,accessor))) - ,match2)) - (exit #f))) - (append vars (append vars1 vars2))))) - ;; (hoge ... rest args) - ((and ellipsis (compare (cadr pattern) ellipsis)) - (let-values (((match-r vars-r) (compile-match-list-reverse pattern))) - (values - `(,_begin ,@(reverse matches) - (,_let ((expr (,_let loop ((a ()) - (d ,accessor)) - (,_if (,_pair? d) - (loop (,_cons (,_car d) a) (,_cdr d)) - (,_cons d a))))) - ,match-r)) - (append vars vars-r)))) - (else - (let-values (((match1 vars1) (compile-match-base (car pattern)))) - (loop (cdr pattern) - (cons `(,_if (,_pair? ,accessor) - (,_let ((expr (,_car ,accessor))) - ,match1) - (exit #f)) - matches) - (append vars vars1) - `(,_cdr ,accessor)))))))) - - (compile-match-list-reverse - (lambda (pattern) - (let loop ((pattern (reverse* pattern)) - (matches '()) - (vars '()) - (accessor 'expr)) - (cond ((and ellipsis (compare (car pattern) ellipsis)) - (let-values (((match1 vars1) (compile-match-ellipsis (cadr pattern)))) - (values - `(,_begin ,@(reverse matches) - (,_let ((expr ,accessor)) - ,match1)) - (append vars vars1)))) - (else - (let-values (((match1 vars1) (compile-match-base (car pattern)))) - (loop (cdr pattern) - (cons `(,_let ((expr (,_car ,accessor))) ,match1) matches) - (append vars vars1) - `(,_cdr ,accessor)))))))) - - (compile-match-ellipsis - (lambda (pattern) - (let-values (((match vars) (compile-match-base pattern))) - (values - `(,_let loop ((expr expr)) - (,_if (,_not (,_null? expr)) - (,_let ,(map (lambda (var) `(,(var->sym var) '())) vars) - (,_let ((expr (,_car expr))) - ,match) - ,@(map - (lambda (var) - `(,_set! ,(var->sym (push-var var)) - (,_cons ,(var->sym var) ,(var->sym (push-var var))))) - vars) - (loop (,_cdr expr))))) - (map push-var vars))))) - - (compile-match-vector - (lambda (pattern) - (let-values (((match vars) (compile-match-base (vector->list pattern)))) - (values - `(,_if (,_vector? expr) - (,_let ((expr (,_vector->list expr))) - ,match) - (exit #f)) - vars))))) - - (let-values (((match vars) (compile-match-base (cdr pattern)))) - (values `(,_let ((expr (,_cdr expr))) - ,match - #t) - vars)))) - - ;;; compile expand - (define (compile-expand ellipsis reserved template) - (letrec ((compile-expand-base - (lambda (template ellipsis-valid) - (cond ((member template reserved eq?) - (values (var->sym template) (list template))) - ((symbol? template) - (values `(rename ',template) '())) - ((pair? template) - (compile-expand-list template ellipsis-valid)) - ((vector? template) - (compile-expand-vector template ellipsis-valid)) - (else - (values `',template '()))))) - - (compile-expand-list - (lambda (template ellipsis-valid) - (let loop ((template template) - (expands '()) - (vars '())) - (cond ;; (... hoge) - ((and ellipsis-valid - (pair? template) - (compare (car template) ellipsis)) - (if (and (pair? (cdr template)) (null? (cddr template))) - (compile-expand-base (cadr template) #f) - (values '(,_syntax-error "invalid template") '()))) - ;; hoge - ((not (pair? template)) - (let-values (((expand1 vars1) - (compile-expand-base template ellipsis-valid))) - (values - `(,_quasiquote (,@(reverse expands) . (,_unquote ,expand1))) - (append vars vars1)))) - ;; (a ... rest syms) - ((and ellipsis-valid - (pair? (cdr template)) - (compare (cadr template) ellipsis)) - (let-values (((expand1 vars1) - (compile-expand-base (car template) ellipsis-valid))) - (loop (cddr template) - (cons - `(,_unquote-splicing - (,_map (,_lambda ,(map var->sym vars1) ,expand1) - ,@(map (lambda (v) (var->sym (push-var v))) vars1))) - expands) - (append vars (map push-var vars1))))) - (else - (let-values (((expand1 vars1) - (compile-expand-base (car template) ellipsis-valid))) - (loop (cdr template) - (cons - `(,_unquote ,expand1) - expands) - (append vars vars1)))))))) - - (compile-expand-vector - (lambda (template ellipsis-valid) - (let-values (((expand1 vars1) - (compile-expand-base (vector->list template) ellipsis-valid))) - (values - `(,_list->vector ,expand1) - vars1))))) - - (compile-expand-base template ellipsis))) - - (define (check-vars vars-pattern vars-template) - ;;fixme - #t) - - (define (compile-rule ellipsis literals rule) - (let ((pattern (car rule)) - (template (cadr rule))) - (let*-values (((match vars-match) - (compile-match ellipsis literals pattern)) - ((expand vars-expand) - (compile-expand ellipsis (flatten vars-match) template))) - (if (check-vars vars-match vars-expand) - (list vars-match match expand) - 'mismatch)))) - - (define (expand-clauses clauses rename) - (cond ((null? clauses) - `(,_quote (syntax-error "no matching pattern"))) - ((compare (car clauses) 'mismatch) - `(,_syntax-error "invalid rule")) - (else - (let ((vars (list-ref (car clauses) 0)) - (match (list-ref (car clauses) 1)) - (expand (list-ref (car clauses) 2))) - `(,_let ,(map (lambda (v) (list (var->sym v) '())) vars) - (,_let ((result (,_call/cc (,_lambda (exit) ,match)))) - (,_if result - ,expand - ,(expand-clauses (cdr clauses) rename)))))))) - - (define (normalize-form form) - (if (and (list? form) (>= (length form) 2)) - (let ((ellipsis '...) - (literals (cadr form)) - (rules (cddr form))) - - (when (symbol? literals) - (set! ellipsis literals) - (set! literals (car rules)) - (set! rules (cdr rules))) - - (if (and (symbol? ellipsis) - (list? literals) - (every? symbol? literals) - (list? rules) - (every? (lambda (l) (and (list? l) (= (length l) 2))) rules)) - (if (member ellipsis literals compare) - `(syntax-rules #f ,literals ,@rules) - `(syntax-rules ,ellipsis ,literals ,@rules)) - #f)) - #f)) - - (let ((form (normalize-form form))) - (if form - (let ((ellipsis (list-ref form 1)) - (literals (list-ref form 2)) - (rules (list-tail form 3))) - (let ((clauses (map (lambda (rule) (compile-rule ellipsis literals rule)) - rules))) - `(,_er-macro-transformer - (,_lambda (expr rename cmp) - ,(expand-clauses clauses r))))) - - `(,_syntax-error "malformed syntax-rules")))))) - - (export syntax-rules) + ;; 4.2.4. Iteration + (export do) ;; 4.2.6. Dynamic bindings @@ -440,8 +67,8 @@ ,@(map (lambda (var) `(parameter-pop! ,var)) vars) result))))))) - (export parameterize make-parameter) - + (export make-parameter + parameterize) ;; 4.2.7. Exception handling @@ -505,35 +132,80 @@ (export guard) - ;; 5.5 Recored-type definitions + ;; 4.2.8. Quasiquotation - (import (picrin record)) + (export quasiquote + unquote + unquote-splicing) + + ;; 4.3.1. Binding constructs for syntactic keywords + + (export let-syntax + letrec-syntax) + + ;; 4.3.2 Pattern language + + (export syntax-rules) + + ;; 4.3.3. Signaling errors in macro transformers + + (export syntax-error) + + ;; 5.3. Variable definitions + + (export define) + + ;; 5.3.3. Multiple-value definitions + + (export define-values) + + ;; 5.4. Syntax definitions + + (export define-syntax) + + ;; 5.5 Recored-type definitions (export define-record-type) - (export (rename floor-remainder modulo) - (rename truncate-quotient quotient) - (rename truncate-remainder remainder)) - - (export define - lambda - if - quote - set! - begin - define-syntax) + ;; 6.1. Equivalence predicates (export eq? eqv? equal?) - (export boolean? - boolean=? - not) + ;; 6.2. Numbers - (export char? - char->integer - integer->char) + (define (exact-integer? x) + (and (exact? x) + (integer? x))) + + (define (zero? x) + (= x 0)) + + (define (positive? x) + (> x 0)) + + (define (negative? x) + (< x 0)) + + (define (min . args) + (let loop ((args args) (min +inf.0)) + (if (null? args) + min + (loop (cdr args) (if (< (car args) min) + (car args) + min))))) + + (define (max . args) + (let loop ((args args) (max -inf.0)) + (if (null? args) + max + (loop (cdr args) (if (> (car args) max) + (car args) + max))))) + + (define (square x) + (* x x)) (export number? complex? @@ -551,8 +223,8 @@ zero? positive? negative? - odd? - even? + ;; odd? + ;; even? min max + @@ -560,117 +232,29 @@ * / abs - floor-quotient - floor-remainder + ;; floor-quotient + ;; floor-remainder floor/ - truncate-quotient - truncate-remainder + ;; truncate-quotient + ;; truncate-remainder truncate/ - gcd - lcm + ;; gcd + ;; lcm floor ceiling truncate round - exact-integer-sqrt + ;; exact-integer-sqrt square expt number->string - string->number - finite? - infinite? - nan? - exp - log - sin - cos - tan - acos - asin - atan - sqrt) + string->number) - (export vector? - make-vector - vector-length - vector-ref - vector-set! - vector-copy! - vector-copy - vector-append - vector-fill! - list->vector - vector->list) + ;; 6.3. Booleans - (export string? - make-string - string-length - string-ref - string-set! - string=? - string? - string<=? - string>=? - string-copy - string-copy! - string-append - string-fill!) - - (export current-input-port - current-output-port - current-error-port - - port? - input-port? - output-port? - textual-port? - binary-port? - close-port - - open-input-string - open-output-string - get-output-string - open-input-bytevector - open-output-bytevector - get-output-bytevector - - eof-object? - eof-object - - read-char - peek-char - char-ready? - read-line - read-string - - read-u8 - peek-u8 - u8-ready? - read-bytevector - read-bytevector! - - newline - write-char - write-string - write-u8 - write-bytevector - flush-output-port) - - (export with-exception-handler - raise - raise-continuable - error - error-object? - error-object-message - error-object-irritants - read-error? - file-error?) - - (export procedure? - apply - map - for-each) + (export boolean? + boolean=? + not) ;; 6.4 Pairs and lists @@ -702,14 +286,14 @@ assv assoc) - ;; 6.5 Symbols + ;; 6.5. Symbols (export symbol? symbol=? symbol->string string->symbol) - ;; 6.6 Characters + ;; 6.6. Characters (define-macro (define-char-transitive-predicate name op) `(define (,name . cs) @@ -721,56 +305,82 @@ (define-char-transitive-predicate char<=? <=) (define-char-transitive-predicate char>=? >=) - (export char=? + (export char? + char->integer + integer->char + char=? char? char<=? char>=?) - ;; 6.7 String + ;; 6.7. Strings - (define (string->list string . opts) - (let ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (string-length string)))) - (do ((i start (+ i 1)) - (res '())) - ((= i end) - (reverse res)) - (set! res (cons (string-ref string i) res))))) + ;; (define (string->list string . opts) + ;; (let ((start (if (pair? opts) (car opts) 0)) + ;; (end (if (>= (length opts) 2) + ;; (cadr opts) + ;; (string-length string)))) + ;; (do ((i start (+ i 1)) + ;; (res '())) + ;; ((= i end) + ;; (reverse res)) + ;; (set! res (cons (string-ref string i) res))))) - (define (list->string list) - (let ((len (length list))) - (let ((v (make-string len))) - (do ((i 0 (+ i 1)) - (l list (cdr l))) - ((= i len) - v) - (string-set! v i (car l)))))) + ;; (define (list->string list) + ;; (let ((len (length list))) + ;; (let ((v (make-string len))) + ;; (do ((i 0 (+ i 1)) + ;; (l list (cdr l))) + ;; ((= i len) + ;; v) + ;; (string-set! v i (car l)))))) - (define (string . objs) - (list->string objs)) + ;; (define (string . objs) + ;; (list->string objs)) - (export string - string->list - list->string - (rename string-copy substring)) + ;; (export string + ;; string->list + ;; list->string + ;; (rename string-copy substring)) - ;; 6.8. Vector + (export string? + string-length + string-ref + string-copy + string-append + string=? + string? + string<=? + string>=?) + + ;; 6.8. Vectors (define (vector . objs) (list->vector objs)) - (define (vector->string . args) - (list->string (apply vector->list args))) + ;; (define (vector->string . args) + ;; (list->string (apply vector->list args))) - (define (string->vector . args) - (list->vector (apply string->list args))) + ;; (define (string->vector . args) + ;; (list->vector (apply string->list args))) - (export vector vector->string string->vector) + ;; (export vector vector->string string->vector) - ;; 6.9 bytevector + (export vector? + make-vector + vector-length + vector-ref + vector-set! + vector-copy! + vector-copy + vector-append + vector-fill! + list->vector + vector->list) + + ;; 6.9. bytevector (define (bytevector->list v start end) (do ((i start (+ i 1)) @@ -791,42 +401,72 @@ (define (bytevector . objs) (list->bytevector objs)) - (define (utf8->string v . opts) - (let ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (bytevector-length v)))) - (list->string (map integer->char (bytevector->list v start end))))) + ;; (define (utf8->string v . opts) + ;; (let ((start (if (pair? opts) (car opts) 0)) + ;; (end (if (>= (length opts) 2) + ;; (cadr opts) + ;; (bytevector-length v)))) + ;; (list->string (map integer->char (bytevector->list v start end))))) - (define (string->utf8 s . opts) - (let ((start (if (pair? opts) (car opts) 0)) - (end (if (>= (length opts) 2) - (cadr opts) - (string-length s)))) - (list->bytevector (map char->integer (string->list s start end))))) + ;; (define (string->utf8 s . opts) + ;; (let ((start (if (pair? opts) (car opts) 0)) + ;; (end (if (>= (length opts) 2) + ;; (cadr opts) + ;; (string-length s)))) + ;; (list->bytevector (map char->integer (string->list s start end))))) - (export bytevector - bytevector->list - list->bytevector - utf8->string - string->utf8) + ;; (export bytevector + ;; bytevector->list + ;; list->bytevector + ;; utf8->string + ;; string->utf8) - ;; 6.10 control features + (export bytevector? + make-bytevector + bytevector-length + bytevector-u8-ref + bytevector-u8-set! + bytevector-copy! + bytevector-append) - (define (string-map f . strings) - (list->string (apply map f (map string->list strings)))) + ;; 6.10. Control features - (define (string-for-each f . strings) - (apply for-each f (map string->list strings))) + ;; (define (string-map f . strings) + ;; (list->string (apply map f (map string->list strings)))) - (define (vector-map f . vectors) - (list->vector (apply map f (map vector->list vectors)))) + ;; (define (string-for-each f . strings) + ;; (apply for-each f (map string->list strings))) - (define (vector-for-each f . vectors) - (apply for-each f (map vector->list vectors))) + ;; (define (vector-map f . vectors) + ;; (list->vector (apply map f (map vector->list vectors)))) - (export string-map string-for-each - vector-map vector-for-each) + ;; (define (vector-for-each f . vectors) + ;; (apply for-each f (map vector->list vectors))) + + ;; (export string-map string-for-each + ;; vector-map vector-for-each) + + (export procedure? + apply + map + for-each + call-with-current-continuation + call/cc + dynamic-wind + values + call-with-values) + + ;; 6.11. Exceptions + + (export with-exception-handler + raise + raise-continuable + error + error-object? + error-object-message + error-object-irritants + read-error? + file-error?) ;; 6.13. Input and output @@ -836,4 +476,47 @@ (lambda () (proc port)) (lambda () (close-port port)))) - (export call-with-port)) + (export current-input-port + current-output-port + current-error-port + + call-with-port + + port? + input-port? + output-port? + textual-port? + binary-port? + + close-port + (rename close-port close-input-port) + (rename close-port close-output-port) + + open-input-string + open-output-string + get-output-string + open-input-bytevector + open-output-bytevector + get-output-bytevector + + eof-object? + eof-object + + read-char + peek-char + char-ready? + read-line + read-string + + read-u8 + peek-u8 + u8-ready? + read-bytevector + read-bytevector! + + newline + write-char + write-string + write-u8 + write-bytevector + flush-output-port)) diff --git a/piclib/scheme/eval.scm b/piclib/scheme/eval.scm index 2a4f3b0f..54574c03 100644 --- a/piclib/scheme/eval.scm +++ b/piclib/scheme/eval.scm @@ -1,15 +1,5 @@ (define-library (scheme eval) - (import (scheme base)) - - (define (null-environment n) - (if (not (= n 5)) - (error "unsupported environment version" n) - '(scheme null))) - - (define (scheme-report-environment n) - (if (not (= n 5)) - (error "unsupported environment version" n) - '(scheme r5rs))) + (import (picrin base)) (define environment (let ((counter 0)) @@ -24,6 +14,4 @@ '(scheme base)) library-name)))) - (export null-environment - scheme-report-environment - environment)) + (export environment eval)) diff --git a/piclib/scheme/file.scm b/piclib/scheme/file.scm index b449e49d..8e2b7300 100644 --- a/piclib/scheme/file.scm +++ b/piclib/scheme/file.scm @@ -1,5 +1,6 @@ (define-library (scheme file) - (import (scheme base)) + (import (picrin base) + (scheme base)) (define (call-with-input-file filename callback) (call-with-port (open-input-file filename) callback)) @@ -19,7 +20,13 @@ (parameterize ((current-output-port port)) (thunk))))) - (export call-with-input-file + (export open-input-file + open-binary-input-file + open-output-file + open-binary-output-file + delete-file + file-exists? + call-with-input-file call-with-output-file with-input-from-file with-output-to-file)) diff --git a/src/eval.c b/src/eval.c deleted file mode 100644 index dd31829c..00000000 --- a/src/eval.c +++ /dev/null @@ -1,29 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/macro.h" - -static pic_value -pic_eval_eval(pic_state *pic) -{ - pic_value program, spec; - struct pic_lib *lib; - - pic_get_args(pic, "oo", &program, &spec); - - lib = pic_find_library(pic, spec); - if (lib == NULL) { - pic_errorf(pic, "no library found: ~s", spec); - } - return pic_eval(pic, program, lib); -} - -void -pic_init_eval(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme eval)") { - pic_defun(pic, "eval", pic_eval_eval); - } -} diff --git a/src/file.c b/src/file.c deleted file mode 100644 index befac195..00000000 --- a/src/file.c +++ /dev/null @@ -1,119 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/port.h" -#include "picrin/error.h" - -static noreturn void -file_error(pic_state *pic, const char *msg) -{ - pic_throw(pic, PIC_ERROR_FILE, msg, pic_nil_value()); -} - -static pic_value -generic_open_file(pic_state *pic, const char *fname, char *mode, short flags) -{ - struct pic_port *port; - xFILE *file; - - file = xfopen(fname, mode); - if (! file) { - file_error(pic, "could not open file"); - } - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = flags; - port->status = PIC_PORT_OPEN; - - return pic_obj_value(port); -} - -pic_value -pic_file_open_input_file(pic_state *pic) -{ - static const short flags = PIC_PORT_IN | PIC_PORT_TEXT; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "r", flags); -} - -pic_value -pic_file_open_input_binary_file(pic_state *pic) -{ - static const short flags = PIC_PORT_IN | PIC_PORT_BINARY; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "rb", flags); -} - -pic_value -pic_file_open_output_file(pic_state *pic) -{ - static const short flags = PIC_PORT_OUT | PIC_PORT_TEXT; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "w", flags); -} - -pic_value -pic_file_open_output_binary_file(pic_state *pic) -{ - static const short flags = PIC_PORT_OUT | PIC_PORT_BINARY; - char *fname; - - pic_get_args(pic, "z", &fname); - - return generic_open_file(pic, fname, "wb", flags); -} - -pic_value -pic_file_exists_p(pic_state *pic) -{ - char *fname; - FILE *fp; - - pic_get_args(pic, "z", &fname); - - fp = fopen(fname, "r"); - if (fp) { - fclose(fp); - return pic_true_value(); - } else { - return pic_false_value(); - } -} - -pic_value -pic_file_delete(pic_state *pic) -{ - char *fname; - - pic_get_args(pic, "z", &fname); - - if (remove(fname) != 0) { - file_error(pic, "file cannot be deleted"); - } - return pic_none_value(); -} - -void -pic_init_file(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme file)") { - pic_defun(pic, "open-input-file", pic_file_open_input_file); - pic_defun(pic, "open-input-binary-file", pic_file_open_input_binary_file); - pic_defun(pic, "open-output-file", pic_file_open_output_file); - pic_defun(pic, "open-output-binary-file", pic_file_open_output_binary_file); - pic_defun(pic, "file-exists?", pic_file_exists_p); - pic_defun(pic, "delete-file", pic_file_delete); - } -} diff --git a/src/init.c b/src/init.c deleted file mode 100644 index 6ff9eac0..00000000 --- a/src/init.c +++ /dev/null @@ -1,70 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/pair.h" - -static pic_value -pic_features(pic_state *pic) -{ - pic_value features = pic_nil_value(); - - pic_get_args(pic, ""); - - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features); - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features); - pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features); - - return features; -} - -static pic_value -pic_libraries(pic_state *pic) -{ - pic_value libs = pic_nil_value(), lib; - - pic_get_args(pic, ""); - - pic_for_each (lib, pic->libs) { - libs = pic_cons(pic, pic_car(pic, lib), libs); - } - - return libs; -} - -void pic_init_eval(pic_state *); -void pic_init_file(pic_state *); -void pic_init_load(pic_state *); -void pic_init_macro2(pic_state *); -void pic_init_system(pic_state *); -void pic_init_time(pic_state *); - -void pic_init_contrib(pic_state *); - -void pic_load_piclib(pic_state *); - -void -pic_init_picrin(pic_state *pic) -{ - pic_deflibrary (pic, "(picrin library)") { - pic_defun(pic, "libraries", pic_libraries); - } - - pic_deflibrary (pic, "(scheme base)") { - pic_defun(pic, "features", pic_features); - - pic_init_eval(pic); - pic_init_file(pic); - pic_init_load(pic); - pic_init_macro2(pic); - pic_init_system(pic); - pic_init_time(pic); - - pic_init_contrib(pic); - - pic_load_piclib(pic); - } -} diff --git a/src/load.c b/src/load.c deleted file mode 100644 index d8c3af7f..00000000 --- a/src/load.c +++ /dev/null @@ -1,79 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" -#include "picrin/pair.h" -#include "picrin/port.h" -#include "picrin/error.h" - -void -pic_load_port(pic_state *pic, struct pic_port *port) -{ - pic_value form; - - pic_try { - size_t ai = pic_gc_arena_preserve(pic); - - while (! pic_eof_p(form = pic_read(pic, port))) { - pic_eval(pic, form, pic->lib); - - pic_gc_arena_restore(pic, ai); - } - } - pic_catch { - pic_errorf(pic, "load error: %s", pic_errmsg(pic)); - } -} - -void -pic_load_cstr(pic_state *pic, const char *src) -{ - struct pic_port *port = pic_open_input_string(pic, src); - - pic_load_port(pic, port); - - pic_close_port(pic, port); -} - -void -pic_load(pic_state *pic, const char *filename) -{ - struct pic_port *port; - xFILE *file; - - file = xfopen(filename, "r"); - if (file == NULL) { - pic_errorf(pic, "could not open file: %s", filename); - } - - port = (struct pic_port *)pic_obj_alloc(pic, sizeof(struct pic_port), PIC_TT_PORT); - port->file = file; - port->flags = PIC_PORT_IN | PIC_PORT_TEXT; - port->status = PIC_PORT_OPEN; - - pic_load_port(pic, port); - - pic_close_port(pic, port); -} - -static pic_value -pic_load_load(pic_state *pic) -{ - pic_value envid; - char *fn; - - pic_get_args(pic, "z|o", &fn, &envid); - - pic_load(pic, fn); - - return pic_none_value(); -} - -void -pic_init_load(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme load)") { - pic_defun(pic, "load", pic_load_load); - } -} diff --git a/src/macro.c b/src/macro.c deleted file mode 100644 index 84237ebc..00000000 --- a/src/macro.c +++ /dev/null @@ -1,47 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include "picrin.h" - -static pic_value -pic_macro_gensym(pic_state *pic) -{ - static const char skel[] = ".g"; - pic_sym uniq; - - pic_get_args(pic, ""); - - uniq = pic_gensym(pic, pic_intern_cstr(pic, skel)); - return pic_sym_value(uniq); -} - -static pic_value -pic_macro_ungensym(pic_state *pic) -{ - pic_sym sym; - - pic_get_args(pic, "m", &sym); - - return pic_sym_value(pic_ungensym(pic, sym)); -} - -static pic_value -pic_macro_macroexpand(pic_state *pic) -{ - pic_value expr; - - pic_get_args(pic, "o", &expr); - - return pic_macroexpand(pic, expr, pic->lib); -} - -void -pic_init_macro2(pic_state *pic) -{ - pic_deflibrary (pic, "(picrin macro)") { - pic_defun(pic, "gensym", pic_macro_gensym); - pic_defun(pic, "ungensym", pic_macro_ungensym); - pic_defun(pic, "macroexpand", pic_macro_macroexpand); - } -} diff --git a/src/main.c b/src/main.c index 14f2f9f0..9bd66a92 100644 --- a/src/main.c +++ b/src/main.c @@ -3,8 +3,55 @@ */ #include "picrin.h" +#include "picrin/pair.h" #include "picrin/error.h" +static pic_value +pic_features(pic_state *pic) +{ + pic_value features = pic_nil_value(); + + pic_get_args(pic, ""); + + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "r7rs")), features); + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "ieee-float")), features); + pic_push(pic, pic_sym_value(pic_intern_cstr(pic, "picrin")), features); + + return features; +} + +static pic_value +pic_libraries(pic_state *pic) +{ + pic_value libs = pic_nil_value(), lib; + + pic_get_args(pic, ""); + + pic_for_each (lib, pic->libs) { + libs = pic_cons(pic, pic_car(pic, lib), libs); + } + + return libs; +} + +void pic_init_contrib(pic_state *); +void pic_load_piclib(pic_state *); + +void +pic_init_picrin(pic_state *pic) +{ + pic_deflibrary (pic, "(picrin library)") { + pic_defun(pic, "libraries", pic_libraries); + } + + pic_deflibrary (pic, "(scheme base)") { + pic_defun(pic, "features", pic_features); + + pic_init_contrib(pic); + pic_load_piclib(pic); + } +} + int main(int argc, char *argv[], char **envp) { diff --git a/src/system.c b/src/system.c deleted file mode 100644 index 20203d27..00000000 --- a/src/system.c +++ /dev/null @@ -1,136 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" -#include "picrin/string.h" -#include "picrin/pair.h" -#include "picrin/cont.h" - -static pic_value -pic_system_cmdline(pic_state *pic) -{ - pic_value v = pic_nil_value(); - int i; - - pic_get_args(pic, ""); - - for (i = 0; i < pic->argc; ++i) { - size_t ai = pic_gc_arena_preserve(pic); - - v = pic_cons(pic, pic_obj_value(pic_str_new_cstr(pic, pic->argv[i])), v); - pic_gc_arena_restore(pic, ai); - } - - return pic_reverse(pic, v); -} - -static pic_value -pic_system_exit(pic_state *pic) -{ - pic_value v; - int argc, status = EXIT_SUCCESS; - - argc = pic_get_args(pic, "|o", &v); - if (argc == 1) { - switch (pic_type(v)) { - case PIC_TT_FLOAT: - status = (int)pic_float(v); - break; - case PIC_TT_INT: - status = pic_int(v); - break; - default: - break; - } - } - - pic_close(pic); - - exit(status); -} - -static pic_value -pic_system_emergency_exit(pic_state *pic) -{ - pic_value v; - int argc, status = EXIT_FAILURE; - - argc = pic_get_args(pic, "|o", &v); - if (argc == 1) { - switch (pic_type(v)) { - case PIC_TT_FLOAT: - status = (int)pic_float(v); - break; - case PIC_TT_INT: - status = pic_int(v); - break; - default: - break; - } - } - - _Exit(status); -} - -static pic_value -pic_system_getenv(pic_state *pic) -{ - char *str, *val; - - pic_get_args(pic, "z", &str); - - val = getenv(str); - - if (val == NULL) - return pic_nil_value(); - else - return pic_obj_value(pic_str_new_cstr(pic, val)); -} - -static pic_value -pic_system_getenvs(pic_state *pic) -{ - char **envp; - pic_value data = pic_nil_value(); - size_t ai = pic_gc_arena_preserve(pic); - - pic_get_args(pic, ""); - - if (! pic->envp) { - return pic_nil_value(); - } - - for (envp = pic->envp; *envp; ++envp) { - pic_str *key, *val; - int i; - - for (i = 0; (*envp)[i] != '='; ++i) - ; - - key = pic_str_new(pic, *envp, i); - val = pic_str_new_cstr(pic, getenv(pic_str_cstr(key))); - - /* push */ - data = pic_acons(pic, pic_obj_value(key), pic_obj_value(val), data); - - pic_gc_arena_restore(pic, ai); - pic_gc_protect(pic, data); - } - - return data; -} - -void -pic_init_system(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme process-context)") { - pic_defun(pic, "command-line", pic_system_cmdline); - pic_defun(pic, "exit", pic_system_exit); - pic_defun(pic, "emergency-exit", pic_system_emergency_exit); - pic_defun(pic, "get-environment-variable", pic_system_getenv); - pic_defun(pic, "get-environment-variables", pic_system_getenvs); - } -} diff --git a/src/time.c b/src/time.c deleted file mode 100644 index 8e42dc8e..00000000 --- a/src/time.c +++ /dev/null @@ -1,49 +0,0 @@ -/** - * See Copyright Notice in picrin.h - */ - -#include - -#include "picrin.h" - -#define UTC_TAI_DIFF 35 - -static pic_value -pic_current_second(pic_state *pic) -{ - time_t t; - - pic_get_args(pic, ""); - - time(&t); - return pic_float_value((double)t + UTC_TAI_DIFF); -} - -static pic_value -pic_current_jiffy(pic_state *pic) -{ - clock_t c; - - pic_get_args(pic, ""); - - c = clock(); - return pic_int_value(c); -} - -static pic_value -pic_jiffies_per_second(pic_state *pic) -{ - pic_get_args(pic, ""); - - return pic_int_value(CLOCKS_PER_SEC); -} - -void -pic_init_time(pic_state *pic) -{ - pic_deflibrary (pic, "(scheme time)") { - pic_defun(pic, "current-second", pic_current_second); - pic_defun(pic, "current-jiffy", pic_current_jiffy); - pic_defun(pic, "jiffies-per-second", pic_jiffies_per_second); - } -}