Commit ed79ebe8 authored by hayeah via gmail com's avatar hayeah via gmail com

Removed kludge for defining fmt-op

fmt-ops were previously defined by top-level macros.

Now when expanding fmt, fmt-ops are expanded with closures found
in *fmt-ops*. &whole and &enviornment not yet supported.

darcs-hash:eb3e61681e79dd0b0d709875b9b48ae882f415c6
parent 34944439
......@@ -139,7 +139,13 @@ Return: ((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
;; (use-package :wisp.util)
(process-js '(foo bar BazBaf ~ ab cd @ la boo))
(process-js 'foo)
(wisp.util::fmt (:a 4 5))
(defmacro process-js (js-form)
`(fmt (process *javascript* (get-pretty-printer) ,js-form (top-level-environment *javascript*))))
(defmethod process-sexp ((language javascript) processor form environment)
(if (consp form)
;; Need to deal with anonymous function call using process-function-call
......@@ -154,6 +160,12 @@ Return: ((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
(process-javascript-scalar processor form))
(maybe-semicolon processor environment))
(defun process-object-path (language processor environment objects)
(loop for (obj . rest) on objects do
(process language processor obj (new-env 'statement-or-expression :expression environment))
when rest do (raw-string processor ".")))
(defun process-object-path (language processor environment objects)
(loop for (obj . rest) on objects do
(process language processor obj (new-env 'statement-or-expression :expression environment))
......@@ -199,6 +211,7 @@ Return: ((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
(number (raw-string processor (format nil "~a" value)))
(character (raw-string processor (javascript-character-text value)))))
(defun javascript-character-text (char)
(case char
(#\Tab "'\\t'")
......@@ -616,8 +629,7 @@ statements such as blocks to *not* emit a semicolon."
(defmacro process-js (js-form)
`(process *javascript* (get-pretty-printer) ,js-form (top-level-environment *javascript*)))
(process-js '(function (b c) d f g))
......@@ -88,20 +88,41 @@
(defun build/rkr/fnlist (required-args key-args rest)
`(,@required-args
,@(when (or rest key-args) '(&key)) ;; include '&key' only there are any key-args (possibly with rest-arg)
,@(when (or rest key-args) '(&key)) ;; include '&key' only if there are any key-args (possibly with rest-arg)
,@(if rest (cons rest key-args) key-args)))
;; Someday support the extended macro lambda list. (Destructuring args)
;; Someday support the extended lambda list. (Destructuring args)
(defmacro def/rkr/fn-type (fn-type name fnlist &body body)
(let* ((fn (mvbind (required-args key-args rest) (parse/rkr/fnlist fnlist)
`(fn (&rest arg-list)
(flet ((bind-args ,(build/rkr/fnlist required-args key-args rest) ,@body))
(mvbind (required keys rest) (parse/rkr/args arg-list ',required-args ',(mapcar #'car key-args))
(let ((keys (if rest ;; sneak in the rest-arg as if it is a key arg
(append (list ,(intern (symbol-name rest) :keyword) rest) keys)
keys)))
(apply #'bind-args (append required keys))))))))
(fn (if (eql fn-type :defmacro)
;; get rid of macro-name for macro expansion, for now.
;; ;; TODO deal with &environment and &whole
`(fn (&rest arg-list) (apply ,fn (cdar arg-list)))
fn)))
(ecase fn-type
(:defmacro `(progn (-> (macro-function ',name) ,fn) ',name))
(:defun `(progn (-> (symbol-function ',name) ,fn) ',name))
(:fn `,fn))))
(defmacro def/rkr/macro (name fnlist &body body)
"Doesn't take document string. Big problem."
(mvbind (required-args key-args rest) (parse/rkr/fnlist fnlist)
`(defmacro ,name (&rest arg-list)
(flet ((bind-args ,(build/rkr/fnlist required-args key-args rest) ,@body))
(mvbind (required keys rest) (parse/rkr/args arg-list ',required-args ',(mapcar #'car key-args))
(let ((keys (if rest ;; add the rest-arg as if it is a key arg
(append (list ,(intern (symbol-name rest) :keyword) rest) keys)
keys)))
(apply #'bind-args (append required keys))))))))
`(def/rkr/fn-type :defmacro ,name ,fnlist ,@body))
(defmacro def/rkr/fun (name fnlist &body body)
`(def/rkr/fn-type :defun ,name ,fnlist ,@body))
(defmacro rkr/fn (fnlist &body body)
`(def/rkr/fn-type :fn nil ,fnlist ,@body))
;; (funcall (rkr/fn (a b &key c d &rest rest) (list a b c d rest)) 1 2 :d 3 4 5)
;; (def/rkr/fun foo (a b &key c d &rest rest) (list a b c d rest))
;; (foo 1 2 :d 3 4 5)
(defun push/rkr/keyarg (keyarg fnlist)
......@@ -134,16 +155,13 @@
;;;; fmt interface
(defmacro defmt-op (name args &body body)
"Defines a new format operation macro that may be used within the fmt macro. The names has to be a keyword."
(if (keywordp name)
`(progn
(pushnew ,name *fmt-ops*)
(def/rkr/macro ,(symcat 'fmt- name) ,args ,@body))
(if (keywordp name)
`(-> (getf *fmt-ops* ,name) (rkr/fn ,args ,@body))
;;(setf (getf ,name *fmt-ops*) (fn/rkr ,args ,@body))
(error "Invalid (keyword) name for format op: ~S" name)))
(defun valid-fmt-op? (fmt-op)
(aif (member fmt-op *fmt-ops*)
(car it)
nil))
(defun find-fmt-op (fmt-op)
(getf *fmt-ops* fmt-op))
;; "No destructuring lambda arg"
(defparameter nil-options '(:nil :list :none))
......@@ -161,19 +179,21 @@
((keywordp fmt-cmd) `(fmt (,fmt-cmd)))
((atom fmt-cmd) (select-nil-option fmt-cmd))
(t
(aif (valid-fmt-op? (car fmt-cmd))
`(,(symcat 'fmt- it) ,@(cdr fmt-cmd))
(aif (find-fmt-op (car fmt-cmd))
;; I am throwing the enviornment away.
;; ;; this is kinda ugly.
(apply (find-fmt-op (car fmt-cmd)) (cdr fmt-cmd))
(select-nil-option fmt-cmd)))))
fmt-cmds)))
fmt-cmds)))
(def/rkr/macro fmt (&key (> '*fmt-stream*) (nil-option :nil) &rest fmt-cmds)
(let* ((body (make-fmt-instructions fmt-cmds :nil-option nil-option))
(body `(macrolet ((fmt (&rest rest) `(progn ,@(make-fmt-instructions rest :nil-option ,nil-option))))
,@body))) ;;rebind fmt so no extra logical blocks are created in embedded fmt calls
,@body))) ;;rebind fmt so no extra logical blocks are created in embedded fmt calls
(case >
((nil) `(with-output-to-string (*fmt-stream*)
(pprint-logical-block (*fmt-stream* nil) ,body)))
(pprint-logical-block (*fmt-stream* nil) ,body)))
(t `(pprint-logical-block (,> nil) ,body)))))
......@@ -198,7 +218,7 @@
;; argument.
;; - Accepts multiple arguments."
(defmt-op :A (&key (as-nil t) (mincol 0) (colinc 1) (minpad 0) (padchar #\space) (pad-left nil) &rest args)
(defmt-op :a (&key (as-nil t) (mincol 0) (colinc 1) (minpad 0) (padchar #\space) (pad-left nil) &rest args)
(let ((pad-left (if pad-left "@" ""))
(as-nil (if as-nil "" ":")))
`(format *fmt-stream* ,#?"~@\{~${mincol},${colinc},${minpad},'${padchar}${as-nil}${pad-left}A~}" ,@args)))
......
......@@ -60,7 +60,13 @@
(abbrevs mvbind multiple-value-bind
mvsetq multiple-value-setq
dbind destructuring-bind)
dbind destructuring-bind
-> setf
--> set
;; <- getf
;; <-- get
)
(defmacro fn (args &body body)
(cond
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment