[sketch] tools to write transpilers from sexpr to Blub languages. For when you are in the direst situation.

universal-lisp-transpiler.lisp

;;[sketch] tools to write transpilers from sexpr to Blub languages. 
;;For when you are in the direst situation.
;; copyleft Minori Yamashita

(defpackage :ult
  (:use :cl))
(in-package :ult)

(defpackage :ult-symspace)

(setf (readtable-case *readtable*) :invert)

(defparameter *infix-ops* (mapcar #'symbol-name '(+ - * / % = == !=)))

;; Base system

(defmacro defform (name params &rest body)
  `(defmacro ,(intern (symbol-name name) 'ult-symspace)
       ,params
     ,@body))

(defgeneric transpile (ast)
  (:documentation "list to code"))

(defmethod transpile :around (ast)
  (let ((expr (call-next-method)))
    (if (listp expr)
	(apply #'format (cons nil expr))
	expr)))

;;utils

(defun joinstrs (separator xs &optional (acc ""))
  (cond ((null xs) "")
	((null (cdr xs))
	 (concatenate 'string acc (string (car xs))))
	(t (joinstrs separator (cdr xs)
		     (concatenate 'string acc (string (car xs)) separator)))))

(defun paren (open close expr)
  (assert (stringp expr))
  (concatenate 'string open expr close))

(defun sym->tok (sym)
  (let ((sname (symbol-name sym)))
    (if (loop :for x across sname
	   :always (upper-case-p x))
	(string-downcase sname)
	sname)))

(defun purify (expr)
  (cond ((symbolp expr)
	 (sym->tok expr))
	((stringp expr)
	 expr)
	(t (warn "inpure "))))

(defun pair->typed-tok (spec)
  (joinstrs " " (mapcar #'sym->tok spec)))

(defun insert-return (body-strs &optional (name-spec ()))
    (concatenate
     'list (butlast body-strs)
     (list (concatenate
	    'string
	    (if (member 'void name-spec) "" "return ")
	    (car (last body-strs)) ";"))))



;; Example: Transpiler for Csharp. INCOMPLETE

(defmethod transpile ((num number))
  (format nil "~A" (float num)))

(defmethod transpile ((str string))
  (format nil "'~A'" str))

(defmethod transpile ((sym symbol))
  (intern (symbol-name sym) 'ult-symspace))

(defun transpile-funcall (operator expr)
  (let ((operands (mapcar #'purify (mapcar #'transpile (cdr expr)))))
    (if (member (symbol-name operator) *infix-ops*
		:test #'string=)
	(paren "(" ")" (joinstrs (sym->tok operator) operands))
	(concatenate
	 'string  (sym->tok operator)
	 (paren "(" ")" (joinstrs ", " operands))))))


;; Core
(defmethod transpile ((expr list))
  (let ((operator (transpile (car expr))))
	(cond ((not (symbolp operator))
	       (warn "Not implemented"))
	      ((macro-function operator)
	       (macroexpand (cons operator (cdr expr))))
	      (t (transpile-funcall operator expr)))))


;;forms

(defform if (pred then else)
  (list "if (~A) { ~A } else { ~A }"
	(transpile pred)
	(transpile then)
	(transpile else)))

(defform def (name val)
  (list "~A = ~A" name
	(transpile val)))

(defform defun (name-spec params &rest body)
  (let* ((body-strs (mapcar #'transpile body))
	 (body-strs (insert-return body-strs name-spec)))
    (list "~A ~A { ~A }"
	  (pair->typed-tok name-spec)
	  (paren "(" ")" (joinstrs "," (mapcar #'pair->typed-tok params)))
	  (joinstrs "; " body-strs))))

(defform lam (params &rest exprs)
  (list "(~A) => { ~A }"
	(joinstrs "," (mapcar #'sym->tok params))
	(joinstrs "; " (insert-return (mapcar #'transpile exprs)))))


;;example blub level macro

(defform defpublic (name-spec params &rest body)
  `(ult-symspace::defun ,(cons 'public name-spec)
       ,params
     ,@body))


;; example transpilation
(transpile '(defpublic (bool isEmpty) () (objects.All (lam (o) (== o null)))))
;;=> "public bool isEmpty () { return objects.All((o) => { (return (o==null);) }); }"