From 02f8dbf330ba9e65cc381a0ff975211944d86a4a Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 13 Aug 2023 21:29:44 -0500 Subject: Moved things around (pt 2) --- extras.scm | 138 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ impl/chicken.scm | 40 ++++++++++++++++ impl/gambit.scm | 7 +++ impl/guile.scm | 76 ++++++++++++++++++++++++++++++ impl/r7rs.scm | 84 +++++++++++++++++++++++++++++++++ 5 files changed, 345 insertions(+) create mode 100644 extras.scm create mode 100644 impl/chicken.scm create mode 100644 impl/gambit.scm create mode 100644 impl/guile.scm create mode 100644 impl/r7rs.scm diff --git a/extras.scm b/extras.scm new file mode 100644 index 0000000..ea19be8 --- /dev/null +++ b/extras.scm @@ -0,0 +1,138 @@ +;;; Extras +(display "EXTRAS!\n") +(define list-append append) +(define list-for-each for-each) +(define list-map map) + +(define (map proc . collections) + (let ((first (car collections))) ; we only need to check the first one + (cond + ((list? first) + (apply list-map proc collections)) + ((vector? first) + (apply vector-map proc collections)) + ((string? first) + (apply string-map proc collections)) + (else (error "Bad datatype" first))))) + +(define (for-each proc . collections) + (let ((first (car collections))) ; we only need to check the first one + (cond + ((list? first) + (apply list-for-each proc collections)) + ((vector? first) + (apply vector-for-each proc collections)) + ((string? first) + (apply string-for-each proc collections)) + (else (error "Bad datatype" first))))) + +(define (append . collections) + (let ((first (car collections))) ; we only need to check the first one + (cond + ((list? first) + (apply list-append collections)) + ((vector? first) + (apply vector-append collections)) + ((string? first) + (apply string-append collections)) + ((bytevector? first) + (apply bytevector-append collections)) + (else (error "Bad datatype" first))))) + +;;; Extended generic functions. +;; These functions already have a list- version defined, but no non-prefixed +;; one. So I'm fixing that. +(define (ref collection k) + (cond + ((list? collection) + (list-ref collection k)) + ((vector? collection) + (vector-ref collection k)) + ((string? collection) + (string-ref collection k)) + ((bytevector? collection) + (bytevector-u8-ref collection k)) + (else (error "Bad datatype" collection)))) + +;; I'm not going to generalize -copy! because I don't think it's a great idea, +;; really. +(define (copy collection) + (cond + ((list? collection) + (list-copy collection)) + ((vector? collection) + (vector-copy collection)) + ((string? collection) + (string-copy collection)) + ((bytevector? collection) + (bytevector-copy collection)) + (else (error "Bad datatype" collection)))) + +;;; Definitions that should be in scheme +;; This sections should be as small as possible + +(define (atom? x) + (and (not (pair? x)) + (not (null? x)))) + +(define read-port-chunk-size + (make-parameter 512)) + +(define (%read-port port) + (let ((chunk-size (read-port-chunk-size))) + (let loop ((next (read-string chunk-size port)) + (blank? #f) + (acc '())) + (cond + ((or (eof-object? next) + (and blank? (equal? next ""))) + (apply string-append (reverse acc))) + ((equal? next "") + (loop (read-string chunk-size port) + #t + (cons next acc))) + (else + (loop (read-string chunk-size port) + blank? + (cons next acc))))))) + +(define read-port + (case-lambda + (() (%read-port (current-input-port))) + ((p) (%read-port p)))) + +(define (defined? sym) + (call-with-current-continuation + (lambda (k) + (with-exception-handler + (lambda (e) (k #f)) + (lambda () + (eval sym (interaction-environment)) + #t))))) + +(define (with-output-to-string thunk) + (call-with-port (open-output-string) + (lambda (port) + (parameterize ((current-output-port port)) + (thunk)) + (get-output-string port)))) + +(define (with-input-from-string s thunk) + (call-with-port (open-input-string s) + (lambda (port) + (parameterize ((current-input-port port)) + (thunk))))) + +(define (displayed x) + (with-output-to-string + (lambda () (display x)))) + +(define (written x) + (with-output-to-string + (lambda () (write x)))) + +(define (print . xs) + (for-each display xs) + (newline)) + +(define ->string displayed) diff --git a/impl/chicken.scm b/impl/chicken.scm new file mode 100644 index 0000000..eeb69bd --- /dev/null +++ b/impl/chicken.scm @@ -0,0 +1,40 @@ +;;; chicanery/impl/chicken -*- geiser-scheme-implementation: chicken -*- + +(module chicanery () + (import (scheme base) + (scheme eval) + (srfi 1) + (chicken module)) + (import-for-syntax r7rs) + (reexport (scheme base) + (scheme case-lambda) + (scheme char) + (scheme complex) + (scheme cxr) + (scheme eval) + (scheme file) + (scheme inexact) + (scheme lazy) + (scheme load) + (scheme process-context) + (scheme read) + (scheme repl) + (scheme time) + (scheme write)) + + (define env (environment '(only chicken.base exit))) + (##sys#current-environment (##sys#slot env 2)) + (##sys#macro-environment (filter-map + (lambda (e) + (and (list? e) e)) + (##sys#slot env 2))) + (include "../extras.scm") + (export append for-each map + list-append list-for-each list-map + ref copy + atom? + read-port read-port-chunk-size + defined? + with-output-to-string with-input-from-string + displayed ->string written + print)) diff --git a/impl/gambit.scm b/impl/gambit.scm new file mode 100644 index 0000000..3b3bc65 --- /dev/null +++ b/impl/gambit.scm @@ -0,0 +1,7 @@ +;;; -*- geiser-scheme-implementation: gambit -*- + +(##include "~~lib/r7rs#.scm") + +(define-library (chicanery) + (include-library-declarations "r7rs.scm") + (namespace "")) diff --git a/impl/guile.scm b/impl/guile.scm new file mode 100644 index 0000000..6bd5387 --- /dev/null +++ b/impl/guile.scm @@ -0,0 +1,76 @@ +;;; chicanery/impl/guile.scm -*- geiser-scheme-implementation: guile -*- + +;; XXX : Apparently this doesn't work. I don't know. + +(define-module (chicanery)) + +(use-modules (scheme base) + (scheme case-lambda) + (scheme char) + (scheme complex) + (scheme cxr) + (scheme eval) + (scheme file) + (scheme inexact) + (scheme lazy) + (scheme load) + (scheme process-context) + (scheme read) + (scheme repl) + (scheme time) + (scheme write)) + +(export! * + - / < <= = > >= abs acos and angle #;append apply asin + assoc assq assv atan begin binary-port? boolean=? boolean? bytevector + bytevector-append bytevector-copy bytevector-copy! bytevector-length + bytevector-u8-ref bytevector-u8-set! bytevector? 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-port call-with-values call/cc car + case case-lambda 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-foldcase char-lower-case? char-numeric? + char-ready? char-upcase char-upper-case? char-whitespace? char<=? + char=? char>? char? 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 emergency-exit environment + eof-object eof-object? eq? equal? eqv? error error-object-irritants + error-object-message error-object? eval even? exact + exact-integer-sqrt exact-integer? exact? exit exp expt features + file-error? file-exists? finite? floor floor-quotient + floor-remainder floor/ flush-output-port #;for-each force 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-open? + input-port? integer->char integer? interaction-environment + jiffies-per-second lambda lcm length let let* let*-values let-syntax + let-values letrec letrec* letrec-syntax list list->string magnitude + make-bytevector make-list make-parameter make-polar make-promise + make-rectangular make-string make-vector #;map max member memq memv min + modulo negative? newline not null? number->string number? 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-open? output-port? pair? parameterize peek-char peek-u8 + port? positive? procedure? promise? quasiquote quote quotient raise + raise-continuable rational? rationalize read read-bytevector + read-bytevector! read-char read-error? read-line read-string read-u8 + real-part real? remainder reverse round set! set-car! set-cdr! sin + sqrt square string string->list string->number string->symbol + string->utf8 string->vector string-append string-ci<=? 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 + string<=? string=? string>? string? substring + symbol->string symbol=? symbol? syntax-error syntax-rules tan + textual-port? truncate truncate-quotient truncate-remainder + truncate/ u8-ready? unless unquote unquote-splicing utf8->string + values vector vector->list vector->string vector-append vector-copy + vector-copy! vector-fill! vector-for-each vector-length vector-map + vector-ref vector-set! vector? 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?) diff --git a/impl/r7rs.scm b/impl/r7rs.scm new file mode 100644 index 0000000..b1a2d5c --- /dev/null +++ b/impl/r7rs.scm @@ -0,0 +1,84 @@ +;;; chicanery/impl/r7rs --- for r7rs-compliant implementations + +(import (scheme base)) +(import (scheme case-lambda)) +(import (scheme char)) +(import (scheme complex)) +(import (scheme cxr)) +(import (scheme eval)) +(import (scheme file)) +(import (scheme inexact)) +(import (scheme lazy)) +(import (scheme load)) +(import (scheme process-context)) +(import (scheme read)) +(import (scheme repl)) +(import (scheme time)) +(import (scheme write)) + +(export * + - / < <= = > >= abs acos and angle #;append apply asin + assoc assq assv atan begin binary-port? boolean=? boolean? bytevector + bytevector-append bytevector-copy bytevector-copy! bytevector-length + bytevector-u8-ref bytevector-u8-set! bytevector? 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-port call-with-values call/cc car + case case-lambda 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-foldcase char-lower-case? char-numeric? + char-ready? char-upcase char-upper-case? char-whitespace? char<=? + char=? char>? char? 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 emergency-exit environment + eof-object eof-object? eq? equal? eqv? error error-object-irritants + error-object-message error-object? eval even? exact + exact-integer-sqrt exact-integer? exact? exit exp expt features + file-error? file-exists? finite? floor floor-quotient + floor-remainder floor/ flush-output-port #;for-each force 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-open? + input-port? integer->char integer? interaction-environment + jiffies-per-second lambda lcm length let let* let*-values let-syntax + let-values letrec letrec* letrec-syntax list list->string magnitude + make-bytevector make-list make-parameter make-polar make-promise + make-rectangular make-string make-vector #;map max member memq memv min + modulo negative? newline not null? number->string number? 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-open? output-port? pair? parameterize peek-char peek-u8 + port? positive? procedure? promise? quasiquote quote quotient raise + raise-continuable rational? rationalize read read-bytevector + read-bytevector! read-char read-error? read-line read-string read-u8 + real-part real? remainder reverse round set! set-car! set-cdr! sin + sqrt square string string->list string->number string->symbol + string->utf8 string->vector string-append string-ci<=? 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 + string<=? string=? string>? string? substring + symbol->string symbol=? symbol? syntax-error syntax-rules tan + textual-port? truncate truncate-quotient truncate-remainder + truncate/ u8-ready? unless unquote unquote-splicing utf8->string + values vector vector->list vector->string vector-append vector-copy + vector-copy! vector-fill! vector-for-each vector-length vector-map + vector-ref vector-set! vector? 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?) + +;; Extras +(include "../extras.scm") +(export append for-each map + list-append list-for-each list-map + ref copy + atom? + read-port read-port-chunk-size + defined? + with-output-to-string with-input-from-string + displayed ->string written + print) -- cgit 1.4.1-21-gabe81