Skip to content
Browse files

Multimethods library, bros

  • Loading branch information...
1 parent 9cd75a7 commit 302bcdaab6eaf3dc7d329eae3e58c3f493bd84ab @VincentToups committed Feb 13, 2011
Showing with 438 additions and 58 deletions.
  1. +6 −6 chemistry.el
  2. +25 −24 functional.el
  3. +14 −14 macro-utils.el
  4. +6 −0 microstack.el
  5. +233 −0 multi-methods.el
  6. +57 −0 sets.el
  7. +34 −1 stack-words.el
  8. BIN stack-words.elc
  9. +53 −6 utils.el
  10. BIN utils.elc
  11. +10 −7 with-stack.el
  12. BIN with-stack.elc
View
12 chemistry.el
@@ -232,21 +232,21 @@
(format "Mix %f %sL of %s stock" (funcall (alist-in *units-map* `(,units :in)) dv)
(||| {units} "%s" swap 2>format dup length 1 swap substring) substance)))
-(defcurryl hpo-handler concentration-handler
+(defcurryl hpo-handler #'concentration-handler
"HPO")
-(defcurryl da-handler concentration-handler
+(defcurryl da-handler #'concentration-handler
"Dopamine")
-(defcurryr default-da-handler da-handler (from-milli 1) (from-milli 50) :micro)
-(defcurryr default-hpo-handler hpo-handler (from-milli 1000) (from-milli 50) :micro)
+(defcurryr default-da-handler #'da-handler (from-milli 1) (from-milli 50) :micro)
+(defcurryr default-hpo-handler #'hpo-handler (from-milli 1000) (from-milli 50) :micro)
-(defdecorated default-hpo-handler-micro default-hpo-handler
+(defdecorated default-hpo-handler-micro #'default-hpo-handler
(lambda (arglist)
(cons (from-micro (car arglist))
(cdr arglist))))
-(defdecorated default-da-handler-nano default-da-handler
+(defdecorated default-da-handler-nano #'default-da-handler
(lambda (arglist)
(cons (from-nano (car arglist))
(cdr arglist))))
View
49 functional.el
@@ -51,38 +51,39 @@
(defmacro defcurryl (newname &rest args)
"Define a function with left-most partial application on another function."
- (if (stringp (car args))
- `(defcurryl-doc ,newname ,(car args) ,@(cdr args))
- `(defcurryl-no-doc ,newname ,@args)))
+ `(defcurryl-no-doc ,newname ,@args))
+;; (if (stringp (car args))
+;; `(defcurryl-doc ,newname ,(car args) ,@(cdr args))
+;; `(defcurryl-no-doc ,newname ,@args)))
- (defmacro defcurryr (newname oldname &rest args)
- (let ((narglist (gensym (format "%s-arglist" newname))))
- `(defun ,newname (&rest ,narglist)
- (apply #',oldname (append ,narglist (list ,@args))))))
+(defmacro defcurryr (newname oldname &rest args)
+ (let ((narglist (gensym (format "%s-arglist" newname))))
+ `(defun ,newname (&rest ,narglist)
+ (apply ,oldname (append ,narglist (list ,@args))))))
- (defmacro clambdal (oldf &rest args)
- (let ((narglist (gensym "clambdal-arglist-")))
- `(lambda (&rest ,narglist)
- (apply ,oldf ,@args ,narglist))))
+(defmacro clambdal (oldf &rest args)
+ (let ((narglist (gensym "clambdal-arglist-")))
+ `(lambda (&rest ,narglist)
+ (apply ,oldf ,@args ,narglist))))
- (defmacro cl (&rest stuff)
- `(clambdal ,@stuff))
+(defmacro cl (&rest stuff)
+ `(clambdal ,@stuff))
- (defmacro clambdar (oldf &rest args)
- (let ((narglist (gensym "clambdal-arglist-")))
- `(lambda (&rest ,narglist)
- (apply ,oldf (append ,narglist (list ,@args))))))
+(defmacro clambdar (oldf &rest args)
+ (let ((narglist (gensym "clambdal-arglist-")))
+ `(lambda (&rest ,narglist)
+ (apply ,oldf (append ,narglist (list ,@args))))))
- (defmacro cr (&rest stuff)
- `(clambdar ,@stuff))
+(defmacro cr (&rest stuff)
+ `(clambdar ,@stuff))
- (defmacro defdecorated (newname oldname transformer)
- (let ((args (gensym (format "%s-decorated-args" newname))))
- `(defun ,newname (&rest ,args)
- (apply #',oldname
- (funcall #',transformer ,args)))))
+(defmacro defdecorated (newname oldname transformer)
+ (let ((args (gensym (format "%s-decorated-args" newname))))
+ `(defun ,newname (&rest ,args)
+ (apply ,oldname
+ (funcall ,transformer ,args)))))
(defmacro lambdecorate (oldf transformer)
(let ((args (gensym (format "decorated-args"))))
View
28 macro-utils.el
@@ -288,19 +288,19 @@
(if x x (tbl!)))
-(setf *fundamentals* '(if let let* cond lambda defun))
-
-(dont-do
- (symbols-in-form '(let ((a 10) (y 11)) (+ a y x)))
- (optimize-let-form '(let* ((x 10) (y 11) (z (+ x x))) (+ x z)))
- (count-free-usages 'x '(let ((y 11) (z (+ x x))) (+ x z)))
- (get-let-body '(let ((y 11) (z (+ x x))) (+ x z)))
-
- (count-free-usages 'x '(let ((x 10) (y 11) (z (+ x x))) (+ x z)))
- (count-free-usages 'x '(let* ((x 10) (y 11) (z (x x x))) (+ x z)))
- (count-free-usages 'z '(let* nil (+ x z)))
- (length (get-let-binders '(let* nil (+ x z))))
- (count-free-usages-let* 'z '(let* nil (+ x z)))
- (count-free-usages 'z (get-let-body '(let* nil (+ x z))) 0)))
+ (setf *fundamentals* '(if let let* cond lambda defun))
+
+ (dont-do
+ (symbols-in-form '(let ((a 10) (y 11)) (+ a y x)))
+ (optimize-let-form '(let* ((x 10) (y 11) (z (+ x x))) (+ x z)))
+ (count-free-usages 'x '(let ((y 11) (z (+ x x))) (+ x z)))
+ (get-let-body '(let ((y 11) (z (+ x x))) (+ x z)))
+
+ (count-free-usages 'x '(let ((x 10) (y 11) (z (+ x x))) (+ x z)))
+ (count-free-usages 'x '(let* ((x 10) (y 11) (z (x x x))) (+ x z)))
+ (count-free-usages 'z '(let* nil (+ x z)))
+ (length (get-let-binders '(let* nil (+ x z))))
+ (count-free-usages-let* 'z '(let* nil (+ x z)))
+ (count-free-usages 'z (get-let-body '(let* nil (+ x z))) 0)))
(provide 'macro-utils)
View
6 microstack.el
@@ -121,6 +121,12 @@
(rest (pop *stack*)))
(push (apply #'format (cons fmtstr rest)) *stack*)))
+(defstackword generic-move
+ (let ((arg (pop *stack*)))
+ (cond
+ ((numberp arg) (|||- {arg} word))
+ ((
+
(setq micro-stack-map
(alist>>
'b 'backward ; move the point backward once
View
233 multi-methods.el
@@ -0,0 +1,233 @@
+(require 'defn)
+(require 'utils)
+(require 'functional)
+(provide 'multi-methods)
+
+(defun mk-dispatch-table-name (method)
+ "generates the symbol for a dispatch table for METHOD"
+ (internf "--%s-dispatch-table" method))
+
+(defun mk-dispatch-function-name (method)
+ "generates the symbol for the dispatch function for METHOD"
+ (internf "--%s-dispatcher" method))
+
+(defun make-keyword-accessor (kw)
+ "Creates an accessor for tables looking for KW"
+ (lexical-let ((kw kw))
+ (lambda (table &rest args) (table-like-get table kw))))
+
+(defmacro defmulti (name dispatch)
+ "Define a multi-method NAME with dispatch function DISPATCH. DEFUNMULTI defines specific instances of the method."
+ (let ((table-name (mk-dispatch-table-name name))
+ (dispatch-name (mk-dispatch-function-name name))
+ (args-name (gensymf "multi-%s-args" name))
+ (internal-name (gensymf "multi-%s-holder" name))
+ (dispatch (if (not (functionp dispatch)) (make-keyword-accessor dispatch) dispatch)))
+ `(progn
+ (defvar ,table-name (alist>>) ,(format "dispatch-table for %s" name))
+ (defvar ,dispatch-name ,dispatch ,(format "dispatch-function for %s" name))
+ (defun ,name (&rest ,args-name)
+ (let ((,internal-name (isa-dispatch (apply ,dispatch-name ,args-name) ,table-name (make-resolve-by-table (alist *preferred-dispatch-table* ',name) ',name))))
+ (if ,internal-name (apply ,internal-name ,args-name)
+ (error (format ,(format "No known method for args %%S for multimethod %s." name) ,args-name))))))))
+
+(defmacro* defunmethod (name value arglist &body body)
+ "Define a method using DEFUN syntax for the dispatch value VALUE."
+ (let ((g (gensym))
+ (table-name (mk-dispatch-table-name name)))
+ `(let ((,g (lambda ,arglist ,@body)))
+ (setq ,table-name
+ (alist>> ,table-name ,value ,g))
+ ',name)))
+
+(defvar *preferred-dispatch-table* nil "Table of method dispatch resolution rules.")
+(defun prefer-method-fun (name pref-val not-pref-val)
+ "Indicate that the NAMEd multimethod should prefer PREF-VAL over NOT-PREF-VAL when dispatching ambiguous inputs."
+ (let ((subtbl (alist *preferred-dispatch-table* name)))
+ (alist! subtbl (vector pref-val not-pref-val) pref-val)
+ (alist! subtbl (vector not-pref-val pref-val) prev-val)
+ (setf (alist *preferred-dispatch-table* name) subtbl)))
+
+(defmacro prefer-method (name pref-val not-pref-val)
+ "Declare that a particular dispatch value PREF-VAL is preferred over NOT-PREF-VAL when dispatching the NAMEd method."
+ `(prefer-method-fun ',name ,pref-val ,not-pref-val))
+
+
+
+
+(defvar *multi-method-heirarchy* (alist>> :down nil
+ :up nil
+ :resolutions nil) "The default multimethod hierarchy used for isa? dispatch.")
+
+(defun clear-mm-heirarchy ()
+ "Clear the hierarchy in the dynamic scope. "
+ (setq *multi-method-heirarchy* (alist>> :down nil
+ :up nil
+ :resolutions nil))
+ *multi-method-heirarchy*)
+
+(dont-do
+ (setq *multi-method-heirarchy* (alist>> :down nil
+ :up nil))
+ (add-parent-relation :vector :thing)
+ (add-child-relation :thing :vector))
+
+(defun add-parent-relation (child parent)
+ "Add a PARENT CHILD relationship to the hierarchy in the dynamic scope."
+ (let ((parents (alist *multi-method-heirarchy* :up)))
+ (setf (alist *multi-method-heirarchy* :up) (alist-add-to-set parents child parent)))
+ *multi-method-heirarchy*)
+
+(defun add-child-relation (parent child)
+ "Add a CHILD PARENT relationship to the hierarchy in the dynamic scope."
+ (let ((children (alist *multi-method-heirarchy* :down)))
+ (setf (alist *multi-method-heirarchy* :down) (alist-add-to-set children parent child)))
+ *multi-method-heirarchy*)
+
+(defun mm-parents (child)
+ "Get the PARENTS of CHILD from the hierachy in the dynamic scope."
+ (let ((parents (alist *multi-method-heirarchy* :up)))
+ (alist parents child)))
+
+(defun mm-children (parent)
+ "Get the CHILDREN of PARENT from the hierachy in the dynamic scope."
+ (let ((children (alist *multi-method-heirarchy* :down)))
+ (alist children parent)))
+
+(defun mm-ancestors (child)
+ "Get all the ancestors of CHILD."
+ (let* ((parents (mm-parents child))
+ (ancestors parents)
+ (done
+ (if parents nil t)))
+ (loop while (not done) do
+ (let ((above (unique (map&filter #'identity #'mm-parents parents) #'equal)))
+ (if above
+ (progn
+ (setq parents above)
+ (setq ancestors (apply #'append (cons ancestors above))))
+ (setq done t))))
+ ancestors))
+
+(defun mm-descendants (child)
+ "Get all the descendants of CHILD."
+ (let* ((children (mm-children child))
+ (descendants children)
+ (done
+ (if children nil t)))
+ (loop while (not done) do
+ (let ((below (unique (map&filter #'identity #'mm-children children) #'equal)))
+ (if below
+ (progn
+ (setq children below)
+ (setq descendants (apply #'append (cons descendants below))))
+ (setq done t))))
+ descendants))
+
+ ; declare some testing hierarchy
+(derive :thing :parseable)
+(derive :thing :number)
+(derive :thing :collection)
+(derive :collection :list)
+(derive :collection :vector)
+(derive :parseable :string)
+(derive :parseable :buffer)
+
+(defun isa_ (o1 o2)
+ "Underlying implementation of isa on regular objects."
+ (if (equal o1 o2) 0
+ (let* ((parents (mm-parents o1))
+ (done (if parents nil t))
+ (rank (if parents 1 nil)))
+ (loop while (not done) do
+ (if (any (mapcar (cr #'equal o2) parents))
+ (setq done t)
+ (progn
+ (setq rank (+ rank 1))
+ (setq parents
+ (apply #'append (mapcar #'mm-parents parents)))
+ (unless parents
+ (setq done t)
+ (setq rank nil)))))
+ rank)))
+
+(defmacro lazy-and2 (e1 e2)
+ "A lazy and macro."
+ (let ((e1- (gensym "lazy-and-e1-")))
+ `(let ((,e1- ,e1))
+ (if (not ,e1-) nil (and ,e1- ,e2)))))
+
+(defun count-equilength-vectors (list-of)
+ "Return the number of objects in list-of which are equilength vectors."
+ (reduce #'+
+ (let ((n nil))
+ (mapcar
+ (lambda (v?)
+ (if (vectorp v?)
+ (progn
+ (if (not n)
+ (progn
+ (setq n (length v?))
+ 1)
+ (if (= n (length v?)) 1 0)))
+ 0))
+ list-of))))
+
+
+
+(defun isa? (o1 o2)
+ "ISA? test for equality using the default hierarchy. Child ISA? Parent but not vice versa. Isa? returns a number representing the distance to the nearest ancestor that matches. For vectors of objects, these distances are summed. If nil, o1 is not an o2."
+ (case (count-equilength-vectors (list o1 o2))
+ ((0) (isa_ o1 o2))
+ ((1) nil)
+ ((2) (reduce (lambda (a b)
+ (cond
+ ((and (numberp a)
+ (numberp b))
+ (+ a b))
+ (t nil)))
+ (map 'vector #'isa_ o1 o2)))))
+
+(defun resolve-by-first (o r p1 p2)
+ "Default, dumb conflict resolver."
+ (list r p1))
+
+(defun make-resolve-by-table (resolution-table method-name)
+ "Creates a conflict resolution function which checks to see if a method has a specific conflict resolution procedure defined."
+ (lexical-let ((restbl resolution-table)
+ (method-name method-name))
+ (lambda (object rank p1 p2)
+ (print object)
+ (print rank)
+ (print p1)
+ (print p2)
+ (let-if resolution (alist restbl (vector (car p1) (car p2)))
+ (list rank (alist (list p1 p2) resolution))
+ (error "Method dispatch ambiguity for %s unresolved (%S vs %S)." method-name (car p1) (car p2))))))
+
+(defun isa-dispatch (object alist resolver)
+ "Dispatch from an alist table based on ISA? matches. More specific matches are preferred over less, and ambiguous matches will be resolved by the function resolver."
+ (cadr (cadr (foldl
+ (lambda (alist-pair best-so-far)
+ (let ((rank (isa? object (car alist-pair))))
+ (cond
+ ((not rank) best-so-far)
+ ((not best-so-far) (list rank alist-pair))
+ ((< rank (car best-so-far))
+ (list rank alist-pair))
+ ((> rank (car best-so-far)) best-so-far)
+ ((= rank (car best-so-far))
+ (if rank
+ (funcall resolver object rank alist-pair (cadr best-so-far)) nil)))))
+ nil
+ alist))))
+
+(dont-do
+ ;example
+ (defmulti report :student-name)
+ (defunmethod report :ricky-gervais (student) "I got an A+")
+ (defunmethod report :karl-pilkington (student) "Maybe I forgot to sign up for exams.")
+ (report (alist>> :student-name :ricky-gervais)) ;-> "I got an A+"
+ (report (alist>> :student-name :karl-pilkington)) ;-> "Maybe I forgot to sign up for exams.")
+ (report (alist>> :steven-merchant)) ;-> error, no method
+)
View
57 sets.el
@@ -0,0 +1,57 @@
+(provide 'sets)
+(require 'utils)
+(require 'cl)
+
+(defun* make-set (members &optional (pred #'equal))
+ (alist>> :values (unique members pred)
+ :pred pred))
+
+(defun predicate-of-set (set)
+ (alist set :pred))
+
+(defun values-of-set (set)
+ (alist set :values))
+
+(defun check-set-compat (set1 set2)
+ (if (not (equal
+ (predicate-of-set set1)
+ (predicate-of-set set2)))
+ (error "Can't operate on sets with distinct predicates.")
+ t))
+
+(defun* set-union (set1 set2)
+ (check-set-compat set1 set2)
+ (make-set (unique (append (values-of-set set1)
+ (values-of-set set2)) (predicate-of-set set1))
+ (predicate-of-set set1)))
+
+(defun in-set (object set)
+ ($ object in (values-of-set set) (predicate-of-set set)))
+
+(defun set-intersection (set1 set2)
+ (check-set-compat set1 set2)
+ (let ((vals (values-of-set (set-union set1 set2))))
+ (make-set
+ (filter
+ (lambda (item)
+ (and ($ item in-set set1)
+ ($ item in-set set2)))
+ vals)
+ (predicate-of-set set1))))
+
+(defun set-difference (set1 set2)
+ (check-set-compat set1 set2)
+ (let ((v1 (values-of-set set1))
+ (v2 (values-of-set set2)))
+ (filter
+ (lambda (i1)
+ (not ($ i1 in-set set2)))
+ v1)))
+
+(defun set-count (set)
+ (length (values-of-set set)))
+
+(defun set-equality (set1 set2)
+ (check-set-compat set1 set2)
+ (= (set-count set1)
+ (set-count (set-union set1 set2))))
View
35 stack-words.el
@@ -1,4 +1,5 @@
(require 'with-stack)
+(require 'utils)
(require 'monads)
(require 'functional)
@@ -12,12 +13,44 @@
end:)
(||| word: foldl ;( list init qtn -- result )
swapd leach end:)
+(defstackword current-continuation
+ (push *stack* *stack*))
+
+(defstackword apply-emacs-fun
+ (let ((arg-list (pop *stack*))
+ (fun (pop *stack*)))
+ (push (apply fun arg-list) *stack*)))
+
+(defstackword alist>>
+ (let ((args (pop *stack*)))
+ (push (apply #'alist>> (cons nil args)) *stack*)))
+
+(defstackword alist
+ (|||- 2>alist))
+
+(defstackword format ; ( format-string arguments -- string )
+ (|||- cons 'format swap apply-emacs-fun))
+
+(||| word: if* pick '(drop call) '(2nip call) if end:)
+
+(defstackword cond ; ( association-list -- ...)
+ (let ((condition-pairs (pop *stack*))
+ (done nil))
+ (loop while (not done)
+ for cond-pair
+ in condition-pairs do
+ (let ((condquot (car cond-pair))
+ (doquot (cadr cond-pair)))
+ (if (|||- {condquot} call)
+ (progn
+ (|||- drop {doquot} call)
+ (setq done t))
+ (|||- drop))))))
(defn split-by-match
([begin end [first & rest :as lst]
height
outlist]
-
(cond (lst
(cond
((equal first begin)
View
BIN stack-words.elc
Binary file not shown.
View
59 utils.el
@@ -10,12 +10,10 @@
(defun list->vector (lst)
"Convert a list to a vector."
- (assert (listp lst) t "list->vector: input not a list.")
(coerce lst 'vector))
(defun vector->list (vec)
"Convert a vector to a list."
- (assert (vectorp vec) t "vector->list input not a vector.")
(coerce vec 'list))
(defun get-current-line-substring ()
@@ -765,7 +763,7 @@
"Test to see if a symbol has a value."
(let ((return-val nil))
(condition-case nil (setq return-val (symbol-value symbol))
- (error nil))))
+ (error nil))))
(defmacro let-repeatedly-until (name pred &rest forms)
"Like let-repeatedly, but stop once PRED is TRUE, returning last NAME value."
@@ -864,6 +862,16 @@
(defun* alist (alist el)
"Access element EL in an alist ALIST."
(cadr (assoc el alist)))
+
+(defun alist! (alist el value)
+ "Destructively updates EL to VALUE in ALIST."
+ (let ((element-holder (assoc el alist)))
+ (if element-holder (setf (cadr element-holder) value)
+ (setcdr (last alist) (list (list el value)))))
+ alist)
+
+(defsetf alist alist!)
+
(defun* alist-or (alist el &optional (or-val nil))
"Like ALIST but returns OR-VAL if (alist lst el) is nil."
(let ((v (assoc el alist)))
@@ -898,9 +906,6 @@
(defun alist-conjugate (alst key fun)
"Returns a new alist where the value of key is now (fun (alist alst key))."
- (print alst)
- (print key)
- (print fun)
(let ((val (alist alst key)))
(alist>> alst key (funcall fun val))))
@@ -910,6 +915,11 @@
(lexical-let ((value value))
(lambda (xxx) (cons value xxx)))))
+(defun alist-add-to-set (alst key value)
+ (alist-conjugate alst key
+ (lexical-let ((value value))
+ (lambda (xxx) (if (not ($ value in xxx)) (cons value xxx) xxx)))))
+
(defun dissoc (alist &rest keys)
"Returns a new ALIST without KEYS."
(let ((keys (flatten keys)))
@@ -1154,6 +1164,36 @@
"Just return the even-indexed elements of the list."
(filter-by-index #'evenp list))
+(defun none-nil (lst)
+ (and-over #'identity lst))
+
+
+
+(defun map&filter (filter-fun transform &rest lists)
+ "Map TRANSFORM across elements in LISTS keeping only those for which FILTER-FUN is true on the output of TRANSFORM."
+ (let ((rests lists)
+ (output nil))
+ (loop while (none-nil rests) do
+ (let* ((els (mapcar #'car rests))
+ (new-rests (mapcar #'cdr rests))
+ (val (apply transform els)))
+
+ (setq rests new-rests)
+ (if (funcall filter-fun val) (push val output))))
+ (reverse output)))
+
+(defun filter&map (filter-fun transform &rest lists)
+ "Map TRANSFORM across ELEMENTS in LISTS only for those for which FILTER-FUN is true."
+ (let ((rests lists)
+ (output nil))
+ (loop while (none-nil rests) do
+ (let* ((els (mapcar #'car rests))
+ (new-rests (mapcar #'cdr rests))
+ (check (apply filter-fun els)))
+ (setq rests new-rests)
+ (if check (push (apply transform els) output))))
+ (reverse output)))
+
(defun factor (n)
"factor a number n by recourse to the command line utility FACTOR."
(mapcar #'read (cdr (split-string (car (capture-shell "factor" (format "%d" n))) " " t))))
@@ -1626,4 +1666,11 @@
(defconst pi 3.14159265 "The constant pi.")
(defconst phi 1.61803399 "The golden ratio")
+(defun gensymf (&rest args)
+ (gensym (apply #'format args)))
+
+(defun* for-work-monitor (&optional (val 100))
+ (interactive)
+ (set-face-attribute 'default nil :height val))
+
(provide 'utils)
View
BIN utils.elc
Binary file not shown.
View
17 with-stack.el
@@ -68,7 +68,7 @@
(and ($ ">" in s)
(let* ((parts (split-string s ">"))
(n-stack-part (car parts)))
- (or (eq n-stack-part "n")
+ (or (string= n-stack-part "n")
(numberp (read n-stack-part)))))))
(defun gen-temp-syms (n)
@@ -88,10 +88,11 @@
(n (read (car parts)))
(sym (intern (join (cdr parts) ">")))
(list-sym (gensym "npop-"))
- (temp-syms (gen-temp-syms n)))
+ (temp-syms (if (numberp n) (gen-temp-syms n) nil)))
+ (print n)
(cond ((and (symbolp n) (eq n 'n))
- `(let ((,list-sym (pop-n *stack*)))
- (appply #',sym (reverse ,list-sym))))
+ `(let ((,list-sym (pop-n (pop *stack*) *stack*)))
+ (apply #',sym (reverse ,list-sym))))
((numberp n)
`(let ,(loop for s in temp-syms collect
`(,s (pop *stack*)))
@@ -501,11 +502,13 @@
(defstackword in ;( item lst -- bool )
(|||- 2>in))
-
-
(univalent-stack-words car cdr cadr first second third fourth list regexp-quote rxq reverse length)
-(bivalent-stack-words split-string join)
+(bivalent-stack-words split-string join cons)
(n-valent-stack-words 3 replace-regexp-in-string reprxstr substring)
+(defstackword apply-emacs-fun
+ (let ((arg-list (pop *stack*))
+ (fun (pop *stack*)))
+ (push (apply fun arg-list) *stack*)))
(provide 'with-stack)
View
BIN with-stack.elc
Binary file not shown.

0 comments on commit 302bcda

Please sign in to comment.
Something went wrong with that request. Please try again.