Skip to content


Subversion checkout URL

You can clone with
Download ZIP
Tree: 0e13b61906
Fetching contributors…

Cannot retrieve contributors at this time

581 lines (510 sloc) 17.3 KB
;; Utilities
(##define-syntax get-path
(lambda (a)
(vector-ref a 2)))
(define (string-contains haystack chr)
(lambda (ret)
(let ((strlen (string-length haystack)))
(let loop ((i 0))
(if (>= i strlen)
(ret #f)
(let ((c (string-ref haystack i)))
(if (eq? c chr)
(ret i)
(loop (+ i 1))))))))))
(define (string-ends-with haystack needle)
(let ((hlen (string-length haystack))
(nlen (string-length needle)))
(and (>= hlen nlen)
(equal? needle
(substring haystack (- hlen nlen) hlen)))))
(define (string-begins-with haystack needle)
(let ((hlen (string-length haystack))
(nlen (string-length needle)))
(and (>= hlen nlen)
(equal? needle
(substring haystack 0 nlen)))))
(define (string-remove-suffix haystack needle)
(if (string-ends-with haystack needle)
(substring haystack 0 (- (string-length haystack)
(string-length needle)))
(define (string-remove-prefix haystack needle)
(if (string-begins-with haystack needle)
(substring haystack
(string-length needle)
(string-length haystack))
(define-macro (push! list obj)
`(set! ,list (cons ,obj ,list)))
(define-macro (pop! list)
;; We don't need to worry about double-evaluating list, because it
;; has to be a simple identifier anyways or the set! won't work.
(let ((tmp (gensym 'tmp)))
`(let* ((,tmp (car ,list)))
(set! ,list (cdr ,list))
(define (reverse! lst)
(let loop ((lst lst) (accum '()))
((pair? lst)
(let ((rest (cdr lst)))
(set-cdr! lst accum)
(loop rest lst)))
(define (file-last-changed-seconds fn)
(file-info fn))))
(define (file-newer? a b)
(lambda (e)
(lambda ()
(> (file-last-changed-seconds a)
(file-last-changed-seconds b)))))
;; I have no idea whether this works on non-Unix environments.
;; I don't care right now.
(define (is-directory? dir)
(file-exists? (string-append dir "/")))
;; This probably won't work on non-Unix environments.
;; I don't care right now.
(define (path-absolute? path)
(and (string? path)
(> (string-length path) 0)
(or (positive? (string-length (path-volume path)))
(eq? #\\ (string-ref path 0))
(eq? #\/ (string-ref path 0)))))
(define (recursively-delete-file dir)
(if (is-directory? dir)
(for-each (lambda (fn)
(path-expand fn dir)))
(list path: dir
ignore-hidden: 'dot-and-dot-dot)))
(delete-directory dir))
(delete-file dir)))
;; Utility function for flatten and flatten1
(define (accumulate-list thunk)
(let ((previous '())
(result '()))
(thunk (lambda (item)
(if (null? previous)
(set! result (cons item '()))
(set! previous result))
(let ((new-pair (cons item '())))
(set-cdr! previous new-pair)
(set! previous new-pair)))))
(if (null? previous)
(set-cdr! previous '())
(define (flatten list)
(lambda (add-item)
(let rec ((list list))
((pair? list)
(rec (car list))
(rec (cdr list)))
((not (null? list))
(add-item list)))))))
(define (flatten1 list)
(lambda (add-item)
(lambda (sublist)
(for-each add-item sublist))
(define (remove! pred list)
((null? list) '())
(if (pred (car list))
(remove! pred (cdr list))
(let ((return list))
(let loop ((list list))
((null? list)
((and (pair? (cdr list))
(pred (cadr list)))
(set-cdr! list
(cddr list))
(loop (cdr list)))
(loop (cdr list))))))))))
;; Recursively search directories after files with a certain extension
(define (find-files-with-ext ext dir #!optional prefix)
(let ((prefix (or prefix "")))
(map (lambda (f)
(let ((full-fn (string-append dir "/" f)))
((is-directory? full-fn)
ext full-fn (string-append prefix f "/")))
((string-ends-with f ext)
(string-append prefix f))
(else '()))))
(directory-files dir)))))
;; Like find-files-with-ext, but removes the extension
(define (find-files-with-ext-remove-ext ext dir)
(map (lambda (a)
(string-append "/"
(string-remove-suffix a ext))))
(find-files-with-ext ext dir)))
(define (filter pred list)
(if (null? list)
(if (pred (car list))
(cons (car list) (filter pred (cdr list)))
(filter pred (cdr list)))))
(define (find pred lst)
(let loop ((lst lst))
((pair? lst)
(let ((hd (car lst)))
(if (pred hd)
(loop (cdr lst)))))
(define (vector-for-each fn vec)
(let ((len (vector-length vec)))
(let loop ((i 0))
((< i len)
(fn (vector-ref vec i))
(loop (+ 1 i)))))
(define (vector-map fn vec)
(let* ((len (vector-length vec))
(v (make-vector len)))
(let loop ((i 0))
((< i len)
(vector-set! v
(fn (vector-ref vec i)))
(loop (+ 1 i)))))
(define (vector-fold fn init vec)
(let ((len (vector-length vec)))
(let loop ((i 0) (accum init))
((< i len)
(loop (+ 1 i)
(fn accum
(vector-ref vec i))))
(define (vector-fold2 fn init vec1 vec2)
(let ((len (vector-length vec1)))
(if (not (eq? len (vector-length vec2)))
(error "Vectors not of equal length" vec1 vec2))
(let loop ((i 0) (accum init))
((< i len)
(loop (+ 1 i)
(fn accum
(vector-ref vec1 i)
(vector-ref vec2 i))))
(define (foldr func end lst)
((null? lst) end)
((pair? lst) (func (car lst)
(foldr func
(cdr lst))))
(else "Expected list" lst)))
(define (last lst)
(cond ((null? lst) #f)
((null? (cdr lst)) (car lst))
(else (last (cdr lst)))))
;; Takes a module name and a symbol. If symbol contains a #, just
;; the symbol is returned. Otherwise mod#sym is returned.
(define (absolutify mod sym)
(if (not mod)
(let ((symstr (symbol->string sym)))
(if (string-contains symstr #\#)
(if (symbol? mod)
(symbol->string mod)
(string-append mod symstr)))))))
;; Takes an expression of the form (name (lambda arglist . body))
;; and transforms it into (name (lambda arglist [add...] . body))
(define (add-at-beginning-of-lambda lm . add)
(let ((lme (cadr lm)))
(if (pair? lme)
(let ((args (cadr lme))
(rest (cddr lme)))
`(,(car lm) (lambda ,args ,@add (let () ,@rest))))
(define (delete-if-exists fn)
(if (file-exists? fn)
(delete-file fn)))
;; (This function's implementation is quite ugly I think)
;; Flattens nested begin expressions to one;
;; (begin (begin #f) #f) => (begin #f #f)
(define (flatten-begin exp)
((or (null? exp) (not (list? exp))) exp)
((eq? (car exp) 'begin)
(let ((r (map flatten-begin (cdr exp))))
(map (lambda (x)
(if (and (list? x)
(not (null? x))
(eq? (car x) 'begin))
(cdr x)
(list x)))
(else exp)))
;; Helper for the define-type macro
(define (expand . args)
(let* ((exp (cdr (apply ##define-type-expand args))))
,@(map (lambda (x)
(if (eq? (car x) '##define-macro)
(cons 'define-macro
(if (eq? (caaddr x)
`(,(cadr x)
,@(cdaddr x)))
(cdr x)))
;; Helper for cond-expand. This function is more or less copied from
;; Gambit's _nonstd.scm
(define (cond-expand-build src clauses features)
(define (satisfied? feature-requirement)
(cond ((##symbol? feature-requirement)
(if (##member feature-requirement features)
((##pair? feature-requirement)
(let ((first (##source-strip (##car feature-requirement))))
(cond ((##eq? first 'not)
(##shape src (##sourcify feature-requirement src) 2)
(##not (satisfied?
(##source-strip (##cadr feature-requirement)))))
((or (##eq? first 'and) (##eq? first 'or))
(##shape src (##sourcify feature-requirement src) -1)
(let loop ((lst (##cdr feature-requirement)))
(if (##pair? lst)
(let ((x (##source-strip (##car lst))))
(if (##eq? (satisfied? x) (##eq? first 'and))
(loop (##cdr lst))
(##not (##eq? first 'and))))
(##eq? first 'and))))
(error "Ill-formed cond-expand form"
(expr*:strip-locationinfo src))))))
(error "Ill-formed cond-expand form"
(expr*:strip-locationinfo src)))))
(define (build clauses)
(if (##pair? clauses)
(let ((clause (##source-strip (##car clauses))))
(##shape src (##sourcify clause src) -1)
(let ((feature-requirement (##source-strip (##car clause))))
(if (or (and (##eq? feature-requirement 'else)
(##null? (##cdr clauses)))
(satisfied? feature-requirement))
(##cons 'begin (##cdr clause))
(build (##cdr clauses)))))
(error "Unfulfilled cond-expand form"
(expr*:strip-locationinfo src))))
(build clauses))
(define (eval-no-hook expr)
(let ((hook ##expand-source)
(c-hook c#expand-source)
(id (lambda (x) x)))
(lambda ()
(set! ##expand-source id)
(set! c#expand-source id))
(lambda ()
(eval expr))
(lambda ()
(set! ##expand-source hook)
(set! c#expand-source c-hook)))))
;; Beware of n^2 algorithms
(define (remove-duplicates list #!optional (predicate eq?))
((null? list) '())
((pair? list)
(let ((e (car list)))
(cons e
(filter (lambda (x)
(not (predicate x e)))
(cdr list))
(else (raise "Argument to remove-duplicates must be a list"))))
(define (create-dir-unless-exists dir)
(if (not (file-exists? dir))
(path-strip-trailing-directory-separator dir)))
(create-directory dir))))
(define (generate-tmp-dir base-dir thunk)
(create-dir-unless-exists base-dir)
(let ((fn (let loop ((i 0))
(let ((fn (path-expand (number->string i)
(if (file-exists? fn)
(loop (+ i 1))
(lambda ()
(if (not fn)
(error "generate-tmp-dir: Can't re-enter"))
(create-directory fn))
(lambda ()
(thunk fn))
(lambda ()
(recursively-delete-file fn)
(set! fn #f)))))
;; Let with multiple values support
(##define-syntax let
(lambda (source)
(define (last lst)
(cond ((null? lst) #f)
((null? (cdr lst)) (car lst))
(else (last (cdr lst)))))
(define (skip-last lst)
((null? lst)
(error "Can't skip last"))
((null? (cdr lst))
(cons (car lst)
(skip-last (cdr lst))))))
(define (filter pred list)
(if (null? list)
(if (pred (car list))
(cons (car list) (filter pred (cdr list)))
(filter pred (cdr list)))))
(define (source-code source)
(if (##source? source)
(##source-code source)
(let* ((sc (source-code source))
(defs (source-code (cadr sc)))
(body (cddr sc)))
((pair? defs)
(let* ((defs (map source-code defs))
(filter (lambda (x)
(null? (cddr x)))
(map (lambda (x)
(cons (last x)
(map (lambda (name)
(cons (gensym (source-code
(skip-last x))))
(filter (lambda (x)
(pair? (cddr x)))
(let loop ((mds multi-defs))
((null? mds)
`(##let (,@single-defs
(map (lambda (multi-def)
(map (lambda (def)
(list (cdr def)
(car def)))
(cdr multi-def)))
(let ((multi-def (car mds)))
(lambda ()
,(car multi-def))
(lambda ,(map car (cdr multi-def))
,(loop (cdr mds))))))))))
(cons '##let
(cdr (source-code source))))))
;; Removes extraneous "./" and "../" in a URI path. Copied from the
;; uri module
(define (remove-dot-segments str)
(let* ((in-len (string-length str))
(res (make-string in-len)))
;; i is where we are in the source string,
;; j is where we are in the result string,
;; segs is a list, used as a stack, of the indices of the
;; previously encountered path segments in the result string.
(lambda (i j segs)
(let* ((segment-start (car segs))
(segment-length (- j segment-start 1)))
;; Check for .
((and (= 1 segment-length)
(char=? #\. (string-ref res segment-start)))
(loop (+ 1 i) segment-start segs))
;; Check for ..
((and (= 2 segment-length)
(char=? #\. (string-ref res segment-start))
(char=? #\. (string-ref res (+ 1 segment-start))))
;; Take care of the "/../something" special case; it
;; should return "/something" and not "something".
((and (= 1 segment-start)
(char=? #\/ (string-ref res 0)))
(loop (+ 1 i) 1 '(1)))
;; This is needed because the code in the else clause
;; assumes that segs is a list of length >= 2
((zero? segment-start)
(loop (+ 1 i) 0 segs))
(loop (+ 1 i) (cadr segs) (cdr segs)))))
;; Check for the end of the string
((>= (+ 1 i) in-len)
(loop (+ 1 i) j (cons j segs)))))))
(lambda (i j segs)
(if (>= i in-len)
(new-segment i j segs)
(let ((chr (string-ref str i)))
(string-set! res j chr)
(if (char=? chr #\/)
(new-segment i (+ 1 j) segs)
(loop (+ 1 i) (+ 1 j) segs)))))))
(let ((idx (loop 0 0 '(0))))
(substring res 0 idx)))))
Jump to Line
Something went wrong with that request. Please try again.