(in-package :cl-wasm)
 

 (declaim (inline signed invsigned))
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defun signed (n i)
     (if (and (<= 0 i)
              (< i (expt 2 (1- n))))
         i
         (- i (expt 2 n))))
   (defun invsigned (n i)
     (if (< i 0)
         (+ i (expt 2 n))
         i)))

 
 (defgeneric run-inst (client stack locals instruction argument)
   (:method (client (stack list) (locals vector) (instruction (eql :get-local)) (argument number))
     (cons (aref locals argument)
           stack)))
 
 (defmacro define-numeric-instruction (suffix (&optional (arg '(argument null))) &body body)
   (let ((i32-name (alexandria:make-keyword (format nil "~a.~a" :i32 suffix)))
         (i64-name (alexandria:make-keyword (format nil "~a.~a" :i64 suffix)))
         (f32-name (alexandria:make-keyword (format nil "~a.~a" :f32 suffix)))
         (f64-name (alexandria:make-keyword (format nil "~a.~a" :f64 suffix))))
     (flet ((get-argument (type)
              (case type
                (:i32 (list (car arg)
                            (case (cadr arg)
                              (:type 'integer)
                              (t (cadr arg)))))
                (:i64 (list (car arg)
                            (case (cadr arg)
                              (:type 'integer)
                              (t (cadr arg)))))
                (:f32 (list (car arg)
                            (case (cadr arg)
                              (:type 'single-float)
                              (t (cadr arg)))))
                (:f64 (list (car arg)
                            (case (cadr arg)
                              (:type 'double-float)
                              (t (cadr arg))))))))
       `(macrolet ((numeric-dispatch (&body forms)
                     (cons 'or forms)))
          (defmethod run-inst (client (stack list) (locals vector) (inst (eql ,i32-name)) ,(get-argument :i32))

            (declare (optimize (speed 1) (safety 1)))

            (macrolet ((numeric-case (type &body body)
                         (when (eql type :i32)
                           (cons 'progn body))))
              (let ((numeric-type '(integer 0 #.(1- (expt 2 32))))
                    (size 32))
                (declare (ignorable numeric-type size))
                ,@body)))
          (defmethod run-inst (client (stack list) (locals vector) (inst (eql ,i64-name)) ,(get-argument :i64))

            (declare (optimize (speed 1) (safety 1)))

            (macrolet ((numeric-case (type &body body)
                         (when (eql type :i64)
                           (cons 'progn body))))

              (let ((numeric-type '(integer 0 #.(1- (expt 2 64))))

                    (size 64))
                (declare (ignorable numeric-type size))
                ,@body)))
          (defmethod run-inst (client (stack list) (locals vector) (inst (eql ,f32-name)) ,(get-argument :f32))

            (declare (optimize (speed 1) (safety 1)))

            (macrolet ((numeric-case (type &body body)
                         (when (eql type :f32)
                           (cons 'progn body))))
              (let ((numeric-type 'single-float)
                    (size 32))
                (declare (ignorable numeric-type size))
                ,@body)))
          (defmethod run-inst (client (stack list) (locals vector) (inst (eql ,f64-name)) ,(get-argument :f64))

            (declare (optimize (speed 1) (safety 1)))

            (macrolet ((numeric-case (type &body body)
                         (when (eql type :f64)
                           (cons 'progn body))))
              (let ((numeric-type 'double-float)
                    (size 64))
                (declare (ignorable numeric-type size))
                ,@body)))))))
 
 (define-numeric-instruction add ()
   (let ((result (+ (coerce (pop stack) numeric-type)
                     (coerce (pop stack) numeric-type))))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod result #.(expt 2 32)))
            (numeric-case :i64 (mod result #.(expt 2 64)))
            (numeric-case :f32 result)
            (numeric-case :f64 result))
           stack)))
 
 (define-numeric-instruction mul ()
   (let ((result (* (coerce (pop stack) numeric-type)
                    (coerce (pop stack) numeric-type))))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod result #.(expt 2 32)))
            (numeric-case :i64 (mod result #.(expt 2 64)))
            (numeric-case :f32 result)
            (numeric-case :f64 result))
           stack)))
 
 (define-numeric-instruction const ((arg :type))
   (cons (coerce arg numeric-type) 
         stack))
 
 (define-numeric-instruction sub ()
   (let ((i2 (pop stack))
         (i1 (pop stack)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod (+ (- (coerce i1 numeric-type)
                                           (coerce i2 numeric-type))
                                        #.(expt 2 32))
                                    #.(expt 2 32)))
            (numeric-case :i64 (mod (+ (- (coerce i1 numeric-type)
                                           (coerce i2 numeric-type))
                                        #.(expt 2 64))
                                    #.(expt 2 64)))
            (numeric-case :f32 (- (coerce i1 numeric-type)
                                   (coerce i2 numeric-type)))
            (numeric-case :f64 (- (coerce i1 numeric-type)
                                   (coerce i2 numeric-type))))
           stack)))
 
 (define-numeric-instruction div_u ()
   (let ((i2 (pop stack))
         (i1 (pop stack)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod (truncate (coerce i1 numeric-type)
                                              (coerce i2 numeric-type))
                                    #.(expt 2 32)))
            (numeric-case :i64 (mod (truncate (coerce i1 numeric-type)
                                              (coerce i2 numeric-type))
                                    #.(expt 2 64)))
            (numeric-case :f32 (error "floating div not implemented"))
            (numeric-case :f64 (error "floating div not implemented")))
           stack)))
 
 (define-numeric-instruction div_s ()
   (let* ((i2 (coerce (pop stack) numeric-type))

          (j2 (signed size i2))

          (i1 (coerce (pop stack) numeric-type))

          (j1 (signed size i1)))

     (declare (ignorable i1 i2 j1 j2))
     (cons (numeric-dispatch

            (numeric-case :i32 (if (/= (truncate i1 i2) #.(expt 2 31))
                                   (invsigned 32 (truncate j1 j2))

                                   (error "undefined result")))
            (numeric-case :i64 (if (/= (truncate (coerce i1 numeric-type)
                                                 (coerce i2 numeric-type))
                                       #.(expt 2 63))

                                   (invsigned 64 (truncate j1 j2))

                                   (error "undefined result")))
            (numeric-case :f32 (error "floating div not implemented"))
            (numeric-case :f64 (error "floating div not implemented")))
           stack)))
 
 (define-numeric-instruction rem_u ()
   (let ((i2 (pop stack))
         (i1 (pop stack)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod (- (coerce i1 numeric-type)
                                        (* (coerce i2 numeric-type)
                                           (truncate i1 i2)))
                                    #.(expt 2 32)))
            (numeric-case :i64 (mod (- (coerce i1 numeric-type)
                                        (* (coerce i2 numeric-type)
                                           (truncate i1 i2)))
                                    #.(expt 2 64)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 
 (define-numeric-instruction rem_s ()
   (let* ((i2 (pop stack))
          (j2 (signed size i2))
          (i1 (pop stack))
          (j1 (signed size i1)))
     (declare (ignorable i1 i2 j1 j2))
     (cons (numeric-dispatch

            (numeric-case :i32 (mod (- j1 (* j2
                                             (truncate j1 j2)))

                                    #.(expt 2 32)))

            (numeric-case :i64 (mod (- j1 (* j2
                                             (truncate j1 j2)))

                                    #.(expt 2 64)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 
 (define-numeric-instruction rem_s ()
   (let* ((i2 (pop stack))
          (j2 (signed size i2))
          (i1 (pop stack))
          (j1 (signed size i1)))
     (declare (ignorable i1 i2 j1 j2))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod (- (coerce j1 numeric-type)
                                        (* (coerce j2 numeric-type)
                                           (truncate j1 j2)))
                                    #.(expt 2 32)))
            (numeric-case :i64 (mod (- (coerce j1 numeric-type)
                                        (* (coerce j2 numeric-type)
                                           (truncate j1 j2)))
                                    #.(expt 2 64)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 
 (define-numeric-instruction and ()
   (let* ((i2 (coerce (pop stack)
                      numeric-type))
          (i1 (coerce (pop stack)
                      numeric-type)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (logand #.(1- (expt 2 32))
                                       (logand i1 i2)))
            (numeric-case :i64 (logand #.(1- (expt 2 64))
                                       (logand i1 i2)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 
 (define-numeric-instruction or ()
   (let* ((i2 (coerce (pop stack)
                      numeric-type))
          (i1 (coerce (pop stack)
                      numeric-type)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (logand #.(1- (expt 2 32))
                                       (logior i1 i2)))
            (numeric-case :i64 (logand #.(1- (expt 2 64))
                                       (logior i1 i2)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 
 (define-numeric-instruction xor ()
   (let* ((i2 (coerce (pop stack)
                      numeric-type))
          (i1 (coerce (pop stack)
                      numeric-type)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (logand #.(1- (expt 2 32))
                                       (logxor i1 i2)))
            (numeric-case :i64 (logand #.(1- (expt 2 64))
                                       (logxor i1 i2)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 

 (define-numeric-instruction shl ()
   (let* ((i2 (coerce (pop stack)
                      numeric-type))
          (i1 (coerce (pop stack)
                      numeric-type)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod (ash i1 i2)
                                    #.(expt 2 32)))
            (numeric-case :i64 (mod (ash i1 i2)
                                    #.(expt 2 64)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 
 (define-numeric-instruction shr_u ()
   (let* ((i2 (coerce (pop stack)
                      numeric-type))
          (i1 (coerce (pop stack)
                      numeric-type)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod (ash i1 (- i2))
                                    #.(expt 2 32)))
            (numeric-case :i64 (mod (ash i1 (- i2))
                                    #.(expt 2 64)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 
 (define-numeric-instruction shr_s ()
   (let* ((i2 (coerce (pop stack)
                      numeric-type))
          (i1 (coerce (pop stack)
                      numeric-type)))
     (declare (ignorable i1 i2))
     (cons (numeric-dispatch
            (numeric-case :i32 (mod (ash (logand -1 i1)
                                         (- i2))
                                    #.(expt 2 32)))
            (numeric-case :i64 (mod (ash (logand -1 i1)
                                         (- i2))
                                    #.(expt 2 64)))
            (numeric-case :f32 (error "floating rem not implemented"))
            (numeric-case :f64 (error "floating rem not implemented")))
           stack)))
 

 (fw.lu:defclass+ tracer ()
   ((%level :initarg :level :accessor level)))
 (fw.lu:defclass+ wat-emitter ()
   ((%level :initarg :level :accessor level)))
 
 (defvar *client*
   (tracer 0))
 
 (defmethod run-inst :around ((client tracer) stack locals instruction argument)
   (format t "~&~vt> ~s ~s ~s~%~vt~8t|~{~s~^ ~}|"
           (level client) locals instruction argument
           (level client) (reverse stack))
   (incf (level client))
   (unwind-protect
        (let ((out (call-next-method)))
          (prog1 out
            (format t "~&~vt<~8t|~{~s~^ ~}|~%"
                    (level client) (reverse out))))
     (decf (level client))))
 
 (defmethod run-inst :around ((client wat-emitter) stack locals instruction argument)
   (incf (level client))
   (unwind-protect
        (let ((out (call-next-method)))
          (let ((*print-case* :downcase))
            (format t "~&~4t~a~:[~; ~:*~a~]" instruction argument))
          out)
     (decf (level client))))
 
 (defgeneric pre-interpret (client)
   (:method (client)))
 (defgeneric post-interpret (client)
   (:method (client)))
 
 (defmethod pre-interpret ((client wat-emitter))
   (format t "~&(module (func $it (result i32)"))
 (defmethod post-interpret ((client wat-emitter))
   (format t ")
   (export \"it\" (func $it)))~%"))
 
 (defun interpret (instructions locals)
   (pre-interpret *client*)
   (let ((stack ()))
     (loop for (instruction argument) in instructions
           do (setf stack
                    (run-inst *client* stack locals instruction argument)))
     (post-interpret *client*)
     stack))
 
 (defun test-responder ()
   (spinneret:with-html-string
     (:html
      (:body
       (:script :src "https://localhost/~elangley/libwabt.js")

       (:script
        (ps:ps
          (let* ((ws (ps:new (-web-socket "ws://localhost:5001/ws")))
                 (compile-wat (lambda (m)
                                (lambda (wabt)
                                  (ps:chain ws
                                            (send
                                             (+ "result "
                                                (ps:chain
                                                 (setf (ps:@ window module)
                                                       (ps:new
                                                        ((ps:@ -web-assembly -instance)
                                                         (ps:new
                                                          ((ps:@ -web-assembly -module)
                                                           (ps:chain wabt
                                                                     (parse-wat "foo.wast"
                                                                                (ps:@ m data))
                                                                     (to-binary
                                                                      (ps:create log ps:t
                                                                                 write_debug_names ps:t))
                                                                     buffer))))))
                                                 exports
                                                 (it))))))))
                 (message-handler (lambda (m)
                                    (ps:chain console (log (ps:@ m data)))
                                    (ps:chain (ps:new (-wabt-module))
                                              (then (compile-wat m))))))
            (ps:chain ws
                      (add-event-listener "message" message-handler))
            (ps:chain ws
                      (add-event-listener "close"
                                          (lambda (_)
                                            (setf ws (ps:new (-web-socket "ws://localhost:5001/ws")))
                                            (ps:chain ws
                                                      (add-event-listener "message" message-handler))))))))))))
 
 (defclass wasm-session (hunchensocket:websocket-resource)
   ((name :initarg :name :reader name)))
 
 (defvar *wasm-sessions*
   (make-array 10 :fill-pointer 0 :adjustable t))
 
 (defmethod hunchensocket:text-message-received ((resource wasm-session) client message)
   (format t "~&in: ~a~%" message))
 
 (defun find-wasm-session (request)
   (or (find (hunchentoot:script-name request)
             *wasm-sessions*
             :test #'string=
             :key 'name)
       (fw.lu:prog1-bind (session (make-instance 'wasm-session 
                                                 :name (hunchentoot:script-name request)))
         (vector-push-extend session
                             *wasm-sessions*))))
 
 (pushnew 'find-wasm-session
          hunchensocket:*websocket-dispatch-table*)
 
 (defun broadcast (session message)
   (loop for peer in (hunchensocket:clients session)
         do (hunchensocket:send-text-message peer message)))
 
 (defclass my-acceptor (hunchensocket:websocket-acceptor)
   ())
 
 (defmethod hunchentoot:acceptor-dispatch-request ((acceptor my-acceptor) request)
   (if (string= "/" (hunchentoot:script-name request))
       (test-responder)
       (call-next-method)))

 
 (defvar *app*)
 (defvar *handler*)

 (defun demo ()

   (let ((app (make-instance 'my-acceptor :port 5001)))
     (values (hunchentoot:start app) 

             app)))
 
 (defun go* ()
   (setf (values *handler* *app*)
         (demo)))

 
 #|
 i32.clz
 i32.ctz
 i32.popcnt
 i32.shl
 i32.shr_s
 i32.shr_u
 i32.rotl
 i32.rotr
 ​	
 i64.clz
 i64.ctz
 i64.popcnt
 i64.shl
 i64.shr_s
 i64.shr_u
 i64.rotl
 i64.rotr
 ​	
 f32.abs
 f32.neg
 f32.ceil
 f32.floor
 f32.trunc
 f32.nearest
 f32.sqrt
 f32.div
 f32.min
 f32.max
 f32.copysign
 ​	
 f64.abs
 f64.neg
 f64.ceil
 f64.floor
 f64.trunc
 f64.nearest
 f64.sqrt
 f64.div
 f64.min
 f64.max
 f64.copysign
 ​	
 i32.eqz
 i32.eq
 i32.ne
 i32.lt_s
 i32.lt_u
 i32.gt_s
 i32.gt_u
 i32.le_s
 i32.le_u
 i32.ge_s
 i32.ge_u
 ​	
 i64.eqz
 i64.eq
 i64.ne
 i64.lt_s
 i64.lt_u
 i64.gt_s
 i64.gt_u
 i64.le_s
 i64.le_u
 i64.ge_s
 i64.ge_u
 ​	
 f32.eq
 f32.ne
 f32.lt
 f32.gt
 f32.le
 f32.ge
 ​	
 f64.eq
 f64.ne
 f64.lt
 f64.gt
 f64.le
 f64.ge
 ​	
 
 i32.wrap_i64
 i32.trunc_f32_s
 i32.trunc_f32_u
 i32.trunc_f64_s
 i32.trunc_f64_u
 i64.extend_i32_s
 i64.extend_i32_u
 i64.trunc_f32_s
 i64.trunc_f32_u
 i64.trunc_f64_s
 i64.trunc_f64_u
 f32.convert_i32_s
 f32.convert_i32_u
 f32.convert_i64_s
 f32.convert_i64_u
 f32.demote_f64
 f64.convert_i32_s
 f64.convert_i32_u
 f64.convert_i64_s
 f64.convert_i64_u
 f64.promote_f32
 i32.reinterpret_f32
 i64.reinterpret_f64
 f32.reinterpret_i32
 f64.reinterpret_i64
 |#