From 1f46fa50599de57d8e596e2294ebf8f5834aca7a Mon Sep 17 00:00:00 2001 From: Case Duckworth Date: Sun, 13 Aug 2023 21:29:02 -0500 Subject: Move files around --- chicanery#.scm | 17 ------- chicanery.extras.scm | 141 --------------------------------------------------- 2 files changed, 158 deletions(-) delete mode 100644 chicanery#.scm delete mode 100644 chicanery.extras.scm diff --git a/chicanery#.scm b/chicanery#.scm deleted file mode 100644 index 6f71e5a..0000000 --- a/chicanery#.scm +++ /dev/null @@ -1,17 +0,0 @@ -;;; chicanery#.scm -*- geiser-scheme-implementation: gambit; -*- - -(##include "~~lib/r7rs#.scm") - -(##namespace ("" ; extras - list-map - list-for-each - list-append - ref - copy - atom? - read-port - read-port-chunk-size - defined? - displayed ->string - written - print)) diff --git a/chicanery.extras.scm b/chicanery.extras.scm deleted file mode 100644 index f264424..0000000 --- a/chicanery.extras.scm +++ /dev/null @@ -1,141 +0,0 @@ -;;; chicanery extras --- extra stuff from ur old pal acdw - -;;; Generalized map, for-each, ... -;; List versions are renamed `list-'. Un-prefixed versions work -;; with any (default) datatype. TODO: generalize? -(define list-map scheme/map) -(define list-for-each scheme/for-each) -(define list-append scheme/append) - -(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) -- cgit 1.4.1-21-gabe81