misc.scm (3884B)
1 ;;;; misc.scm - miscellaneous utility functions 2 3 4 (define temp 5 (let ((count 1)) 6 (lambda prefix 7 (let ((i count)) 8 (set! count (+ count 1)) 9 (string->symbol 10 (string-append 11 (if (pair? prefix) 12 (car prefix) 13 "t") 14 (number->string i))))))) 15 16 (define (dribble . args) 17 (for-each 18 (cut display <> (current-error-port)) 19 args) 20 (newline (current-error-port))) 21 22 (define (read-forms file-or-port) 23 ((if (string? file-or-port) 24 call-with-input-file 25 (lambda (fp p) (p fp))) 26 file-or-port 27 (lambda (port) 28 (let loop ((xs '())) 29 (let ((x (read port))) 30 (if (eof-object? x) 31 `(begin ,@(reverse xs)) 32 (loop (cons x xs)))))))) 33 34 (define (copy-file-data file) 35 (with-input-from-file file 36 (lambda () 37 (let loop () 38 (let ((c (read-char))) 39 (unless (eof-object? c) 40 (write-char c) 41 (loop))))))) 42 43 (define (emit . xs) 44 (for-each display xs)) 45 46 (define (emit-list xs) 47 (match xs 48 (() #f) 49 ((x) (emit x)) 50 ((x1 xs ...) 51 (emit x1) 52 (for-each (lambda (x) (emit ", " x)) xs)))) 53 54 (define (stringify x) 55 (cond ((symbol? x) (symbol->string x)) 56 ((string? x) x) 57 (else (error "can't stringify" x)))) 58 59 (define (symbolify x) 60 (cond ((symbol? x) x) 61 ((string? x) (string->symbol x)) 62 (else (error "can't symbolify" x)))) 63 64 (define (join xs sep) 65 (apply 66 string-append 67 (let loop ((xs xs)) 68 (cond ((null? xs) '()) 69 ((null? (cdr xs)) xs) 70 (else (cons (car xs) (cons sep (loop (cdr xs))))))))) 71 72 (define (fail msg . arg) 73 (let ((out (current-error-port))) 74 (display "\nError: " out) 75 (display msg out) 76 (cond ((pair? arg) 77 (display ":\n\n" out) 78 (pp (car arg) out)) 79 (else (newline out))) 80 (exit 1))) 81 82 (define (symbol<? s1 s2) 83 (string<? (symbol->string s1) (symbol->string s2))) 84 85 (define (butlast lst) 86 (let loop ((lst lst)) 87 (if (null? (cdr lst)) 88 '() 89 (cons (car lst) (loop (cdr lst)))))) 90 91 (define (last lst) 92 (let loop ((lst lst)) 93 (if (null? (cdr lst)) 94 (car lst) 95 (loop (cdr lst))))) 96 97 (define (test-option opt state) 98 (cond ((assq opt state) => cdr) 99 (else #f))) 100 101 (define (identifier id) 102 (let* ((str (stringify id)) 103 (out (open-output-string)) 104 (n (string-length str))) 105 (display "___" out) 106 (do ((i 0 (+ i 1))) 107 ((>= i n) (get-output-string out)) 108 (let ((c (string-ref str i))) 109 (if (and (not (char-lower-case? c)) 110 (or (not (char-numeric? c)) (= i 0))) 111 (let ((i (char->integer c))) 112 (write-char #\_ out) 113 (when (< i 16) (write-char #\0 out)) 114 (display (number->string i 16) out)) 115 (write-char c out)))))) 116 117 (define (read-library state name . reader) 118 (let loop ((lpath (test-option 'library-path state))) 119 (if (null? lpath) 120 ((or (test-option 'fail state) fail) 121 "library not found" name) 122 (let ((lib (file-exists? (string-append (car lpath) "/" name)))) 123 (cond (lib 124 (when (test-option 'verbose state) 125 (dribble "reading library " lib)) 126 ((if (pair? reader) (car reader) read-forms) lib)) 127 (else (loop (cdr lpath)))))))) 128 129 (define (parse-llist llist) 130 (let loop ((ll llist) (vars '())) 131 (match ll 132 (() (list (reverse vars) #f)) 133 ((? symbol?) (list (reverse (cons ll vars)) ll)) 134 (((? symbol? v) . more) 135 (loop more (cons v vars))) 136 (_ (fail "bad lambda list" llist))))) 137 138 (define (string-find-char c str) 139 (let ((len (string-length str))) 140 (let loop ((i 0)) 141 (and (< i len) 142 (or (char=? c (string-ref str i)) 143 (loop (+ i 1))))))) 144 145 (define (note loc state x . args) 146 (when (or (not state) (test-option 'verbose state)) 147 (apply 148 dribble 149 (append 150 (if loc 151 `("(" ,loc ") ") 152 '()) 153 args))) 154 x) 155 156 (define (read-contents filename) 157 (with-input-from-file filename 158 (lambda () 159 (with-output-to-string 160 (lambda () 161 (let loop () 162 (let ((c (read-char))) 163 (unless (eof-object? c) 164 (write-char c) 165 (loop)))))))))