;;; claw.lisp -- a compiler from Core Erlang to Common Lisp
;;;;
;;; This file defines a compiler from Core Erlang to Common Lisp. Core
;;; Erlang is a simple "kernel language" used by the Erlang compiler.

(defpackage :claw
  (:use :common-lisp :split-sequence)
  (:export :test :file
           ;;; The language
           #:call #:match-case #:match-clause #:receive
           #:tuple #:tuplep #:tuple-size #:tuple-elements #:atom? #:binary
           #:erlang-atom #:ref #:port #:pid
           #:defbif)
  (:documentation "Main package for the CLAW compiler."))

(in-package :claw)

;;;; Runtime system
;;;
;;; The core runtime system is pretty thin. This is partly because we
;;; don't implement concurrency here and partly because many Erlang
;;; datatypes map directly onto Lisp ones (e.g. lists and functions).
;;; Atoms are represented as Lisp symbols in the ATOM package, and
;;; variables in compiled code are named by symbols in the VAR
;;; package. We sprinkle some syntactic sugar on atoms and variables
;;; to make compiled code more readable (see below).

(defpackage :var
  (:use)
  (:documentation "Symbols in this package are Erlang variables."))

(defpackage :atom
  (:use)
  (:documentation "Symbols in this package are Erlang atoms."))

(defun get-variable (name)
  "Return the variable called NAME."
  (intern name :var))

(defun get-atom (name)
  "Return the atom called NAME."
  (let ((symbol (intern name :atom)))
    (unless (boundp symbol)
      (eval `(defconstant ,symbol ',symbol)))
    symbol))

(deftype erlang-atom     () '(satisfies atom?))
(deftype erlang-variable () '(satisfies variable?))
(deftype ref             () 'null)
(deftype port            () 'null)
(deftype pid             () 'null)
(deftype binary          () 'vector)

(deftype erlang-term ()
  '(or integer float erlang-atom erlang-variable ref port pid binary))

(defun variable? (x)
  (and (symbolp x)
       (equal (symbol-package x) (find-package :var))))

(defun atom? (x)
  (and (symbolp x)
       (equal (symbol-package x) (find-package :atom))))

(defstruct (tuple (:print-function print-tuple)
                  (:predicate tuplep))
  elements)

(defun tuple (&rest elements)
  (make-tuple :elements (coerce elements 'vector)))

(defmethod make-load-form ((s tuple) &optional env)
  (make-load-form-saving-slots s :environment env))

(defun tuple-size (tuple)
  (length (tuple-elements tuple)))

;;;; Scanner

(clex:deflexer core
    ((sign (or "+" "-"))
     (digit (range "0" "9"))
     (uppercase (or (range "A" "Z")
                    (range #.(code-char #xC0) #.(code-char #xD6))
                    (range #.(code-char #xD8) #.(code-char #xDE))))
     (lowercase (or (range "a" "z")
                    (range #.(code-char #xDF) #.(code-char #xF6))
                    (range #.(code-char #xF8) #.(code-char #xFF))))
     ;; input-char is [^\r\n], not convenient to specify in clex
     (input-char (or (range #\null #.(code-char (1- (char-code #\linefeed))))
                     #.(code-char (1+ (char-code #\linefeed)))
                     (range #.(code-char (1+ (char-code #\newline)))
                            #.(code-char #xFF))))
     (control (range #\null #.(code-char #x1F)))
     (space   #x20)
     (namechar (or uppercase lowercase digit "@_<>+-*=:/^!"))
     (varchar  (or uppercase lowercase digit "_"))
     (escape (and "\\" (or octal
                           (and "^" ctrlchar)
                           escapechar)))
     (octaldigit (range "0" "7"))
     (octal (and octaldigit (? octaldigit (? octaldigit))))
     (ctrlchar (range #.(code-char #x40) #.(code-char #x5F)))
     (ecapechar (or "bdefnrstv\"'\\")))
  ;; integer
  ((and (? sign) (+ digit))
   (return (list :integer (parse-integer clex:bag))))
  ;; char
  ((and "$" namechar)
   (list :char (char-code (elt clex:bag 1))))
  ;; float
  ((and (? sign) (+ digit) "." (+ digit)
        (? (or "E" "e") (? sign) (+ digit)))
   ;; FIXME: parse
   (return (list :float clex:bag)))
  ;; atom
  ((and "'" (* namechar) "'")
   (return (list :atom (subseq clex:bag 1 (1- (length clex:bag))))))
  ;; string
  ((and #\" (* namechar) #\")
   (return (list :string (subseq clex:bag 1 (1- (length clex:bag))))))
  ;; variable
  ((and (or uppercase (and "_" varchar))
        (* varchar))
   (return (list :variable clex:bag)))
  ((and "->")
   (return :arrow))
  ((and "-|")
   (return :annotation))
  ((and "#<")
   (return :bin<))
  ((and "#>")
   (return :>bin))
  ((or "{}[]()=,|/<>/:")
   (return (char clex:bag 0)))
  ;; keywords
  ((or (and "after")
       (and "apply")
       (and "attributes")
       (and "call")
       (and "case")
       (and "catch")
       (and "do")
       (and "end")
       (and "fun")
       (and "in")
       (and "let")
       (and "letrec")
       (and "module")
       (and "of")
       (and "primop")
       (and "receive")
       (and "try")
       (and "when"))
   (return (intern (string-upcase clex:bag) :keyword)))
  ;; skip whitespace
  ((or #\space #\tab #\newline #\return)))

(defun core-tokens (stream)
  (let ((lexer (make-core-lexer stream)))
    (loop for token = (funcall lexer)
          collect token
          until (eq token :eof))))

(defun scan-file (filename)
  (with-open-file (stream filename :direction :input)
    (core-tokens stream)))


;;;; Parser

(defmacro defparser (name terminals &body grammar)
  "Translate from this syntax:
  (CATEGORY {-> {TOKEN}* [=> EXPR]}*
to
  {(CATEGORY --> {TOKEN}* (action EXPR))}*

If you catch my drift.."
  ;; Check the grammar.
  (let* ((categories
          (union '(nil -> => %1 %2 %3 %4 %5 %6 %7 %8 %9 %10)
                 (mapcar #'car grammar)))
         (dodgy (remove-if-not (lambda (x)
                                 (and (symbolp x)
                                      (not (member x categories))
                                      (not (keywordp x))))
                               (apply #'append grammar))))
    (when dodgy
      (warn "~&No productions for ~S~%" (remove-duplicates dodgy))))
  (flet ((translate-rule (r)
           (let* ((category (pop r))
                  (productions (split-sequence '-> (rest r))))
             (mapcar (lambda (p)
                       (if (member '=> p)
                           `(,category --> ,@(subseq p 0 (- (length p) 2))
                             (action ,(first (last p))))
                           `(,category --> ,@p #'identity)))
                     productions))))
    `(lalr:define-grammar ,name ,terminals
      ,@(loop for production in grammar
              appending (translate-rule production)))))

(defmacro action (&rest body)
  (let ((args (gensym)))
    `#'(lambda (&rest ,args)
         (declare (ignorable ,args))
         (symbol-macrolet ((%1 (nth 0 ,args))
                           (%2 (nth 1 ,args))
                           (%3 (nth 2 ,args))
                           (%4 (nth 3 ,args))
                           (%5 (nth 4 ,args))
                           (%6 (nth 5 ,args))
                           (%7 (nth 6 ,args))
                           (%8 (nth 7 ,args))
                           (%9 (nth 8 ,args))
                           (%10 (nth 9 ,args)))
             ,@body))))

(defvar *just-parse* nil
  "When non-nil, create a regular parse tree instead of a program.")

(declaim (optimize (compilation-speed 3) (space 3) (speed 0)))

(defparser core-parser
    (:arrow :annotation :atom :string :variable :float :integer :char
            :after :apply :attributes :call :case :catch :do
            :end :fun :in :let :letrec :module :of :primop
            :receive :try :when :bin< :>bin
            #\{ #\} #\[ #\] #\( #\) #\= #\, #\| #\/ #\< #\> #\/ #\:)
  (module-definition -> :module :atom module-export module-attribute module-defs :end
                     => (comp-module %2 %3 %4 %5))

  (module-export -> #\[ #\]                => (comp-module-export '())
                 -> #\[ exported-names #\] => (comp-module-export %2))

  (exported-names -> exported-name #\, exported-names => (cons %1 %3)
                  -> exported-name                    => (list %1))

  (exported-name -> function-name => %1)

  (module-attribute -> :attributes #\[ #\]                =>
                    (comp-module-attribute '())
                    -> :attributes #\[ attribute-list #\] =>
                    (comp-module-attribute %3))

  (attribute-list -> attribute #\, attribute-list => (cons %1 %3)
                  -> attribute                    => (list %1))
  
  (attribute -> :atom #\= literal => (list %1 %3))

  (module-defs -> function-definitions)

  (annotation -> #\[ #\] => '())
  (annotation -> #\[ constants #\] => %2)

  (function-definitions -> function-definition function-definitions => (cons %1 %2)
                        ;; FIXME: Should allow zero-length
                        -> function-definition => (list %1))

  (function-definition -> anno-function-name #\= anno-fun => (comp-fdef %1 %3))

  ;; Ignore annotations.
  (anno-fun -> #\( fun-expr :annotation annotation #\) => %2
            -> fun-expr => %1)

  (constant -> atomic-constant => %1
            -> tuple-constant  => %1
            -> cons-constant   => %1)

  (constants -> constant #\, constants => (cons %1 %3)
             -> constant => (list %1))

  (atomic-constant -> :char    => %1
                   -> :integer => %1
                   -> :float   => %1
                   -> atom     => %1
                   -> :string  => (comp-string %1)
                   -> null     => '())

  (tuple-constant -> #\{ #\} => (comp-tuple '())
                  -> #\{ constants #\} => (comp-tuple %2))

  (cons-constant -> #\[ constant tail-constant => (cons %2 %3))

  (tail-constant -> #\]                        => '()
                 -> #\| constant #\]           => %2
                 -> #\, constant tail-constant => (cons %2 %3))

  (anno-pattern -> #\( other-pattern :annotation annotation => %2
                -> other-pattern => %1
                -> anno-variable => %1)

  (anno-patterns -> anno-pattern #\, anno-patterns => (cons %1 %3)
                 -> anno-pattern => (list %1))

  (pattern -> variable => %1
           -> other-pattern => %1)

  (other-pattern -> atomic-pattern => %1
                 -> tuple-pattern  => %1
                 -> cons-pattern   => %1
                 -> binary-pattern => %1
                 -> anno-variable #\= anno-pattern => (comp-alias %1 %3))

  (atomic-pattern -> atomic-literal => %1)

  (tuple-pattern -> #\{ #\} => (comp-tuple-pattern '())
                 -> #\{ anno-patterns #\} => (comp-tuple-pattern %2))

  (cons-pattern -> #\[ anno-pattern tail-pattern => (cons %2 %3))

  (tail-pattern -> #\] => '()
                -> #\| anno-pattern #\]          => %2
                -> #\, anno-pattern tail-pattern => (cons %2 %3))

  (binary-pattern -> :bin< :>bin => (comp-binary '())
                  -> :bin< segment-patterns :>bin => (comp-binary %2))

  (segment-patterns -> segment-pattern #\, segment-patterns => (cons %1 %3)
                    -> segment-pattern => (list %1))

  (segment-pattern -> pattern #\: seg-size-pattern #\: seg-type seg-flags
                   => (destructuring-bind (size unit) %3
                        (comp-segment-pattern %1 size unit %5 %6)))

  (seg-size-pattern -> pattern :* :integer => (comp-seg-size-pattern %1 %3)
                    -> pattern => (comp-seg-size-pattern %1 1))

  (variable -> :variable => (comp-variable %1))

  (anno-variables -> anno-variable #\, anno-variables => (cons %1 %3)
                  -> anno-variable => (list %1))

  (anno-variable -> variable => %1
                 -> #\( variable :annotation annotation #\) => %2)

  (anno-expression -> expression => %1
                   -> #\( expression :annotation annotation #\) => %2)

  (anno-expressions -> anno-expression #\, anno-expressions => (cons %1 %3)
                    -> anno-expression => (list %1))

  (expression -> #\< #\> => (comp-values '())
              -> #\< anno-expressions #\> => (comp-values %2)
              -> single-expression => %1)

  (single-expression -> atomic-literal => %1
                     -> tuple => %1
                     -> cons => %1
                     -> binary => %1
                     -> variable => %1
                     ;; NB: we introduce function-ref in place for
                     ;; function-name for expressions.
                     -> function-ref => %1
                     -> fun-expr => %1
                     -> let-expr => %1
                     -> letrec-expr => %1
                     -> case-expr => %1
                     -> receive-expr => %1
                     -> application-expr => %1
                     -> call-expr => %1
                     -> primop-expr => %1
                     -> try-expr => %1
                     -> sequence => %1
                     -> catch-expr => %1)

  (literal -> atomic-literal => %1
           -> tuple-literal => %1
           -> cons-literal => %1)

  (literals -> literal #\, literals => (cons %1 %3)
            -> literal => (list %1))

  (atomic-literal -> :char    => %1
                  -> :integer => %1
                  -> :float   => %1
                  -> atom     => %1
                  -> :string  => (comp-string %1)
                  -> null     => nil)

  (null -> #\[ #\] => '())

  (tuple-literal -> #\{ #\} => (comp-tuple-literal '())
                 -> #\{ literals #\} => (comp-tuple-literal %2))

  (cons-literal -> #\[ literal tail-literal => (cons %2 %3))

  (tail-literal -> #\] => '()
                -> #\| literal #\] => %2
                -> #\, literal tail-literal => (cons %2 %3))

  (tuple -> #\{ #\} -> (comp-tuple '())
         -> #\{ anno-expressions #\} => (comp-tuple %2))

  (cons -> #\[ anno-expression tail => (comp-cons %2 %3))

  (tail -> #\] => '()
        -> #\| anno-expression #\]  => %2
        -> #\, anno-expression tail => (comp-cons %2 %3))

  (binary -> :bin< :>bin          => (comp-binary '())
          -> :bin< segments :>bin> => (comp-binary %2))

  (segments -> segment #\, segments => (cons %1 %3)
            -> segment => %1)

  (segment -> single-expression #\: seg-size-unit #\: seg-type seg-flags
           => (destructuring-bind (size unit) %3
                (comp-segment %1 size unit %5 %6)))

  (seg-size-unit -> single-expression :* :integer => (comp-seg-size %1 %3)
                 -> single-expression             => (comp-seg-size %1 1))

  (seg-type -> :atom => %1)

  (atom -> :atom => (comp-atom %1))

  (seg-flags -> :- :atom seg-flags => (cons %2 %3)
             -> :atom => '())                 ; FIXME: epsilon?

  (function-name -> :atom #\/ :integer => (comp-fname %1 %3))
  (function-ref -> :atom #\/ :integer  => (comp-fref %1 %3))

  (anno-function-name -> function-name => %1
                      -> #\( function-name :annotation annotation #\) => %2)

  (let-vars -> anno-variable => (list %1)
            -> #\< #\> => '()
            -> #\< anno-variables #\> => %2)

  (sequence -> :do anno-expression anno-expression => (comp-seq %2 %3))

  (fun-expr -> :fun #\( #\) :arrow anno-expression => (comp-fun '() %5)
            -> :fun #\( anno-variables #\) :arrow anno-expression =>
            (comp-fun %3 %6))

  (let-expr -> :let let-vars #\= anno-expression :in anno-expression =>
            (comp-let %2 %4 %6))

  (letrec-expr -> :letrec letrec-definitions :in anno-expression
               => (comp-letrec %2 %4))

  ;; This is added for CLAW. The original just uses function-definitions.
  (letrec-definitions -> letrec-definition letrec-definitions =>
                      (cons %1 %2)
                      -> letrec-definition => (list %1))

  (letrec-definition -> anno-function-name #\= anno-fun =>
                     (comp-letrec-def %1 %3))

  (case-expr -> :case anno-expression :of anno-clauses :end
             => (comp-case %2 %4))

  (anno-clauses -> anno-clause anno-clauses => (cons %1 %2)
                -> anno-clause => (list %1))

  (anno-clause -> clause => %1
               -> #\( clause :annotation annotation #\) => %2)

  (clause -> clause-pattern :when anno-expression :arrow anno-expression =>
          (comp-clause %1 %3 %5))

  (clause-pattern -> anno-pattern          => (list %1)
                  -> #\< #\>               => '()
                  -> #\< anno-patterns #\> => %2)
          
  (application-expr -> :apply anno-expression arg-list =>
                    (comp-apply %2 %3))

  (call-expr -> :call anno-expression #\: anno-expression arg-list =>
             (comp-call %2 %4 %5))

  (primop-expr -> :primop :atom arg-list => (comp-primop %2 %3))

  (arg-list -> #\( #\)                  => '()
            -> #\( anno-expressions #\) => %2)

  (try-expr ->
            :try anno-expression :of let-vars :arrow anno-expression
            :catch let-vars :arrow anno-expression
            => (comp-try %2 %4 %6 %8 %10))

  (catch-expr -> :catch anno-expression => (comp-catch %2))

  (receive-expr -> :receive timeout =>
                (destructuring-bind (time action) %2
                  (comp-receive '() time action))
                -> :receive anno-clauses timeout =>
                (destructuring-bind (time action) %3
                  (comp-receive %2 time action)))

  (timeout -> :after anno-expression :arrow anno-expression => (list %2 %4)))

;; Driver

(defun core-compile (module-name input)
  (ignore-errors (delete-package module-name))
  (let* ((*module-package* (make-package module-name))
         (*package* *module-package*)
         (lexer (make-core-lexer input)))
    (use-package '(:claw))
    (flet ((next-input ()
             (let ((x (funcall lexer)))
               (cond ((eq x :eof) (values :eof :eof))
                     ((atom x) (values x x))
                     (t (values (first x) (second x))))))
           (parse-error ()
             (error "Parse-Error! at pos = ~D"
                    (file-position input))))
      (core-parser #'next-input #'parse-error))))

(defun test ()
  (with-open-file (s "fact.core" :direction :input)
    (claw::core-compile "fact" s)))

(defun file (name)
  (let ((infile  (concatenate 'string name ".core"))
        (outfile (concatenate 'string name ".cl"))
        module)
    (with-open-file (s infile :direction :input)
      (setq module (core-compile name s)))
    (format t "Converted to Lisp..~%")
    (with-open-file (out outfile :direction :output
                         :if-exists :supersede
                         :if-does-not-exist :create)
      (let ((*print-case* :downcase)
            (*package* (find-package name)))
        (mapc (lambda (form)
                (format out "~s~%" form)
                (terpri out))
              (cdr module))))
    (format t "Wrote ~s, compiling..~%" outfile)
    #+nil
    (let ((*readtable* *claw-readtable*))
      (apply #'compile-file outfile compile-keywords))))

;;;; Compiler

(defvar *module-package* nil
  "Bound to the package of the module being compiled.")

;; Code generators

(defun comp-module (name exports attributes defs)
  `(progn
    (defpackage ,name
      (:use :claw :common-lisp)
      (:export ,@(mapcar #'symbol-name exports)))
    (in-package ,name)
    (defvar ,(intern "*attributes*" (find-package name)) ',attributes)
    ,@defs
    ,name))

(defun comp-module-export (fnames) fnames)
(defun comp-module-attribute (attrs) attrs)

(defun comp-values (values)
  `(values ,@values))

(defun comp-tuple (elems)
  `(tuple ,@elems))

(defun comp-tuple-pattern (elems)
  (apply #'tuple elems))

(defun comp-let (vars vexp exp)
  (if (= (length vars) 1)
      `(let ((,(car vars) ,vexp)) ,exp)
      `(multiple-value-bind ,vars ,vexp ,exp)))

(defun comp-atom (name)
  (get-atom name))

(defun comp-cons (car cdr)
  (cond ((eq cdr nil)
         `(list ,car))
        ((and (consp cdr)
              (eq (first cdr) 'list))
         `(list ,car ,@(rest cdr)))
        (t
         `(cons ,car ,cdr))))

(defun comp-string (string)
  (list 'quote (coerce string 'list)))

(defun comp-variable (v)
  (get-variable v))

(defun comp-fname (name arity)
  (intern (format nil "~a/~a" name arity) *module-package*))

(defun comp-fref (name arity)
  `(function ,(comp-fname name arity)))

(defun comp-fdef (name fun)
  ;; We pull apart the FUN's lambda expression to create a DEFUN
  (destructuring-bind (lambda args expr) fun
    (declare (ignore lambda))
    `(defun ,name ,args ,expr)))

(defun comp-letrec-def (name fun)
  (destructuring-bind (lambda args expr) fun
    (declare (ignore lambda))
    (list name args expr)))

(defun comp-fun (args body)
  `(lambda ,args ,body))

(defun comp-case (e clauses)
  `(match-case ,e ,@clauses))

(defun comp-clause (patterns guard expr)
  (list* patterns guard (unprogn expr)))

(defun unprogn (x)
  (if (and (consp x)
           (eq (first x) 'progn))
      (rest x)
      (list x)))

(defun comp-alias (variable pattern)
  (list 'alias variable pattern))

(defun comp-apply (fexp args)
  (if (local-function-ref? fexp)
      `(,(cadr fexp) ,@args)
      `(funcall ,fexp ,@args)))

(defun comp-call (module function args)
  `(call ,module ,function ,@args))

(defun comp-seq (e1 e2)
  (if (and (consp e2)
           (eq (car e2) 'progn))
      `(progn ,e1 ,@(cdr e2))
      `(progn ,e1 ,e2)))

(defun comp-letrec (named-funs e)
  `(labels ,named-funs ,e))

(defun comp-local-fdef (name fun)
  (destructuring-bind (lambda args &rest body) fun
    (declare (ignore lambda))
    `(,name ,args ,@body)))

(defun local-function-ref? (x)
  (and (consp x)
       (= (length x) 2)
       (eq (first x) 'function)
       (symbolp (second x))
       (eq (symbol-package (second x)) *module-package*)))

(defun comp-list (x)
  (if (consp x)
      `(cons ,(car x) ,(comp-list (cdr x)))
      x))

(defun comp-catch (expr)
  `(handler-case ,expr (error (e) e)))

(defun comp-try (exp1 v1 exp2 v2 exp3)
  ;; Not properly implemented, since there is no "throw" yet. FIXME.
  exp1)

(defun comp-primop (name args)
  (list* 'primop (get-atom name) args))

;;;; Core^2 Language

(defmacro call (mod fun &rest args)
  (list* 'funcall `(remote-fname ,mod ,fun ,(length args)) args))

(defun remote-fname (module function arity)
  (let ((package (find-package (symbol-name module))))
    (or (and package
             (find-symbol (format nil "~A/~D" (symbol-name function) arity)
                          package))
        (error "Undefined function: ~A:~A/~A" module function arity))))

(defvar *it* nil
  "Bound during pattern matching to the (sub)term being considered.")

(defmacro match-case (e &body clauses)
  "Match the result(s) of an expression against a series of clauses.

  (MATCH-CASE E CLAUSE1 ... CLAUSEn)
  CLAUSE = ((<PATTERN0 ... PATTERNn>) GUARD BODY-EXPR)
  PATTERN = (PATTERN) | #(PATTERN) | atom"
  `(let ((*it* (multiple-value-list ,e)))
    (catch 'result
      ,@(loop for c in clauses
              collect (destructuring-bind (pat guard &rest body) c
                        `(match-clause ,pat ,guard
                                       (throw 'result (progn ,@body)))))
      (error "case-clause"))))

(defmacro match-clause (pattern guard body)
  "If *IT* matches PATTERN and GUARD is true then execute BODY."
  (let ((*variables* '()))
    (labels ((pat (e)
               (cond
                 ((variable? e)
                  (push e *variables*)
                  `(prog1 t (setq ,e *it*)))
                 ((numberp e)
                  `(equalp *it* ,e))
                 ((symbolp e)
                  `(equalp *it* ',e))
                 ((and (consp e)
                       (eq (car e) 'alias))
                  (destructuring-bind (alias v p) e
                    (declare (ignore alias))
                    (push v *variables*)
                    `(when ,(pat p)
                      (setq ,v *it*)
                      t)))
                 ((consp e)
                  `(and (consp *it*)
                    (let ((*it* (car *it*))) ,(pat (car e)))
                    (let ((*it* (cdr *it*))) ,(pat (cdr e)))))
                 ((tuplep e)
                  (let ((elems (tuple-elements e)))
                    `(and (tuplep *it*)
                      (= (length (tuple-elements *it*)) ,(length elems))
                      ,@(loop for exp across elems
                              for i from 0
                              collect
                              `(let ((*it* (elt (tuple-elements *it*) ,i)))
                                ,(pat exp)))))))))
      (let* ((test (pat pattern)))
        `(let ,*variables*
          (when (and ,test (eq ,guard 'atom::|true|))
            ,body))))))

;; (match-clause '(+ 1 2) (var::foo 3 #(1 2 3)) (< x 1) yes no)

;;;; Syntactic sugar

(defvar *claw-readtable* nil
  "Main readtable for claw source files.")

(defvar *claw-symbol-readtable* nil
  "Readtable used for atoms and variables. Case sensitive.")

(defun read-atom (stream char)
  (declare (ignore char))
  (let ((sym (read-symbol-with-package :atom stream t nil t)))
    (if *read-suppress*
        nil
        ;; This makes atoms self-evaluating, like keywords.
        (eval `(load-time-value (defconstant ,sym ',sym))))))

(defun read-variable (stream char)
  (declare (ignore char))
  (read-symbol-with-package :var stream t nil t))

(defun read-symbol-with-package (package-name &rest read-args)
  #+MOVITZ
  (declare (dynamic-extent read-args))
  (let ((*package* (find-package package-name))
        (*readtable* *claw-symbol-readtable*))
    (apply #'read (copy-seq read-args))))

(defun read-tuple (stream char)
  (declare (ignore char))
  (apply #'tuple (read-delimited-list #\} stream)))

(defun print-quoted-atom (stream x)
  (print-atom stream (cadr x)))

(defun print-atom (stream atom)
  (let ((*package* (find-package :atom))
        (*readtable* *claw-symbol-readtable*)
        (*print-pretty* nil))
    (princ "@" stream)
    (prin1 atom stream)))

(defun print-variable (stream var)
  (let ((*package* (find-package :var))
        (*readtable* *claw-symbol-readtable*)
        (*print-pretty* nil))
    (princ "$" stream)
    (prin1 var stream)))

(defun print-tuple (tuple stream depth)
  (declare (ignore depth))
  (format stream "~@<{~{~S~^ ~}}~:>" (coerce (tuple-elements tuple) 'list)))

;; Setup read and print syntax for atoms and variables.
(setq *claw-readtable* (copy-readtable))
(set-macro-character #\@ #'read-atom     t *claw-readtable*)
(set-macro-character #\$ #'read-variable t *claw-readtable*)
(set-macro-character #\{ #'read-tuple    t *claw-readtable*)
(set-syntax-from-char #\} #\))
(set-pprint-dispatch 'erlang-atom #'print-atom)
(set-pprint-dispatch 'erlang-variable #'print-variable)
(setq *claw-symbol-readtable* (copy-readtable))
(setf (readtable-case *claw-symbol-readtable*) :preserve)

(setq *readtable* *claw-readtable*)

(defun pprint-match-case (stream list &rest noise)
  (declare (ignore noise))
  ;; NB: Format strings are a sport, not a readable notation.
  (format stream
          "~:<~W ~3I~:_~S~1I~:_~@{~_~S~}~:>" list))

(set-pprint-dispatch '(cons (eql match-case) cons) #'pprint-match-case)

;;;; Concurrency

(defstruct (process (:conc-name #:proc.))
  pid mailbox links trap-exit)

(defvar *processes* '())

(defvar *pid-counter* 0)

(defvar *process*)

(defmacro appendf (value place)
  `(setf ,place (append ,place (list ,value))))

(defmacro removef (value place)
  `(setf ,place (remove ,value ,place)))

(defmacro aif (test then &optional else)
  `(let ((it ,test))
    (if it ,then ,else)))

(defmacro when-let ((var exp) &body body)
  `(let ((,var ,exp)) (when ,var ,@body)))

(defun spawn (fun)
  (let ((p (make-process :pid (incf *pid-counter*))))
    (push p *processes*)
    (mp:make-process (lambda () (let ((*process* p)) (funcall fun))))
    p))

(defun send (p m)
  (mp:without-scheduling (appendf m (proc.mailbox p))))

;;;; BIFs
;;;
;;; Eval this in Emacs:
;;; (font-lock-add-keywords nil '(("\\<defbif\\>" (0 font-lock-keyword-face))))
(defmacro defbif (name args &body body)
  (let ((fname (intern (format nil "~A/~D" (symbol-name name) (length args))
                      (symbol-package name))))
    `(progn (defun ,fname ,args ,@body)
            (export ',fname))))

(defmacro defpackage* (name &body options)
  "Define package NAME with OPTIONS, unless it already exists.

This is used to avoid the incredibly annoying warnings when manually
exporting symbols. ``Package FOO also exports..''"
  `(eval-when (:compile-toplevel :load-toplevel :execute)
    (unless (find-package ,(symbol-name name))
      (defpackage ,name ,@options))))

(defun primop (op arg)
  (ecase op
    (@match_fail (error "Badmatch: ~S" arg))))

;;;;; erlang

(defpackage* :|erlang|
  (:nicknames :bif)
  (:use :cl :claw)
  (:export "</2" ">/2" "=</2" ">=/2" "+/2" "-/2" "*/2")
  (:documentation "Erlang built-in-functions (BIFs.)"))

(in-package :|erlang|)

(defvar *true*  'atom::|true|)
(defvar *false* 'atom::|false|)

;; wrappers to enforce number of arguments
(defun </2 (x y)
  (true/false (less? x y)))

(defun >/2 (x y)
  (true/false (not (or (equal? x y) (less? x y)))))

(defun =</2 (x y)
  (true/false (or (less? x y) (equal? x y))))

(defun >=/2 (x y)
  (true/false (or (less? y x) (equal? x y))))

(defun +/2 (x y) (cl:+ x y))
(defun -/2 (x y) (cl:- x y))
(defun */2 (x y) (cl:* x y))
(defbif |display| (x) (print x))
(defbif |and| (x y)
  (true/false! x y)
  (true/false (and (true? x) (true? y))))
(defbif |or| (x y)
  (true/false! x y)
  (true/false (or (true? x) (true? y))))
(defun ++/2 (x y)
  (append x y))
(defun --/2 (x y)
  (reduce (lambda (acc e) (remove e acc :test #'equal? :count 1)) y
          :initial-value x))
(defbif |==| (x y)
  (true/false (equal? x y)))
(defbif |=:=| (x y)
  (true/false (equal x y)))

(defbif |is_atom| (x) (atom? x))
(defbif |is_list| (x) (consp x))
(defbif |is_tuple| (x) (tuplep x))
;;(defbif |is_constant| (x) 
(defbif |is_float| (x) (floatp x))
(defbif |is_integer| (x) (integerp x))
(defbif |is_number| (x) (numberp x))
;;(defbif |is_pid| (x) 
;;(defbif |is_port| (x) )
;;(defbif |is_reference| (x) )
;;(defbif |is_binary| (x) )
(defbif |is_function| (x) (functionp x))
;;(defbif |is_record| (x) )

(defun true/false (x) (if x *true* *false*))
(defun true/false! (&rest objs)
  #+MOVITZ
  (declare (dynamic-extent objs))
  (dolist (x objs)
    (unless (or (eq x *true*) (eq x *false*))
      (error "badarg: ~s is not an erlang boolean" x))))
(defun true?  (x) (eq x *true*))
(defun false? (x) (eq x *false*))

(defconstant term-order
  '(number erlang-atom ref port pid tuple null cons binary)
  "Ordering of Erlang types.")

(defun orderval (x)
  (position x term-order :test #'typep))

(defun less? (x y)
  "Is X less than Y by Erlang term ordering rules?"
  (let ((ox (orderval x))
        (oy (orderval y)))
    (cond ((< ox oy) t)
          ((> ox oy) nil)
          (t
           (etypecase x
             (number (< x y))
             (symbol (string< (symbol-name x) (symbol-name y)))
             (tuple  (if (= (tuple-size x) (tuple-size y))
                         (sequence-less? (tuple-elements x) (tuple-elements y))
                         (< (tuple-size x) (tuple-size y))))
             (null   t)
             (cons   (cond ((less? (car x) (car y)) t)
                           ((less? (car y) (car x)) nil)
                           (t              (less? (cdr x) (cdr y)))))
             (vector (sequence-less? x y)))))))

(defun sequence-less? (x y)
  "Is sequence X less than sequence Y?"
  (map nil (lambda (a b)
             (cond ((less? a b) (return-from sequence-less? t))
                   ((less? b a) (return-from sequence-less? nil))))
       x y))

(defun equal? (&rest args)
  (apply #'equalp args))