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

Messing around with language.lisp

darcs-hash:8c7d63c62e8e9b15fca685b4d681f721cd351b5b
parent dfbd913d
......@@ -21,6 +21,14 @@
(defun statement-or-expression (env)
(cdr (assoc 'statement-or-expression env)))
(defun js-expression? (env)
(eql (cdr (assoc 'statement-or-expression env))
:expression))
(defun js-statement? (env)
(eql (cdr (assoc 'statement-or-expression env))
:statement))
(defparameter *javascript* (make-instance 'javascript))
(defvar *javascript-gensym-counter* 0)
......@@ -86,18 +94,30 @@ Return:
(defun parse-js-form (js-form)
"Parse javascript form of the form
(<js-form>* [~ <js-form>*] [@ <js-form>*])
"Parse javascript form of the form (<js-form>* [~ <js-form>*] [@ <js-form>*])
Where forms before ~ are object path.
Between ~ and @ are arguments to method application.
After @ are array references.
- Return ((<js-form>*) (~ <js-form>*) (@ <js-form>*))"
-
Return: ((<js-form>*) (~ <js-form>*) (@ <js-form>*)) "
(let* ((separators '(~ @))
(broken-form (split-by-tests js-form '(~ @))))
(cons (car broken-form)
(mapcar #'(lambda (separator)(assoc separator broken-form))
separators))))
(defun string-invert (str)
"Invert case of a string"
(declare (optimize (speed 3) (compilation-speed 0) (debug 0) (safety 0))
(simple-string str))
(let ((up nil) (down nil))
(block skip
(loop for char of-type character across str do
(cond ((upper-case-p char)
(if down (return-from skip str) (setf up t)))
((lower-case-p char)
(if up (return-from skip str) (setf down t)))))
(if up (string-downcase str) (string-upcase str)))))
......@@ -117,7 +137,9 @@ After @ are array references.
;; (use-package :wisp.util)
(process-js '(foo bar BazBaf ~ ab cd @ la boo))
(defmethod process-sexp ((language javascript) processor form environment)
(if (consp form)
;; Need to deal with anonymous function call using process-function-call
......@@ -188,10 +210,10 @@ After @ are array references.
(#\Null "'\\0'")
(t (format nil "'~a'" char))))
(defun dash-to-intercap (symbol)
(defun dash-to-intercap (symbol)
(with-output-to-string (s)
(loop with up = nil
for char across (symbol-name symbol)
for char across (string-invert (symbol-name symbol))
when (char= char #\-) do (setf up t)
else do
(write-char (if up (char-upcase char) char) s)
......@@ -501,6 +523,10 @@ statements such as blocks to *not* emit a semicolon."
(define-javascript-special-operator throw :statement (processor expr)
"throw " (expression expr) ";")
(process-js '(try 1 2 3 4
(catch blah joo ha su)
(finally suma boo)))
;; Try
(define-javascript-special-operator try :statement (processor &rest body)
(flet ((key (e) (if (consp e) (first e))))
......@@ -531,6 +557,35 @@ statements such as blocks to *not* emit a semicolon."
(loop for stmt in (rest finally-clause) do (out (statement stmt) :freshline))
:unindent :freshline "}"))))))
(defspecial-js try :statement (&rest body)
(flet ((key (e) (if (consp e) (first e))))
(let ((catch-clause (find 'catch body :key #'key))
(finally-clause (find 'finally body :key #'key)))
(when catch-clause
(assert
(let ((next (cdr (member catch-clause body))))
(or (null next) (eql (car next) finally-clause)))))
(when finally-clause
(assert (null (cdr (member finally-clause body)))))
(setf body (ldiff body (or (member catch-clause body)
(member finally-clause body))))
(out
"try {" :%
(:idn (:lst body :infix :% (out (statement stmt))))
:% "}"
(when catch-clause
(destructuring-bind (var &rest body) (rest catch-clause)
(out
" catch (" (name var) ") {" :%
(:idn (:lst body :infix :& (out (statement stmt))))
:& "}")))
(when finally-clause
(out
" finally {" :%
(:idn (lst (rest finally-clause) :infix :& (out (statement stmt))))
:& "}"))))))
;; Function -- two kinds, named and anonymous. The former is a
;; statement; the latter an expression.
(define-javascript-special-operator function :statement (processor &rest body &environment env)
......@@ -561,50 +616,8 @@ statements such as blocks to *not* emit a semicolon."
(generate-from-string *lispscript* "(@ (.foo bar))")
(generate-from-string *lispscript* "(.foo bar (.baz maz jo jo))")
(generate-from-string *lispscript* "(@ (.foo bar) baz)")
(generate-from-string *lispscript* "((foo ~ 1 2 3) baz ~ 4 5 6 @ 7 8 9 )")
(generate-from-string *lispscript* "(set (a b c) (+ 1 2 (* (foo @ 4 5) (foo baz @ 3))))")
(generate-from-string *lispscript* "(defvar bah (function (foo) (blah)))")
(generate-from-string *javascript* "(FUNCTION b (a) a b)")
(defmethod process-sexp ((language javascript) processor form environment)
(if (consp form)
(destructuring-bind (name &rest arguments) form
(if (method-name name)
(process-method-call language processor environment
(method-name name)
(first arguments)
(rest arguments))
(process-function-call language processor environment
name
arguments)))
(process-javascript-scalar processor form))
(maybe-semicolon processor environment))
(defun process-function-call (language processor environment name arguments)
(let ((function-expression-statement-p
(and (consp name) (eql (car name) 'function) (eql (statement-or-expression environment) :statement))))
(when function-expression-statement-p (raw-string processor "("))
(process language processor name (new-env 'statement-or-expression :expression environment))
(when function-expression-statement-p (raw-string processor ")"))
(raw-string processor "(")
(loop for (arg . rest) on arguments do
(process language processor arg (new-env 'statement-or-expression :expression environment))
when rest do (raw-string processor ", "))
(raw-string processor ")")))
(process *javascript* (get-pretty-printer) '(function (b c) d) (top-level-environment *javascript*))
(get 'function 'javascript-special-operator)
(symbol-plist 'function)
(defmacro process-js (js-form)
`(process *javascript* (get-pretty-printer) ,js-form (top-level-environment *javascript*)))
(with-open-file (out #p"/home/howard/wisp/cl-user-symbols" :direction :output :if-exists :supersede)
(do-symbols (sym (find-package :cl-user))
(print sym out)))
(sleep 3)
(process-js '(function (b c) d f g))
;;
;; Copyright (c) 2005, Gigamonkeys Consulting All rights reserved.
;;
(in-package :com.gigamonkeys.foo.language)
;;; Hmmmm. Might be useful to support symbol macros.
(defclass language ()
((special-operator-symbol
:initarg :special-operator-symbol
:accessor special-operator-symbol)
(macro-symbol
:initarg :macro-symbol
:accessor macro-symbol)
(input-readtable
:initarg :input-readtable
:accessor input-readtable)
(input-package
:initarg :input-package
:accessor input-package)
(output-file-type
:initarg :output-file-type
:accessor output-file-type)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Primary interface
(defgeneric special-operator-symbol (language)
(:documentation "Return the symbol added to a symbol's plist to
indicate it is the name of a special operator in LANGUAGE."))
(defgeneric macro-symbol (language)
(:documentation "Return the symbol added to a symbol's plist to
indicate it has been defined as a macro in LANGUAGE."))
(defgeneric identifier (language form)
(:documentation "Extract a symbol that identifies the form."))
(defgeneric sexp-form-p (language form)
(:documentation "Is the given form a meaningful non-special,
non-macro form in language."))
(defgeneric embeddable-value-form (language form)
(:documentation "Return a form that will evaluate to a string
that can be embedded in the generated output."))
(defgeneric process-sexp (language processor form environment)
(:documentation "The basic evaluation rule for the language,
after special operators and macro forms have been handled."))
;;; Secondary interface -- these are typically implemented in terms of
;;; the primary interface.
(defgeneric special-form-p (language form)
(:documentation "Is the given form a special form in language."))
(defgeneric macro-form-p (language form)
(:documentation "Is the given form a macro form in language."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File compiler interface
(defgeneric comment (language text)
(:documentation "Return text as a comment."))
(defgeneric input-readtable (language)
(:documentation "The readtable we should use to read the input file."))
(defgeneric input-package (language)
(:documentation "The package we should use to read the input file."))
(defgeneric top-level-environment (language)
(:documentation "Environment for evaluating top-level forms."))
(defgeneric output-file-type (language)
(:documentation "File suffix for generated files."))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Null implementation of processor interface -- this is used for
;;; walking fors without generating any output.
(defmethod raw-string ((pp (eql nil)) string &optional newlines-p)
(declare (ignore string newlines-p)))
(defmethod newline ((pp (eql nil))))
(defmethod freshline ((pp (eql nil))))
(defmethod indent ((pp (eql nil))))
(defmethod unindent ((pp (eql nil))))
(defmethod toggle-indenting ((pp (eql nil))))
(defmethod embed-value ((pp (eql nil)) value)
(declare (ignore value)))
(defmethod embed-code ((pp (eql nil)) code)
(declare (ignore code)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Language engine.
(defun process (language processor form environment)
"Process FORM as an expression in LANGUAGE. The ENVIRONMENT is
provided to special forms and to the basic evaluation rule
implemented by a method on PROCESS-SEXP."
(cond
((special-form-p language form) (process-special-form language processor form environment))
((macro-form-p language form) (process language processor (expand-macro-form language form environment) environment))
((sexp-form-p language form) (process-sexp language processor form environment))
((consp form) (embed-code processor form))
(t (embed-value processor (embeddable-value-form language form)))))
(defgeneric process-special-form (language processor form environment))
(defgeneric expand-macro-form (language form environment))
(defmethod process-special-form (language processor form environment)
(let ((special-operator (get (identifier language form) (special-operator-symbol language))))
(funcall special-operator processor form environment)))
#+(or)(defmethod expand-macro-form :before ((language t) form environment)
(format t "Expanding~&~s~%in environment ~s~%" form environment))
(defmethod expand-macro-form (language form environment)
(let ((macro-function (get (identifier language form) (macro-symbol language))))
(funcall macro-function form environment)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Default methods.
(defmethod identifier ((language t) (form cons))
"Reasonable default for languages with a Lispy syntax."
(and (symbolp (car form)) (car form)))
(defmethod identifier ((language t) (form t))
(error "Malformed expression for ~a: ~s" language form))
(defmethod special-form-p ((language t) (form t)) nil)
(defmethod special-form-p ((language t) (form cons))
(print form)
(let ((identifier (identifier language form)))
(print identifier)
(and identifier
(get identifier (special-operator-symbol language)))))
(defmethod macro-form-p ((language t) (form t)) nil)
(defmethod macro-form-p ((language t) (form cons))
(let ((identifier (identifier language form)))
(and identifier
(get identifier (macro-symbol language)))))
(defmethod sexp-form-p ((language t) form)
"Suitable default for languages in which all forms that are not
special or macros have some meaning. Languages that allow
embedded code and embedded values will need their own
specialization of this method."
(declare (ignore form))
t)
(defmethod embeddable-value-form ((language t) form)
"Reasonable default. Languages that need to escape certain
characters will need their own specializations of this method."
`(princ-to-string ,form))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Macros -- typically specific languages will provide their own
;;; definitional macros that will expand into these two macros.
(defmacro define-special-operator (name special-operator-symbol (processor &rest other-parameters) &body body)
(with-gensyms (whole)
(multiple-value-bind (parameters environment) (parse-&environment other-parameters)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name ',special-operator-symbol)
(lambda (,processor ,whole ,environment)
(declare (ignorable ,environment))
(handler-case
(destructuring-bind (,@parameters) (rest ,whole)
,@body)
(error (e)
(error 'foo-syntax-error :form ,whole :cause e)))))))))
(define-condition foo-syntax-error ()
((form :initarg :form :accessor form-of)
(cause :initarg :cause :accessor cause-of :initform nil)))
(defmethod print-object ((c foo-syntax-error) stream)
(print-unreadable-object (c stream)
(format stream "in form: ~s; caused by: ~a" (form-of c) (cause-of c))))
(defmacro define-macro (name macro-symbol (&rest parameters) &body body)
(with-gensyms (whole namevar)
(multiple-value-bind (parameters environment) (parse-&environment parameters)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (get ',name ',macro-symbol)
(lambda (,whole ,environment)
(handler-case
(destructuring-bind (,@(normalize-macro-lambda-list parameters namevar)) ,whole
(declare (ignore ,namevar))
(declare (ignorable ,environment))
,@body)
(error (e)
(error 'foo-syntax-error :form ,whole :cause e)))))))))
;; (parse-&environment '(&body body env boo hoo))
(defun parse-&environment (parameters)
"Parse out an optional &environment parameter and return the
parameter list without it and the name of the parameter."
(let ((cons (member '&environment parameters)))
(if cons
(values
;; why include cddr cons? shouldn't environment be at the last position?
;; ;; Ohhh, the spec says that the enviornment can appear once, but anywhere in the list.
(nconc (ldiff parameters cons) (cddr cons))
(cadr cons))
;; why uninterned symbol?
;; ;; we have to put something in the lambda-list. This is just a filler, and uninterned to
;; ;; make explicit that it can't be referenced anywhere.
(values parameters (make-symbol (symbol-name '&environment))))))
(defun normalize-macro-lambda-list (parameters namevar)
"Create a destructuring-lambda list that can parse a whole
macro form, including an aptional &whole parameter and a
parameter to eat up the macro name."
(let* ((back (if (eql (car parameters) '&whole) (cddr parameters) parameters))
(front (ldiff parameters back)))
`(,@front ,namevar ,@back)))
(defun self-evaluating-p (form)
(and (atom form) (if (symbolp form) (keywordp form) t)))
(defun sexp->ops (language body environment)
(loop with compiler = (make-instance 'text-compiler)
for form in body do (process language compiler form environment)
finally (return (ops compiler))))
(defun emit (language body environment)
(process language (get-pretty-printer) body environment))
(defun compile-special-op-body (processor body)
"Code generator generator."
(loop for thing in body collect
(etypecase thing
(string `(raw-string ,processor ,thing ,(not (not (find #\Newline thing)))))
(cons thing)
(keyword
(ecase thing
(:newline `(newline ,processor))
(:freshline `(freshline ,processor))
(:indent `(indent ,processor))
(:unindent `(unindent ,processor)))))))
\ No newline at end of file
......@@ -42,6 +42,8 @@
;; (fmt nil)
;; (values)) => "1nil"
(in-package :wisp.util)
;;; rkr lambda-list
......@@ -174,6 +176,7 @@
(pprint-logical-block (*fmt-stream* nil) ,body)))
(t `(pprint-logical-block (,> nil) ,body)))))
(defmacro fmt* (&rest fnlist)
`(fmt ,@(append '(:nil-option :none) fnlist)))
......@@ -246,7 +249,8 @@
(defmt-op :if (test true false)
`(if ,test ,true ,false))
(defmt-op :lst (var-form &key infix &rest rest)
(defmt-op :lst (var-form &key infix &rest rest)
;; not really happy with the name, but can't think of anything better yet.
(let ((args (gensym "REST"))
(arg (car var-form)))
`(loop for (,arg . ,args) = ,(cadr var-form) then ,args
......@@ -269,10 +273,14 @@
(fmt (:_))))
(defmt-op :tab ()
`(pprint-tab :line-relative 5 1 *fmt-stream*))
;; at least print a space to prevent nasty suprises
`(progn (pprint-tab :line-relative 5 1 *fmt-stream*)
(unless *print-pretty* (princ " " *fmt-stream*))))
(defmt-op :_ ()
`(pprint-newline :mandatory *fmt-stream*))
;; at least print a space to prevent nasty suprises
`(progn (pprint-newline :mandatory *fmt-stream*)
(unless *print-pretty* (princ " " *fmt-stream*))))
......
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