summaryrefslogtreecommitdiff
path: root/support/utils.scm
diff options
context:
space:
mode:
Diffstat (limited to 'support/utils.scm')
-rw-r--r--support/utils.scm408
1 files changed, 408 insertions, 0 deletions
diff --git a/support/utils.scm b/support/utils.scm
new file mode 100644
index 0000000..ab93f6b
--- /dev/null
+++ b/support/utils.scm
@@ -0,0 +1,408 @@
+;;; utils.scm -- utility functions
+;;;
+;;; author : Sandra Loosemore
+;;; date : 18 Nov 1991
+;;;
+;;; This file contains miscellaneous functions that are generally useful.
+;;; If you find some missing feature from the base language, this is
+;;; a good place to put it. Common Lisp-style sequence functions are
+;;; an example of the sort of thing found here.
+
+
+;;;=====================================================================
+;;; Sequence functions
+;;;=====================================================================
+
+(define (vector-replace to-vec from-vec to start end)
+ (declare (type fixnum to start end)
+ (type vector to-vec from-vec))
+ (if (and (eq? to-vec from-vec)
+ (> to start))
+ ;; Right shift in place
+ (do ((from (1- end) (1- from))
+ (to (1- (+ to (- end start)))))
+ ((< from start) to-vec)
+ (declare (type fixnum from to))
+ (setf (vector-ref to-vec to) (vector-ref from-vec from))
+ (decf to))
+ ;; Normal case, left-to-right
+ (do ((from start (1+ from)))
+ ((= from end) to-vec)
+ (declare (type fixnum from))
+ (setf (vector-ref to-vec to) (vector-ref from-vec from))
+ (incf to))))
+
+(define (string-replace to-vec from-vec to start end)
+ (declare (type fixnum to start end)
+ (type string to-vec from-vec))
+ (if (and (eq? to-vec from-vec)
+ (> to start))
+ ;; Right shift in place
+ (do ((from (1- end) (1- from))
+ (to (1- (+ to (- end start)))))
+ ((< from start) to-vec)
+ (declare (type fixnum from to))
+ (setf (string-ref to-vec to) (string-ref from-vec from))
+ (decf to))
+ ;; Normal case, left-to-right
+ (do ((from start (1+ from)))
+ ((= from end) to-vec)
+ (declare (type fixnum from))
+ (setf (string-ref to-vec to) (string-ref from-vec from))
+ (incf to))))
+
+(define (string-fill string c start end)
+ (declare (type fixnum start end)
+ (type string string)
+ (type char c))
+ (do ((i start (1+ i)))
+ ((= i end) string)
+ (declare (type fixnum i))
+ (setf (string-ref string i) c)))
+
+(define (string-position c string start end)
+ (declare (type fixnum start end)
+ (type string string)
+ (type char c))
+ (cond ((= start end) '#f)
+ ((char=? (string-ref string start) c) start)
+ (else
+ (string-position c string (1+ start) end))))
+
+(define (string-position-not-from-end c string start end)
+ (declare (type fixnum start end)
+ (type string string)
+ (type char c))
+ (cond ((= start end) '#f)
+ ((not (char=? (string-ref string (setf end (1- end))) c))
+ end)
+ (else
+ (string-position-not-from-end c string start end))))
+
+(define (string-nreverse string start end)
+ (declare (type fixnum start end)
+ (type string string))
+ (do ((i start (1+ i))
+ (j (1- end) (1- j)))
+ ((not (< i j)) string)
+ (declare (type fixnum i j))
+ (let ((c (string-ref string i)))
+ (setf (string-ref string i) (string-ref string j))
+ (setf (string-ref string j) c))))
+
+
+(define (string-starts? s1 s2) ; true is s1 begins s2
+ (and (>= (string-length s2) (string-length s1))
+ (string=? s1 (substring s2 0 (string-length s1)))))
+
+
+;;;=====================================================================
+;;; Table utilities
+;;;=====================================================================
+
+
+(define (table->list table)
+ (let ((l '()))
+ (table-for-each
+ (lambda (key val) (push (cons key val) l)) table)
+ l))
+
+(define (list->table l)
+ (let ((table (make-table)))
+ (dolist (p l)
+ (setf (table-entry table (car p)) (cdr p)))
+ table))
+
+
+
+;;;=====================================================================
+;;; Tuple utilities
+;;;=====================================================================
+
+;;; For future compatibility with a typed language, define 2 tuples with
+;;; a few functions: (maybe add 3 tuples someday!)
+
+(define-integrable (tuple x y)
+ (cons x y))
+
+(define-integrable (tuple-2-1 x) (car x)) ; Flic-like notation
+(define-integrable (tuple-2-2 x) (cdr x))
+
+(define (map-tuple-2-1 f l)
+ (map (lambda (x) (tuple (funcall f (tuple-2-1 x)) (tuple-2-2 x))) l))
+
+(define (map-tuple-2-2 f l)
+ (map (lambda (x) (tuple (tuple-2-1 x) (funcall f (tuple-2-2 x)))) l))
+
+
+;;;=====================================================================
+;;; List utilities
+;;;=====================================================================
+
+;;; This does an assq using the second half of the tuple as the key.
+
+(define (rassq x l)
+ (if (null? l)
+ '#f
+ (if (eq? x (tuple-2-2 (car l)))
+ (car l)
+ (rassq x (cdr l)))))
+
+;;; This is an assoc with an explicit test
+
+(define (assoc/test test-fn x l)
+ (if (null? l)
+ '#f
+ (if (funcall test-fn x (tuple-2-1 (car l)))
+ (car l)
+ (assoc/test test-fn x (cdr l)))))
+
+
+
+
+;;; Stupid position function works only on lists, uses eqv?
+
+(define (position item list)
+ (position-aux item list 0))
+
+(define (position-aux item list index)
+ (declare (type fixnum index))
+ (cond ((null? list)
+ '#f)
+ ((eqv? item (car list))
+ index)
+ (else
+ (position-aux item (cdr list) (1+ index)))
+ ))
+
+
+;;; Destructive delete-if function
+
+(define (list-delete-if f l)
+ (list-delete-if-aux f l l '#f))
+
+(define (list-delete-if-aux f head next last)
+ (cond ((null? next)
+ ;; No more elements.
+ head)
+ ((not (funcall f (car next)))
+ ;; Leave this element and do the next.
+ (list-delete-if-aux f head (cdr next) next))
+ (last
+ ;; Delete element from middle of list.
+ (setf (cdr last) (cdr next))
+ (list-delete-if-aux f head (cdr next) last))
+ (else
+ ;; Delete element from head of list.
+ (list-delete-if-aux f (cdr next) (cdr next) last))))
+
+
+;;; Same as the haskell function
+
+(define (concat lists)
+ (if (null? lists)
+ '()
+ (append (car lists) (concat (cdr lists)))))
+
+
+;;; This is a quick & dirty list sort function.
+
+(define (sort-list l compare-fn)
+ (if (or (null? l) (null? (cdr l)))
+ l
+ (insert-sorted compare-fn (car l) (sort-list (cdr l) compare-fn))))
+
+(define (insert-sorted compare-fn e l)
+ (if (null? l)
+ (list e)
+ (if (funcall compare-fn e (car l))
+ (cons e l)
+ (cons (car l) (insert-sorted compare-fn e (cdr l))))))
+
+(define (find-duplicates l)
+ (cond ((null? l)
+ '())
+ ((memq (car l) (cdr l))
+ (cons (car l)
+ (find-duplicates (cdr l))))
+ (else (find-duplicates (cdr l)))))
+
+;;; A simple & slow topsort routine.
+;;; Input: A list of lists. Each list is a object consed onto the
+;;; list of objects it preceeds.
+;;; Output: Two values: SORTED / CYCLIC & a list of either sorted objects
+;;; or a set of components containing the cycle.
+
+(define (topsort l)
+ (let ((changed? '#t)
+ (sorted '())
+ (next '()))
+ (do () ((not changed?)
+ (if (null? next)
+ (values 'sorted (nreverse sorted))
+ (values 'cyclic (map (function car) next))))
+ (setf changed? '#f)
+ (setf next '())
+ (dolist (x l)
+ (cond ((topsort-aux (cdr x) sorted)
+ (push (car x) sorted)
+ (setf changed? '#t))
+ (else
+ (push x next))))
+ (setf l next))))
+
+
+;;; Returns true if x doesn't contain any elements that aren't in sorted.
+;;; equivalent to (null? (set-intersection x sorted)), but doesn't cons
+;;; and doesn't traverse the whole list in the failure case.
+
+(define (topsort-aux x sorted)
+ (cond ((null? x)
+ '#t)
+ ((memq (car x) sorted)
+ (topsort-aux (cdr x) sorted))
+ (else
+ '#f)))
+
+(define (set-intersection s1 s2)
+ (if (null? s1)
+ '()
+ (let ((rest (set-intersection (cdr s1) s2)))
+ (if (memq (car s1) s2)
+ (cons (car s1) rest)
+ rest))))
+
+;;; remove s2 elements from s1
+
+(define (set-difference s1 s2)
+ (if (null? s1)
+ '()
+ (let ((rest (set-difference (cdr s1) s2)))
+ (if (memq (car s1) s2)
+ rest
+ (cons (car s1) rest)))))
+
+
+(define (set-union s1 s2)
+ (if (null? s2)
+ s1
+ (if (memq (car s2) s1)
+ (set-union s1 (cdr s2))
+ (cons (car s2) (set-union s1 (cdr s2))))))
+
+
+;;; Destructive list splitter
+
+(define (split-list list n)
+ (declare (type fixnum n))
+ (let ((tail1 (list-tail list (1- n))))
+ (if (null? tail1)
+ (values list '())
+ (let ((tail2 (cdr tail1)))
+ (setf (cdr tail1) '())
+ (values list tail2)))))
+
+
+;;; Some string utils
+
+(define (mem-string s l)
+ (and (not (null? l)) (or (string=? s (car l))
+ (mem-string s (cdr l)))))
+
+(define (ass-string k l)
+ (cond ((null? l)
+ '#f)
+ ((string=? k (caar l))
+ (car l))
+ (else
+ (ass-string k (cdr l)))))
+
+
+;;;=====================================================================
+;;; Syntax extensions
+;;;=====================================================================
+
+;;; The mlet macro combines let* and multiple-value-bind into a single
+;;; syntax.
+
+(define-syntax (mlet binders . body)
+ (mlet-body binders body))
+
+(define (mlet-body binders body)
+ (if (null? binders)
+ `(begin ,@body)
+ (let* ((b (car binders))
+ (var (car b))
+ (init (cadr b))
+ (inner-body (mlet-body (cdr binders) body)))
+ (if (pair? var)
+ (multiple-value-bind (new-vars ignore-decl)
+ (remove-underlines var)
+ `(multiple-value-bind ,new-vars
+ ,init ,@ignore-decl ,inner-body))
+ `(let ((,var ,init)) ,inner-body)))))
+
+(define (remove-underlines vars)
+ (if (null? vars)
+ (values '() '())
+ (multiple-value-bind (rest ignore-decl) (remove-underlines (cdr vars))
+ (if (not (eq? (car vars) '_))
+ (values (cons (car vars) rest) ignore-decl)
+ (let ((var (gensym)))
+ (values (cons var rest)
+ `((declare (ignore ,var)) ,@ignore-decl)))))))
+
+
+
+
+;;;=====================================================================
+;;; Other utilities
+;;;=====================================================================
+
+(define (add-extension name ext)
+ (assemble-filename (filename-place name) (filename-name name) ext))
+
+(define (time-execution thunk)
+ (let* ((start-time (get-run-time))
+ (res (funcall thunk))
+ (end-time (get-run-time)))
+ (values res (- end-time start-time))))
+
+(define (pprint-flatten code . maybe-port)
+ (pprint-flatten-aux
+ code
+ (if (null? maybe-port) (current-output-port) (car maybe-port))))
+
+(define (pprint-flatten-aux code port)
+ (if (and (pair? code)
+ (eq? (car code) 'begin))
+ (dolist (c (cdr code))
+ (pprint-flatten-aux c port))
+ (pprint*-aux code port)))
+
+(define (print-flatten code port)
+ (if (and (pair? code)
+ (eq? (car code) 'begin))
+ (dolist (c (cdr code))
+ (print-flatten c port))
+ (begin
+ (internal-write code port)
+ (internal-newline port))))
+
+
+;;; Like pprint, but print newline after instead of before.
+
+(define (pprint* object . maybe-port)
+ (pprint*-aux
+ object
+ (if (null? maybe-port) (current-output-port) (car maybe-port))))
+
+(define (pprint*-aux object port)
+ (dynamic-let ((*print-pretty* '#t))
+ (prin1 object port))
+ (terpri port))
+
+;;; This reads stuff from a string. (Better error checks needed!)
+
+(define (read-lisp-object str)
+ (call-with-input-string str (lambda (port) (read port))))
generated by cgit v1.2.3 (git 2.46.0) at 2024-09-16 19:18:43 +0000