flanchan
/
cl-utils
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial commit

Browse Source
master
Ringo Wantanabe 6 years ago
commit 97ba4eeddd
No known key found for this signature in database
GPG Key ID: DDDD9B6759158726
4 changed files with 227 additions and 0 deletions
Show Stats Download Patch File Download Diff File

1
.gitignore vendored
Unescape View File

@ -0,0 +1 @@
utils/

109
.utils.lisp
Unescape View File

@ -0,0 +1,109 @@
(if (boundp '*-utils-lisp*) "Already loaded" (progn
;;; --- internally maintained config, don't put anything above these!!
(defparameter *-utils-lisp* t)
(defparameter *-utils-depends* '(#:cl-ppcre))
;;; -- Handle internal exporting --
(defmacro insystem? (thing &optional (else nil))
`(if (boundp '*-utils-system*)
,thing
,else))
(defmacro export? (val)
`(if (boundp '*-utils-system*)
(export ',val)
nil))
(defmacro export* (&rest syms)
`(mapc #'export '(,@syms)))
(defmacro export*! (&rest syms)
`(mapc #'export (list ,@syms)))
(export? export*)
(export? export*!)
(defmacro export*? (&rest val)
`(insystem? (export*! ,@val) (progn ,@val)))
(defun file-get-contents (filename)
(with-open-file (stream filename)
(let ((contents (make-string (file-length stream))))
(read-sequence contents stream)
contents)))
(export? file-get-contents)
(defun utils->system (input output &key (name :utils) (description "Some random utilities") (author "Ringo <flanchan@cumallover.me>") (license "None"))
"Write this file to an ASDF system."
(let ((this (cadddr (read-from-string (file-get-contents input))))
(sysdef `(asdf:defsystem ,name
:description ,description
:author ,author
:license ,license
:version "0.0.2"
:serial t
:depends-on ,*-utils-depends*
:components ((:file ,(car (last (cl-ppcre:split "/" output))))))))
(rplaca this `(defpackage ,name (:use #:cl)))
(rplaca (cdr this) `(in-package ,name))
(rplaca (cddr this) '(defparameter *-utils-system* t))
(with-open-file (output-lisp (concatenate 'string output ".lisp") :direction :output :if-exists :supersede)
(with-open-file (output-asd (concatenate 'string output ".asd") :direction :output :if-exists :supersede)
(mapc #'(lambda (stmt) (write stmt :stream output-lisp)) this)
(write sysdef :stream output-asd)))))
(export*?
;;; --- actual (exported) code goes here ---
(defmacro popto (li val &key (test #'eql))
"pop() list <li> until (car li) is equal to <val>, return elements pop()ed in new list"
`(loop while (not (funcall ,test (car ,li) ,val))
collect (pop ,li)))
(defmacro popn (li n)
"pop() list <li> <n> times, return elements pop()ed in a new list."
(if (numberp n)
(list 'let '((tmp 'nil))
(apply #'list 'progn
(loop for x from 1 to n
collect `(setf tmp (cons (pop ,li) tmp))))
'(reverse tmp))
`(loop for x from 1 to ,n collect (pop ,li))))
(defun make-paged-vector (blocksize &key (element-type 'integer))
"Vector that increases size in blocks"
(list (make-array blocksize :element-type element-type :fill-pointer 0 :adjustable t) blocksize 0 1))
(defun paged-vector<-size (vec) (caddr vec))
(defun paged-vector<-blocksize (vec) (cadr vec))
(defun paged-vector<-blocks (vec) (cadddr vec))
(defmacro paged-vector->push (vec elem)
"add <elem> to end, extending if needed"
`(if (>= (1+ (mod (paged-vector<-size ,vec) (paged-vector<-blocksize ,vec))) (paged-vector<-blocksize ,vec))
(progn
(adjust-array (car ,vec)
(* (1+ (paged-vector<-blocks ,vec))
(paged-vector<-blocksize ,vec)))
(incf (cadddr ,vec))
(incf (caddr ,vec))
(vector-push ,elem (car ,vec))
,vec)
(progn (incf (caddr ,vec)) (vector-push ,elem (car ,vec)) ,vec)))
(defun make-paged-vector-s (elements blocksize)
"make-paged-vector with default elements"
(let ((out (make-paged-vector blocksize)))
(mapc #'(lambda (x) (paged-vector->push out x)) elements) out))
(defmacro paged-vector<- (vec) `(car ,vec))
) ;; -- end export
(mapc #'fmakunbound '(insystem? export? export*?))
)) ;; -- end guard

4
make-asdf-system
Unescape View File

@ -0,0 +1,4 @@
#!/bin/bash
sbcl --eval "(progn (asdf:load-system :cl-ppcre) (load \"utils.lisp\") (print (utils->system \"utils.lisp\" \"utils/utils\")) (quit))"
echo

113
utils.lisp
Unescape View File

@ -0,0 +1,113 @@
;;;; utils.lisp -- some random utils I collect. might be useful, probably won't be.
(if (boundp '*-utils-lisp*) "Already loaded" (progn
;;; --- internally maintained config, don't put anything above these!!
(defparameter *-utils-lisp* t)
(defparameter *-utils-depends* '(#:cl-ppcre))
(defparameter *-utils-version* "0.0.2")
;;; -- Handle internal exporting --
(defmacro insystem? (thing &optional (else nil))
`(if (boundp '*-utils-system*)
,thing
,else))
(defmacro export? (val)
`(if (boundp '*-utils-system*)
(export ',val)
nil))
(defmacro export* (&rest syms)
`(mapc #'export '(,@syms)))
(defmacro export*! (&rest syms)
`(mapc #'export (list ,@syms)))
(export? export*)
(export? export*!)
(defmacro export*? (&rest val)
`(insystem? (export*! ,@val) (progn ,@val)))
(defun file-get-contents (filename)
(with-open-file (stream filename)
(let ((contents (make-string (file-length stream))))
(read-sequence contents stream)
contents)))
(export? file-get-contents)
(defun utils->system (input output &key (name :utils) (description "Some random utilities") (author "Ringo <flanchan@cumallover.me>") (license "None"))
"Write this file to an ASDF system."
(let ((this (cadddr (read-from-string (file-get-contents input))))
(sysdef `(asdf:defsystem ,name
:description ,description
:author ,author
:license ,license
:version ,*-utils-version*
:serial t
:depends-on ,*-utils-depends*
:components ((:file ,(car (last (cl-ppcre:split "/" output))))))))
(rplaca this `(defpackage ,name (:use #:cl)))
(rplaca (cdr this) `(in-package ,name))
(rplaca (cddr this) '(defparameter *-utils-system* t))
(with-open-file (output-lisp (concatenate 'string output ".lisp") :direction :output :if-exists :supersede)
(with-open-file (output-asd (concatenate 'string output ".asd") :direction :output :if-exists :supersede)
(mapc #'(lambda (stmt) (write stmt :stream output-lisp)) this)
(write sysdef :stream output-asd :case :downcase )))))
(export*?
;;; --- actual (exported) code goes here ---
(defmacro popto (li val &key (test #'eql))
"pop() list <li> until (car li) is equal to <val>, return elements pop()ed in new list"
`(loop while (not (funcall ,test (car ,li) ,val))
collect (pop ,li)))
(defmacro popn (li n)
"pop() list <li> <n> times, return elements pop()ed in a new list."
(if (numberp n)
(list 'let '((tmp 'nil))
(apply #'list 'progn
(loop for x from 1 to n
collect `(setf tmp (cons (pop ,li) tmp))))
'(reverse tmp))
`(loop for x from 1 to ,n collect (pop ,li))))
(defun make-paged-vector (blocksize &key (element-type 'integer))
"Vector that increases size in blocks"
(list (make-array blocksize :element-type element-type :fill-pointer 0 :adjustable t) blocksize 0 1))
(defun paged-vector<-size (vec) (caddr vec))
(defun paged-vector<-blocksize (vec) (cadr vec))
(defun paged-vector<-blocks (vec) (cadddr vec))
(defmacro paged-vector->push (vec elem)
"add <elem> to end, extending if needed"
`(if (>= (1+ (mod (paged-vector<-size ,vec) (paged-vector<-blocksize ,vec))) (paged-vector<-blocksize ,vec))
(progn
(adjust-array (car ,vec)
(* (1+ (paged-vector<-blocks ,vec))
(paged-vector<-blocksize ,vec)))
(incf (cadddr ,vec))
(incf (caddr ,vec))
(vector-push ,elem (car ,vec))
,vec)
(progn (incf (caddr ,vec)) (vector-push ,elem (car ,vec)) ,vec)))
(defun make-paged-vector-s (elements blocksize)
"make-paged-vector with default elements"
(let ((out (make-paged-vector blocksize)))
(mapc #'(lambda (x) (paged-vector->push out x)) elements) out))
(defmacro paged-vector<- (vec) `(car ,vec))
) ;; -- end export
(mapc #'fmakunbound '(insystem? export? export*?))
)) ;; -- end guard
Write Preview
Loading…
Cancel
Save