diff --git a/CHANGELOG.md b/CHANGELOG.md index 5fc2a1e79..d04fcb185 100755 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,7 @@ * add R7RS `parameterize` and `make-parameter` * add `shuffle` function * add support to ES Modules [#254](https://github.com/jcubic/lips/issues/254) +* add support for `(scheme-report-environment 7)` ### Bugfix * remove evaluating of async list data as first argument * fix `number->string` for binary numbers diff --git a/dist/std.min.scm b/dist/std.min.scm index bd9c61b32..0819d7f34 100644 --- a/dist/std.min.scm +++ b/dist/std.min.scm @@ -267,7 +267,7 @@ (define (with-output-to-file string thunk) (let* ((port (open-output-file string)) (env **interaction-environment**) (internal-env (env.get (quote **internal-env**))) (old-stdout (internal-env.get "stdout"))) (internal-env.set "stdout" port) (try (thunk) (finally (internal-env.set "stdout" old-stdout) (close-output-port port))))) (define (file-exists? filename) (new Promise (lambda (resolve) (let ((fs (--> lips.env (get (quote **internal-env**)) (get (quote fs))))) (if (null? fs) (throw (new Error "file-exists?: fs not defined")) (fs.stat filename (lambda (err stat) (if (null? err) (resolve (stat.isFile)) (resolve #f))))))))) (define open-output-file (let ((open)) (lambda (filename) "(open-output-file filename)\u000A\u000AFunction that opens file and return port that can be used for writing. If file\u000Aexists it will throw an Error." (typecheck "open-output-file" filename "string") (if (not (procedure? open)) (set! open (%fs-promisify-proc (quote open) "open-output-file"))) (if (file-exists? filename) (throw (new Error "open-output-file: file exists")) (lips.OutputFilePort filename (open filename "w")))))) -(define (scheme-report-environment version) "(scheme-report-environment version)\u000A\u000AReturns new Environment object for given Scheme Spec version.\u000AOnly argument 5 is supported that create environment for R5RS." (typecheck "scheme-report-environment" version "number") (case version ((5) (%make-env "R5RS" * + - / < <= = > >= abs acos and angle append apply asin assoc assq assv atan begin boolean? caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call-with-current-continuation call-with-input-file call-with-output-file call-with-values car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char=? char>? char? close-input-port close-output-port complex? cond cons cos current-input-port current-output-port define define-syntax delay denominator display do dynamic-wind eof-object? eq? equal? eqv? eval even? exact->inexact exact? exp expt floor for-each force gcd if imag-part inexact->exact inexact? input-port? integer->char integer? interaction-environment lambda lcm length let let* let-syntax letrec letrec-syntax list list->string list->vector list-ref list-tail list? load log magnitude make-polar make-rectangular make-string make-vector map max member memq memv min modulo negative? newline not null-environment null? number->string number? numerator odd? open-input-file open-output-file or output-port? pair? peek-char positive? procedure? quasiquote quote quotient rational? rationalize read read-char real-part real? remainder reverse round scheme-report-environment set! set-car! set-cdr! sin sqrt string string->list string->number string->symbol string-append string-ci<=? string-ci=? string-ci>? string-copy string-fill! string-length string-ref string-set! string<=? string=? string>? string? substring symbol->string symbol? tan truncate values vector vector->list vector-fill! vector-length vector-ref vector-set! vector? with-input-from-file with-output-to-file write write-char zero?)) ((7) (throw (new Error "not yet implemented"))) (else (throw (new Error (string-append "scheme-report-environment: version " (number->string version) " not supported")))))) +(define (scheme-report-environment version) "(scheme-report-environment version)\u000A\u000AReturns new Environment object for given Scheme Spec version.\u000AOnly argument 5 is supported that create environment for R5RS." (typecheck "scheme-report-environment" version "number") (case version ((5) (%make-env "R5RS" * + - / < <= = > >= abs acos and angle append apply asin assoc assq assv atan begin boolean? caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call-with-current-continuation call-with-input-file call-with-output-file call-with-values car case cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char->integer char-alphabetic? char-ci<=? char-ci=? char-ci>? char-downcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? char<=? char=? char>? char? close-input-port close-output-port complex? cond cons cos current-input-port current-output-port define define-syntax delay denominator display do dynamic-wind eof-object? eq? equal? eqv? eval even? exact->inexact exact? exp expt floor for-each force gcd if imag-part inexact->exact inexact? input-port? integer->char integer? interaction-environment lambda lcm length let let* let-syntax letrec letrec-syntax list list->string list->vector list-ref list-tail list? load log magnitude make-polar make-rectangular make-string make-vector map max member memq memv min modulo negative? newline not null-environment null? number->string number? numerator odd? open-input-file open-output-file or output-port? pair? peek-char positive? procedure? quasiquote quote quotient rational? rationalize read read-char real-part real? remainder reverse round scheme-report-environment set! set-car! set-cdr! sin sqrt string string->list string->number string->symbol string-append string-ci<=? string-ci=? string-ci>? string-copy string-fill! string-length string-ref string-set! string<=? string=? string>? string? substring symbol->string symbol? tan truncate values vector vector->list vector-fill! vector-length vector-ref vector-set! vector? with-input-from-file with-output-to-file write write-char zero?)) ((7) (%make-env "R7RS" - * / _ + < <= = => > >= abs acos and angle append apply asin assoc assq assv atan begin binary-port? boolean? boolean=? bytevector bytevector? bytevector-append bytevector-copy bytevector-copy! bytevector-length bytevector-u8-ref bytevector-u8-set! caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call/cc call-with-current-continuation call-with-input-file call-with-output-file call-with-port call-with-values car case case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr ceiling char? char? char>=? char->integer char-alphabetic? char-ci? char-ci>=? char-downcase char-foldcase char-lower-case? char-numeric? char-ready? char-upcase char-upper-case? char-whitespace? close-input-port close-output-port close-port command-line complex? cond cond-expand cons cos current-error-port current-input-port current-jiffy current-output-port current-second define define-record-type define-syntax define-values delay delay-force delete-file denominator digit-value display do dynamic-wind else emergency-exit environment eof-object eof-object? eq? equal? eqv? error error-object? error-object-irritants error-object-message eval even? exact exact? exact-integer? exact-integer-sqrt exit exp expt features file-exists? finite? floor floor/ floor-quotient floor-remainder flush-output-port force for-each gcd get-environment-variable get-environment-variables get-output-bytevector get-output-string guard if imag-part import include include-ci inexact inexact? infinite? input-port? input-port-open? integer? integer->char interaction-environment interaction-environment jiffies-per-second lambda lcm length let let* let*-values letrec letrec* letrec-syntax let-syntax let-values list list? list->string list->vector list-copy list-ref list-set! list-tail load log magnitude make-bytevector make-list make-parameter make-polar make-promise make-rectangular make-string make-vector map max member memq memv min modulo nan? negative? newline not null? number? number->string numerator odd? open-binary-input-file open-binary-output-file open-input-bytevector open-input-file open-input-string open-output-bytevector open-output-file open-output-string or output-port? output-port-open? pair? parameterize peek-char peek-u8 port? positive? procedure? quasiquote quote quotient raise raise-continuable rational? rationalize read read-bytevector read-bytevector! read-char read-line read-string read-u8 real? real-part remainder reverse round scheme-report-environment set! set-car! set-cdr! sin sqrt square string string? string? string>=? string->list string->number string->symbol string->utf8 string->vector string-append string-ci? string-ci>=? string-copy string-copy! string-downcase string-fill! string-foldcase string-for-each string-length string-map string-ref string-set! string-upcase substring symbol? symbol=? symbol->string syntax-error syntax-rules tan textual-port? truncate truncate/ truncate-quotient truncate-remainder u8-ready? unless unquote unquote-splicing utf8->string values vector vector? vector->list vector->string vector-append vector-copy vector-copy! vector-fill! vector-for-each vector-length vector-map vector-ref vector-set! when with-exception-handler with-input-from-file with-output-to-file write write-bytevector write-char write-shared write-simple write-string write-u8 zero?)) (else (throw (new Error (string-append "scheme-report-environment: version " (number->string version) " not supported")))))) (define-macro (%make-vector prefix type help) "(%make-vector prefix type help)\u000A\u000AMega-helper macro that creates a list of functions for single byte vectors\u000Abased on typed arrays from JavaScript." (letrec ((prefix-str (symbol->string prefix)) (type-str (symbol->string type)) (l-type (--> type-str (toLowerCase))) (static (lambda (name) (string->symbol (format "~a.~a" type-str name)))) (TypedArray.from (static "from")) (fn-name (lambda (str) (string->symbol (format str prefix-str)))) (type-vector (fn-name "~avector")) (make-vector (fn-name "make-~avector")) (vector? (fn-name "~avector?")) (vector-in-range? (fn-name "%~avector-in-range?")) (vector-ref (fn-name "~avector-ref")) (repr-str (format "#~a" prefix-str)) (vector-length (fn-name "~avector-length")) (vector->list (fn-name "~avector->list")) (vector-set! (fn-name "~avector-set!")) (list->tvector (fn-name "list->~avector")) (vector->tvector (fn-name "vector->~avector"))) (quasiquote (begin (define ((unquote type-vector) . args) (unquote (format "(~a v1 v2 ...)\u000A\u000ACreate ~a from give arguments." type-vector help)) ((unquote TypedArray.from) (list->vector args))) (define ((unquote vector-length) v) (unquote (format "(~a v)\u000A\u000Areturn length of ~a." vector-length help)) (typecheck (unquote (symbol->string vector-length)) v (unquote l-type)) v.length) (define ((unquote make-vector) k . fill) (unquote (format "(~a k fill)\u000A\u000AAllocate new ~a of length k, with optional initial values." make-vector help)) (let ((v (new (unquote type) k))) (if (not (null? fill)) (--> v (fill (car fill)))) v)) (define ((unquote vector?) x) (unquote (format "(~a x)\u000A\u000AReturns #t of argument is ~a otherwise it return #f." vector? help)) (and (object? x) (equal? (. x (quote constructor)) (unquote type)))) (define ((unquote vector-in-range?) vector k) (unquote (format "(~a vector k)\u000A\u000AFunction that tests if index is range for ~a." vector-in-range? help)) (typecheck (unquote (symbol->string vector-in-range?)) vector (unquote l-type)) (typecheck (unquote (symbol->string vector-in-range?)) k "number") (let ((len (length vector))) (and (>= k 0) (< k len)))) (define ((unquote vector-ref) vector k) (unquote (format "(~a vector k)\u000A\u000AReturns value from vector at index k. If index is out of range it throw exception." vector-ref help)) (typecheck (unquote (symbol->string vector-ref)) vector (unquote l-type)) (typecheck (unquote (symbol->string vector-ref)) k "number") (if (not ((unquote vector-in-range?) vector k)) (throw (new Error (unquote (format "~a index out of range" vector-ref)))) (. vector k))) (define ((unquote vector->list) vector) (typecheck (unquote (symbol->string vector->list)) vector (unquote l-type)) (vector->list (Array.from vector))) (define ((unquote vector-set!) vector k v) (unquote (format "(~a vector k)\u000A\u000AFunction set value of ~a at index k. If index is out of range it throw exception." vector-set! help)) (typecheck (unquote (symbol->string vector-set!)) vector (unquote l-type)) (typecheck (unquote (symbol->string vector-set!)) k "number") (if (not ((unquote vector-in-range?) vector k)) (throw (new Error (unquote (format "~a index out of range" vector-set!)))) (set-obj! vector k v))) (define ((unquote list->tvector) lst) (typecheck (unquote (symbol->string list->tvector)) lst "pair") (apply (unquote vector) lst)) (define ((unquote vector->tvector) vector) (typecheck (unquote (symbol->string vector->tvector)) vector "array") ((unquote TypedArray.from) vector)) (set-special! (unquote repr-str) (quote (unquote type-vector)) lips.specials.SPLICE) (set-repr! (unquote type) (lambda (x _quote) (string-append (unquote repr-str) (repr ((unquote vector->list) x) _quote)))))))) (%make-vector u8 Uint8Array "unsigned 8-bit integer vector (C unsigned char)") (%make-vector s8 Int8Array "signed 8-bit integer vector (C signed char)") diff --git a/dist/std.scm b/dist/std.scm index 1083edad1..27801ce62 100644 --- a/dist/std.scm +++ b/dist/std.scm @@ -2966,6 +2966,7 @@ (finally (close-output-port p))))) +;; ----------------------------------------------------------------------------- (define (with-input-from-port port thunk) "(with-input-from-port port thunk) @@ -3074,10 +3075,48 @@ string>=? string>? string? substring symbol->string symbol? tan truncate values vector vector->list vector-fill! vector-length vector-ref vector-set! vector? with-input-from-file with-output-to-file write write-char zero?)) - ((7) (throw (new Error "not yet implemented")) #;(%make-env "R7RS")) - (else (throw (new Error (string-append "scheme-report-environment: version " - (number->string version) - " not supported")))))) + ((7) (%make-env "R7RS" - * / _ + < <= = => > >= abs acos and angle append apply asin assoc assq + assv atan begin binary-port? boolean? boolean=? bytevector bytevector? bytevector-append + bytevector-copy bytevector-copy! bytevector-length bytevector-u8-ref bytevector-u8-set! caaaar + caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call/cc + call-with-current-continuation call-with-input-file call-with-output-file call-with-port + call-with-values car case case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr + cddar cdddar cddddr cdddr cddr cdr ceiling char? char? char>=? + char->integer char-alphabetic? char-ci? char-ci>=? + char-downcase char-foldcase char-lower-case? char-numeric? char-ready? char-upcase + char-upper-case? char-whitespace? close-input-port close-output-port close-port command-line + complex? cond cond-expand cons cos current-error-port current-input-port current-jiffy + current-output-port current-second define define-record-type define-syntax define-values delay + delay-force delete-file denominator digit-value display do dynamic-wind else emergency-exit + environment eof-object eof-object? eq? equal? eqv? error error-object? error-object-irritants + error-object-message eval even? exact exact? exact-integer? exact-integer-sqrt exit exp expt + features file-exists? finite? floor floor/ floor-quotient floor-remainder flush-output-port force + for-each gcd get-environment-variable get-environment-variables get-output-bytevector + get-output-string guard if imag-part import include include-ci inexact inexact? infinite? + input-port? input-port-open? integer? integer->char interaction-environment + interaction-environment jiffies-per-second lambda lcm length let let* let*-values letrec letrec* + letrec-syntax let-syntax let-values list list? list->string list->vector list-copy list-ref + list-set! list-tail load log magnitude make-bytevector make-list make-parameter make-polar + make-promise make-rectangular make-string make-vector map max member memq memv min modulo nan? + negative? newline not null? number? number->string numerator odd? open-binary-input-file + open-binary-output-file open-input-bytevector open-input-file open-input-string + open-output-bytevector open-output-file open-output-string or output-port? output-port-open? pair? + parameterize peek-char peek-u8 port? positive? procedure? quasiquote quote quotient raise + raise-continuable rational? rationalize read read-bytevector read-bytevector! read-char read-line + read-string read-u8 real? real-part remainder reverse round scheme-report-environment set! + set-car! set-cdr! sin sqrt square string string? string? + string>=? string->list string->number string->symbol string->utf8 string->vector string-append + string-ci? string-ci>=? string-copy string-copy! + string-downcase string-fill! string-foldcase string-for-each string-length string-map string-ref + string-set! string-upcase substring symbol? symbol=? symbol->string syntax-error syntax-rules tan + textual-port? truncate truncate/ truncate-quotient truncate-remainder u8-ready? unless unquote + unquote-splicing utf8->string values vector vector? vector->list vector->string vector-append + vector-copy vector-copy! vector-fill! vector-for-each vector-length vector-map vector-ref + vector-set! when with-exception-handler with-input-from-file with-output-to-file write + write-bytevector write-char write-shared write-simple write-string write-u8 zero?)) + (else (throw (new Error (string-append "scheme-report-environment: version " + (number->string version) + " not supported")))))) ;; Implementation of byte vector functions - SRFI-4 and SRFI-160 ;; ;; original code was based on https://small.r7rs.org/wiki/NumericVectorsCowan/17/ diff --git a/dist/std.xcb b/dist/std.xcb index 4c9bb96d2..3d830a4a4 100644 Binary files a/dist/std.xcb and b/dist/std.xcb differ diff --git a/lib/R5RS.scm b/lib/R5RS.scm index 47e5c704c..150ef8dd2 100755 --- a/lib/R5RS.scm +++ b/lib/R5RS.scm @@ -1398,6 +1398,7 @@ (finally (close-output-port p))))) +;; ----------------------------------------------------------------------------- (define (with-input-from-port port thunk) "(with-input-from-port port thunk) @@ -1506,7 +1507,45 @@ string>=? string>? string? substring symbol->string symbol? tan truncate values vector vector->list vector-fill! vector-length vector-ref vector-set! vector? with-input-from-file with-output-to-file write write-char zero?)) - ((7) (throw (new Error "not yet implemented")) #;(%make-env "R7RS")) - (else (throw (new Error (string-append "scheme-report-environment: version " - (number->string version) - " not supported")))))) + ((7) (%make-env "R7RS" - * / _ + < <= = => > >= abs acos and angle append apply asin assoc assq + assv atan begin binary-port? boolean? boolean=? bytevector bytevector? bytevector-append + bytevector-copy bytevector-copy! bytevector-length bytevector-u8-ref bytevector-u8-set! caaaar + caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr call/cc + call-with-current-continuation call-with-input-file call-with-output-file call-with-port + call-with-values car case case-lambda cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr + cddar cdddar cddddr cdddr cddr cdr ceiling char? char? char>=? + char->integer char-alphabetic? char-ci? char-ci>=? + char-downcase char-foldcase char-lower-case? char-numeric? char-ready? char-upcase + char-upper-case? char-whitespace? close-input-port close-output-port close-port command-line + complex? cond cond-expand cons cos current-error-port current-input-port current-jiffy + current-output-port current-second define define-record-type define-syntax define-values delay + delay-force delete-file denominator digit-value display do dynamic-wind else emergency-exit + environment eof-object eof-object? eq? equal? eqv? error error-object? error-object-irritants + error-object-message eval even? exact exact? exact-integer? exact-integer-sqrt exit exp expt + features file-exists? finite? floor floor/ floor-quotient floor-remainder flush-output-port force + for-each gcd get-environment-variable get-environment-variables get-output-bytevector + get-output-string guard if imag-part import include include-ci inexact inexact? infinite? + input-port? input-port-open? integer? integer->char interaction-environment + interaction-environment jiffies-per-second lambda lcm length let let* let*-values letrec letrec* + letrec-syntax let-syntax let-values list list? list->string list->vector list-copy list-ref + list-set! list-tail load log magnitude make-bytevector make-list make-parameter make-polar + make-promise make-rectangular make-string make-vector map max member memq memv min modulo nan? + negative? newline not null? number? number->string numerator odd? open-binary-input-file + open-binary-output-file open-input-bytevector open-input-file open-input-string + open-output-bytevector open-output-file open-output-string or output-port? output-port-open? pair? + parameterize peek-char peek-u8 port? positive? procedure? quasiquote quote quotient raise + raise-continuable rational? rationalize read read-bytevector read-bytevector! read-char read-line + read-string read-u8 real? real-part remainder reverse round scheme-report-environment set! + set-car! set-cdr! sin sqrt square string string? string? + string>=? string->list string->number string->symbol string->utf8 string->vector string-append + string-ci? string-ci>=? string-copy string-copy! + string-downcase string-fill! string-foldcase string-for-each string-length string-map string-ref + string-set! string-upcase substring symbol? symbol=? symbol->string syntax-error syntax-rules tan + textual-port? truncate truncate/ truncate-quotient truncate-remainder u8-ready? unless unquote + unquote-splicing utf8->string values vector vector? vector->list vector->string vector-append + vector-copy vector-copy! vector-fill! vector-for-each vector-length vector-map vector-ref + vector-set! when with-exception-handler with-input-from-file with-output-to-file write + write-bytevector write-char write-shared write-simple write-string write-u8 zero?)) + (else (throw (new Error (string-append "scheme-report-environment: version " + (number->string version) + " not supported"))))))