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

Remade exporting structure

Browse Source
master
Ringo Wantanabe 6 years ago
parent 92046b7133
commit a38640a581
No known key found for this signature in database
GPG Key ID: DDDD9B6759158726
5 changed files with 80 additions and 121 deletions
Show Stats Download Patch File Download Diff File

2
.gitignore vendored
Unescape View File

@ -1 +1 @@
utils/
utils

3
Makefile
Unescape View File

@ -1,3 +0,0 @@
flan-utils:
./make-asdf-system

15
flan-utils.asd
Unescape View File

@ -0,0 +1,15 @@
(asdf/parse-defsystem:defsystem :flan-utils
:description
"Some random utilities"
:author
"Rin <flanchan@cumallover.me>"
:license
"None"
:version
"0.2.0"
:serial
t
:depends-on
(#:cl-ppcre #:bordeaux-threads)
:components
((:file "flan-utils")))

177
utils.lisp → flan-utils.lisp
Unescape View File

@ -1,115 +1,46 @@
;;;; 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 #:bt-semaphore))
(defparameter *-utils-version* "0.1.6")
;;; -- 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)))
(defpackage :flan-utils (:use :cl))
(in-package :flan-utils)
(defmacro export* (&rest syms)
"Export all symbols"
(cons 'progn (mapcan #'(lambda (x) `((export ',x))) syms)))
(defmacro eval-all (syms)
"Eval all statements, return in list."
`(mapcar #'eval '(,@syms)))
(export? eval-all)
(export 'eval-all)
(defmacro export*! (&rest syms)
"Eval all statements export return values"
`(mapc #'export (eval-all ,syms)))
(export? export*)
(export? export*!)
(export 'export*)
(export 'export*!)
(defmacro export*? (&rest val)
`(insystem? (export*! ,@val)
(mapc #'eval '(,@val))))
(defmacro defexport (&rest val)
"Same as export*! for some reason"
`(export*! ,@val))
(export? defexport)
(export 'defexport)
(defun file-get-contents (filename)
"Read file into string"
(with-open-file (stream filename)
(let ((contents (make-string (file-length stream))))
(read-sequence contents stream)
contents)))
(export? file-get-contents)
;(export? val-if-or)
(defun utils->system (input output &key (name :flan-utils) (description "Some random utilities") (author "Ringo <flanchan@cumallover.me>") (license "None"))
(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 :pretty nil)) this)
(write sysdef :stream output-asd :case :downcase )))))
;(defun utils->create-for (utils for &key (name 'flan-utils) ) ;;; TODO: Make this work /for structs/ at all
; (let ((this (cadddr (read-from-string (file-get-contents utils))))
; (for (read-from-string (file-get-contents for))))
; (labels ((sieve (li) ;; find all `,name:' functions in list
; (mapcan #'(lambda (part)
; (if (atom part)
; (if (cl-ppcre:scan (concatenate 'string "^" (write-to-string name) ":")
; (write-to-string part))
; (list part)
; nil)
; (sieve part)))
; li)))
; (let ((syms (sieve for))
; (allowed-definitions '(defun
; defmacro
; defparameter))) ;;;; STRUCT
; (labels ((find-func (sym-name l) ;;; TODO: here
; (mapcan #'(lambda (part)
; (when (not (atom part))
; (if (eql (cadr part) sym-name) ;; symbol found
; (list part)
; (when (eql (car part) 'export*?) ;; export*?
; (find-func sym-name part)))))
; l)))
; (let ((defs (mapcan #'(lambda (sym)
; (find-func (read-from-string (cadr (cl-ppcre:split (concatenate 'string "^" (write-to-string name) ":") (write-to-string sym)))) this))
; syms)))
; (mapcan #'(lambda (def)
; (when (member (car def) allowed-definitions)))
; defs)))))))
(export 'file-get-contents)
(defparameter *old-readtables* nil)
(export*?
(defexport
;;; --- actual (exported) code goes here --
(defmacro val-if-or (val test or)
"(if (test val) val or)"
`(let ((vv ,val))
(if (funcall ,test vv) vv ,or)))
@ -122,9 +53,11 @@
(not (null f)))
(defun nop ()
"Do nothing"
nil)
(defun yep ()
"Do nothing"
t)
(defun mapline (input fi &key (read-line #'read-line))
@ -133,6 +66,7 @@
while line do (funcall fi line)))
(defun strcat (&rest str)
"Concat all strings, if item is not string it is written to one."
(apply #'concatenate (cons 'string (mapcar #'(lambda (x)
(typecase x
(string x)
@ -141,21 +75,19 @@
str))))
(defmacro until (stmt)
"Repeat stmt until its return is not NIL, then return that value."
`(let ((ret nil))
(loop while (null (setf ret ,stmt)))
ret))
(defmacro until-trace (stmt)
`(let ((ret nil))
(loop while (null (setf ret ,stmt))
collect ret)))
(defmacro popor (li or)
"If li is list, pop it, else return or"
`(if (atom ,li) ,or
(pop ,li)))
(defun rand-in (l &key (random #'random) )
"Random member of, slide right if nil"
"Pretty sure this doesn't work"
(let ((rng (funcall random (list-length l))))
(let ((nl (nthcdr rng l)))
(until (pop nl)))))
@ -172,6 +104,7 @@
(<= num s)))
(defun format-string (fmt &rest r)
"Like sprintf I guess"
(with-output-to-string (stream)
(apply #'format `(,stream ,fmt . ,r))))
@ -183,29 +116,33 @@
lst))
(defun symbol-match (scan &optional (symbols nil))
"Return all symbols whose names match regex `scan'. If symbols are not provided, get them all."
(let ((symbols (val-if-or symbols #'true
(get-all-symbols))))
(where #'(lambda (x) (cl-ppcre:scan scan (write-to-string x)))
symbols)))
(defun index (i max)
"Looping index"
(if (< i 0)
(index (+ max i) max)
(mod i max)))
(defun slice (seq start end)
"only works with lists i guess"
"Like JS slice()?"
(let ((start (index start (length seq)))
(end (index end (length seq))))
(rplacd (nthcdr end seq) nil)
(nthcdr start seq)))
(defun flatten-top-level (li)
"'( (1 2) 3 4 (5 6 7) (8) ((9 10))) -> ( 1 2 3 4 5 6 7 8 (9 10))"
(mapcan #'(lambda (x)
(if (atom x) (list x) x))
li))
(defun flatten (li)
"'( (1 2) 3 4 (5 6 7) (8) ((9 10))) -> ( 1 2 3 4 5 6 7 8 9 10)"
(mapcan #'(lambda (x)
(if (atom x)
(list x)
@ -213,6 +150,7 @@
li))
(defun strjoin (delim &rest strs)
"Join strings with deliminator"
(let ((strs (flatten-top-level strs)))
(apply #'strcat
(slice
@ -221,10 +159,11 @@
strs)
0 -2))))
(defun export-struct (struct &optional (symbols nil)) ;;XXX: Exporting make-* is a hack and you should fix it
(defun export-struct (struct &optional (symbols nil)) ;;XXX: Exporting make-* does not check for $
"Export all symbols relating to `struct'"
(mapc #'export (symbol-match (strcat "^(MAKE-)?" (write-to-string struct) "-?") symbols)))
(defun -export*-struct (structs &optional (symbols nil)) ;;XXX: Exporting make-* is a hack and you should fix it
(defun -export*-struct (structs &optional (symbols nil)) ;;XXX
(mapc #'export (symbol-match
(strcat
"^(MAKE-)?("
@ -233,6 +172,7 @@
symbols)))
(defmacro export*-struct (&rest structs)
"Export all symbols relating to multiple structs"
`(-export*-struct '(,@structs)))
@ -245,6 +185,7 @@
ret))
(defun cyclic (list)
"Simple circular list"
(cdr (rplacd (last list) list)))
(defun map1 (lam &rest lists)
@ -279,7 +220,9 @@
(mapcar lam (flatten-top-level args))))
(defmacro lexical-boundp (lex)
"XXX: Use (declare (special ...)) instead"
`(when (ignore-errors ,lex) t))
;; --- progressive evals
(defmacro progen (&rest things)
@ -307,6 +250,7 @@
(apply #'values --yield-var)))
(defmacro yield (value)
"Yield return value `value' if in yield-return(...) block."
`(when (boundp '--yield-vars)
(setf --yield-var (multiple-value-list ,value))
(push (car --yield-var) --yield-vars)))
@ -328,35 +272,43 @@
;; ---
(defmacro push-unique (thing things &key (key nil) (test #'eql))
"Push if not member"
`(let ((lex-thing ,thing))
(if (member lex-thing ,things :key ,key :test ,test)
(values ,things nil)
(values (push lex-thing ,things) t))))
(defmacro import* (&rest args)
"Import all symbols"
(cons 'progn (mapcan #'(lambda (x) `((import ',x))) args)))
(defmacro shadowing-import* (&rest args)
"Import all symbols (shadowing)"
(cons 'progn (mapcan #'(lambda (x) `((shadowing-import ',x))) args)))
(defmacro import*! (&rest args)
"Map eval then import all returns"
`(mapc #'import (progel ,args)))
(defmacro shadowing-import*! (&rest args)
"Map eval then import all returns (shadowing)"
`(mapc #'shadowing-import (progel ,args)))
(defmacro import*-from (package &rest args)
"Import all symbols from package. NOTE: You shouldn't prefix the symbols with the package name"
(let ((ret (mapcar #'(lambda (x) (read-from-string (strcat (subseq (write-to-string package) 1) ":" (write-to-string x)))) args)))
`(shadowing-import* @,ret)))
(defun restrain-index (i max)
(if nil
(if (>= i max) (1- max)
(if (< i 0) 0
i))
i))
;(defun restrain-index (i max)
;
; (if nil
; (if (>= i max) (1- max)
; (if (< i 0) 0
; i))
; i))
(defun many-equals (items &key (test #'eql))
"For some reason equality comparers don't like more than 2 args"
(let ((comp (car items)))
(labels ((compare (x to)
(when (null x) t)
@ -367,18 +319,23 @@
(defun many-eql (&rest items)
(many-equals items :test #'eql))
; --- async stuff
(defstruct async-info
thread
handlers
lock)
(defmacro push-handler (name lam)
"Push new handler to current async-info with name"
"NOTE: Should only be used inside an async() body."
`(bt:with-lock-held
((async-info-lock current-async-info))
(push (cons ,name ,lam)
(async-info-handlers current-async-info))))
(defmacro async (&rest form)
"Run form(s) async"
`(let ((current-async-info (make-async-info)))
(setf (async-info-handlers current-async-info) nil)
(setf (async-info-lock current-async-info) (bt:make-lock))
@ -389,22 +346,26 @@
current-async-info))
(defun async-info-handler (async name &key (test 'eql))
"Get handler from async-info of name"
(bt:with-lock-held ((async-info-lock async))
(let ((as (assoc name (async-info-handlers async) :test test )))
(and as
(cdr as)))))
(defun wait (handle)
"Wait on async()"
(if (async-info-p handle)
(wait (async-info-thread handle))
(bt:join-thread handle)))
(defun async-kill (handle)
"Kill async()"
(if (async-info-p handle)
(async-kill (async-info-thread handle))
(bt:destroy-thread handle)))
(defun async-alive (handle)
"Is async() alive"
(if (async-info-p handle)
(async-alive (async-info-thread handle))
(bt:thread-alive-p handle)))
@ -412,6 +373,7 @@
(defun val (v) v)
(defun groupn (n list)
"Group list into sublists every `n' items."
(let ((last nil)
(ret nil))
(loop for x in list
@ -424,6 +386,8 @@
(setf last nil))))
(reverse ret)))
; --- reader macros
(defun sexpr-reader (stream char &key (func 'val))
"Read next token only if S expression, else return as is"
(if (char= (peek-char t stream t nil t) #\()
@ -435,20 +399,7 @@
(defun bang-reader (stream char)
(declare (ignore char))
(list (quote not) (read stream t nil t)))
;
;(defmacro enable-reader (char func &optional (keep t))
; `(eval-when (:compile-toplevel :load-toplevel :execute)
; (when keep
; (push *readtable* *old-readtables*)
; (setq *readtable* (copy-readtable)))
; (set-macro-character ,char ,func)))
;
;(defun disable-reader (&optional (char nil))
; (if (null char)
; '(eval-when (:compile-toplevel :load-toplevel :execute)
; (setq *readtable* (pop *old-readtables*)))
; `(set-macro-character ,char nil)))
;
(defun read-delimiter (stream char)
(declare (ignore stream char)))
@ -539,6 +490,8 @@
; (make-list length :initial-element 1)
; :debug t))
; --- others
(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))
@ -584,6 +537,4 @@
) ;; -- end export
(mapc #'fmakunbound '(insystem? export? export*?))
)) ;; -- end guard

4
make-asdf-system
Unescape View File

@ -1,4 +0,0 @@
#!/bin/bash
sbcl --eval "(progn (asdf:load-system :cl-ppcre) (asdf:load-system :bt-semaphore) (load \"utils.lisp\") (print (utils->system \"utils.lisp\" \"utils/flan-utils\")) (quit))"
echo
Write Preview
Loading…
Cancel
Save