summaryrefslogtreecommitdiffstats
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/keyparams.tl55
1 files changed, 21 insertions, 34 deletions
diff --git a/stdlib/keyparams.tl b/stdlib/keyparams.tl
index eaaebc6c..6e161643 100644
--- a/stdlib/keyparams.tl
+++ b/stdlib/keyparams.tl
@@ -24,28 +24,23 @@
;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.
-(defun sys:extract-keys (keys args)
- (build
- (each ((k keys))
- (iflet ((f (memp (car k) args)))
- (add (cadr f))
- (add (cdr k))))))
-(defun sys:extract-keys-p (keys args)
- (build
- (each ((k keys))
- (add (if (memp k args) t)))))
-
-(defun sys:build-key-list-expr (key-params menv)
- (let ((exprs (collect-each ((kp key-params))
- (let ((kw (intern (symbol-name (first kp)) 'keyword))
- (ex (second kp)))
- (if (constantp ex menv)
- ^(quote (,kw . ,(second kp)))
- ^(cons ,kw ,(second kp)))))))
- (if [all exprs (op eq 'quote) car]
- ^(quote ,[mapcar cadr exprs])
- ^(list ,*exprs))))
+(defun sys:stuff-key-params (keys args)
+ (with-gensyms (cell)
+ (collect-each ((k keys))
+ (tree-bind (sym : init sym-p) k
+ (let ((kw (intern (symbol-name sym) :keyword)))
+ ^(let ((,cell (memp ,kw ,args)))
+ ,(if init
+ ^(cond
+ (,cell
+ (set ,sym (cadr ,cell))
+ ,*(if sym-p ^((set ,sym-p t))))
+ (t
+ (set ,sym ,init)))
+ ^(when ,cell
+ (set ,sym (cadr ,cell))
+ ,*(if sym-p ^((set ,sym-p t)))))))))))
(define-param-expander :key (param body menv form)
(let* ((excluding-rest (butlastn 0 param))
@@ -74,17 +69,9 @@
(compile-error form "invalid dotted form ~s" key-spec))
(unless (bindable sym)
(compile-error form "~s isn't a bindable symbol" sym)))))
- (let* ((key-params-p [keep-if third key-params])
- (key-vars [mapcar first key-params])
- (key-vars-p [mapcar third key-params-p])
- (keys (sys:build-key-list-expr key-params menv))
- (keys-p (mapcar (op intern (symbol-name (first @1)) 'keyword)
- key-params-p)))
+ (let* ((key-syms [mapcar first key-params])
+ (key-syms-p (remq nil [mapcar third key-params])))
(list eff-param
- ^(tree-bind ,key-vars
- (sys:extract-keys ,keys ,rest-param)
- ,*(if keys-p
- ^((tree-bind ,key-vars-p
- (sys:extract-keys-p ',keys-p ,rest-param)
- ,*body))
- body))))))
+ ^(let (,*key-syms ,*key-syms-p)
+ ,*(sys:stuff-key-params key-params rest-param)
+ ,*body)))))