From 3d55e7c3cf228271ddc25203cad64fbdcba9342a Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 13 Aug 2023 22:49:03 -0500 Subject: I don't even know any more --- chicanery.base.scm | 20 +++++++ chicanery.egg | 20 +++++-- chicanery.extras.scm | 145 +++++++++++++++++++++++++++++++++++++++++++++++++++ chicanery.scm | 5 ++ chicanery.sld | 23 -------- extras.scm | 138 ------------------------------------------------ impl/chicken.scm | 40 -------------- impl/gambit.scm | 7 --- impl/guile.scm | 76 --------------------------- impl/r7rs.scm | 84 ----------------------------- 10 files changed, 185 insertions(+), 373 deletions(-) create mode 100644 chicanery.base.scm create mode 100644 chicanery.extras.scm create mode 100644 chicanery.scm delete mode 100644 chicanery.sld delete mode 100644 extras.scm delete mode 100644 impl/chicken.scm delete mode 100644 impl/gambit.scm delete mode 100644 impl/guile.scm delete mode 100644 impl/r7rs.scm diff --git a/chicanery.base.scm b/chicanery.base.scm new file mode 100644 index 0000000..4ab0000 --- /dev/null +++ b/chicanery.base.scm @@ -0,0 +1,20 @@ +;;; chicanery/impl/chicken -*- geiser-scheme-implementation: chicken -*- + +(module (chicanery base) () + (import-for-syntax r7rs) + (import scheme (chicken module)) + (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))) diff --git a/chicanery.egg b/chicanery.egg index 21cb68e..e959cb8 100644 --- a/chicanery.egg +++ b/chicanery.egg @@ -2,15 +2,25 @@ ((synopsis "Subtly breaking scheme expectations.") (author "Case Duckworth") - (version "0.2.0") + (version "0.3.0") (license "God Willing License") (category lang-exts) (dependencies r7rs utf8) (components - (extension chicanery - (source chicanery.sld) + (extension chicanery.base + (source chicanery.base.scm) (types-file) ; I don't know what this does ... (inline-file) (csc-options "-X" "r7rs" "-R" "r7rs" - "-X" "utf8" "-R" "utf8" - "-no-warnings")))) + "-X" "utf8" "-R" "utf8")) + (extension chicanery.extras + (source chicanery.extras.scm) + (component-dependencies chicanery.base) + (types-file) + (inline-file)) + (extension chicanery + (source chicanery.scm) + (component-dependencies chicanery.base + chicanery.extras) + (types-file) + (inline-file)))) diff --git a/chicanery.extras.scm b/chicanery.extras.scm new file mode 100644 index 0000000..f9bb4a1 --- /dev/null +++ b/chicanery.extras.scm @@ -0,0 +1,145 @@ +(module (chicanery extras) ( append for-each map + list-append list-for-each list-map + ref copy + atom? defined? + read-port-chunk-size read-port + with-output-to-string with-input-from-string + displayed written print ->string) + (import scheme (chicanery base)) + + (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/chicanery.scm b/chicanery.scm new file mode 100644 index 0000000..3677dde --- /dev/null +++ b/chicanery.scm @@ -0,0 +1,5 @@ +(module chicanery () + (import scheme (chicken module)) + (reexport (chicanery base) + (chicanery extras))) + diff --git a/chicanery.sld b/chicanery.sld deleted file mode 100644 index 3a179c1..0000000 --- a/chicanery.sld +++ /dev/null @@ -1,23 +0,0 @@ -(cond-expand - (chicken - (include "impl/chicken.scm")) - (guile - (install-r7rs!) - (include "impl/guile.scm") - (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)) - (gambit - (include "impl/gambit.scm")) - (r7rs - (display "R7RS!\n") - (define-library (chicanery) - (include "impl/r7rs.scm"))) - (else (exit #f))) diff --git a/extras.scm b/extras.scm deleted file mode 100644 index ea19be8..0000000 --- a/extras.scm +++ /dev/null @@ -1,138 +0,0 @@ -;;; 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 deleted file mode 100644 index eeb69bd..0000000 --- a/impl/chicken.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; 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 deleted file mode 100644 index 3b3bc65..0000000 --- a/impl/gambit.scm +++ /dev/null @@ -1,7 +0,0 @@ -;;; -*- 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 deleted file mode 100644 index 6bd5387..0000000 --- a/impl/guile.scm +++ /dev/null @@ -1,76 +0,0 @@ -;;; 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 deleted file mode 100644 index b1a2d5c..0000000 --- a/impl/r7rs.scm +++ /dev/null @@ -1,84 +0,0 @@ -;;; 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