ls-mode.lisp (6279B)
1 #+sbcl(require :parenscript) 2 #-sbcl(progn 3 (load "~/lisp/cl-asdf-1.79/asdf") 4 (push "~/lisp/systems/" asdf:*central-registry*) 5 (asdf:operate 'asdf:load-op :asdf-install) 6 (asdf:operate 'asdf:load-op :parenscript)) 7 8 (js:defjsmacro labels (defs &body body) 9 `(let ,(loop for (fname fargs fbody) in defs 10 collect `(,fname (lambda ,fargs ,fbody))) 11 ,@body)) 12 13 ;;(js:js-to-string '(labels ((f1 (f1a1 f1a2) f1b) (f2 (f2a1 f2a2) f2b)) b)) 14 15 (js:defjsmacro flet (defs &body body) 16 ;; same as labels for js 17 `(labels ,defs ,@body)) 18 19 ;;(js:js-to-string '(flet ((f1 (f1a1 f1a2) f1b) (f2 (f2a1 f2a2) f2b)) b)) 20 21 (js:defjsmacro funcall (fn &rest args) 22 ;; same as labels for js 23 `(,fn ,@args)) 24 25 ;;(js:js-to-string '(funcall 'identity 1 2)) 26 27 (js:defjsmacro defbuild (name args &body body) 28 (declare (ignore args)) 29 `(setf (aref *wbuild* ,name) 30 (lambda (pw self) 31 ,@body))) 32 33 (js:defjsmacro defpack (name args &body body) 34 (declare (ignore args)) 35 `(setf (aref *wpack* ,name) 36 (lambda (pw w self) 37 ,@body))) 38 39 #+nil(js:defjsmacro definit (name args &body body) 40 (declare (ignore args)) 41 `(setf (aref *winit* ,name) 42 (lambda (pw w self) 43 ,@body))) 44 45 (js:defjsmacro defhandler (name args &body body) 46 `(setf (aref *whandler* ,name) 47 (lambda ,args ,@body))) 48 49 (js:defjsmacro awhen (test &body body) 50 `(let ((it ,test)) 51 (when it 52 ,@body))) 53 54 (js:defjsmacro aif (test then &body else) 55 `(let ((it ,test)) 56 (if it ,then (progn ,@body)))) 57 58 #+nil(js:defjsmacro on-load (&rest body) 59 `(progn 60 (*yahoo*.util.*event.add-listener window "load" (lambda (e) ,@body)))) 61 62 (js:defjsmacro with-properties (names &body body) 63 `(let ,(mapcar (lambda (name) 64 (list name `(get-property self ,(js::symbol-to-js name)))) 65 names) 66 ,@body)) 67 68 (js:defjsmacro with-signals (names &body body) 69 `(let ,(mapcar (lambda (name) 70 (list name `(get-signal self ,(js::symbol-to-js name)))) 71 names) 72 ,@body)) 73 74 (js:defjsmacro with-packing (names &body body) 75 `(let ,(mapcar (lambda (name) 76 (list name `(get-packing self ,(js::symbol-to-js name)))) 77 names) 78 ,@body)) 79 80 (js:defjsmacro plusp (number) 81 `(< 0 ,number)) 82 83 (js:defjsmacro minusp (number) 84 `(< ,number 0)) 85 86 (js:defjsmacro zerop (number) 87 `(= ,number 0)) 88 89 #+nil(js:defjsmacro push (item place) 90 `(.push ,place ,item)) 91 92 #+nil(js:defjsmacro pop (place) 93 `(.pop ,place)) 94 95 (js:defjsmacro null (&optional obj) 96 `(== nil ,obj)) 97 98 #+nil(js:defjsmacro cons (object1 object2) 99 `(list ,object1 ,object2)) 100 101 #+nil(js:defjsmacro elt (sequence index) 102 `(slot-value ,sequence ,index)) 103 104 (js:defjsmacro length (sequence) 105 `(slot-value ,sequence 'length)) 106 107 #+nil(js:defjsmacro first (sequence) 108 `(slot-value ,sequence 0)) 109 110 #+nil(js:defjsmacro second (sequence) 111 `(slot-value ,sequence 1)) 112 113 #+nil(js:defjsmacro rest (sequence) 114 `(.slice ,sequence 1)) 115 116 #+nil(js:defjsmacro funcall (fn &rest args) 117 `(,fn ,@args)) 118 119 ;;(js:js-to-string '(null)) 120 ;;(js:js-to-string '(null undefined)) 121 ;;(js:js-to-string '(null false)) 122 ;;(js:js-to-string '(null 1)) 123 ;;(js:js-to-string '(null nil)) 124 125 ;;(js:compile-parenscript-file "/home/tomas/public_html/lib/webglade.ls") 126 127 (js:defjsmacro defstruct (name-and-options &rest slots) 128 (let* ((name (cond 129 ((symbolp name-and-options) name-and-options) 130 ((listp name-and-options) (first name-and-options)) 131 (t (error "Symbol or list expected: ~s" name-and-options)))) 132 ;; include 133 (include (when (listp name-and-options) 134 (rest (assoc :include (rest name-and-options))))) 135 (iname (first include)) 136 (islots (rest include)) 137 ;; constructor 138 (constructor (when (listp name-and-options) 139 (rest (assoc :constructor (rest name-and-options))))) 140 (cname (first constructor)) 141 (cargs (rest constructor))) 142 ;;(format t "Constructor ~s" constructor) 143 ;;(format t "iname ~s~%" iname) 144 `(progn 145 ,@(append 146 (when iname 147 (list `(setf (slot-value ,name 'prototype) (new ,iname)))) 148 #+nil(unless cname 149 (list `(defun ,(make-cname) () 150 ))) 151 (list 152 `(defun ,name () 153 ,@(loop for slot in slots 154 for name = (cond 155 ((symbolp slot) slot) 156 ((listp slot) (first slot)) 157 (t (error "Symbol or list expected: ~s" name))) 158 for value = (when (listp slot) 159 (second slot)) 160 collect `(setf (slot-value this ',name) ,value)))))))) 161 162 (js:defjsmacro cond (&rest clauses) 163 (labels ((rec (clauses) 164 (when clauses 165 (let ((head (first clauses)) 166 (tail (rest clauses))) 167 `(if ,(first head) 168 (progn ,@(rest head)) 169 ,(when tail `(progn ,(rec tail)))))))) 170 (rec clauses))) 171 172 ;;(js:js-to-string '(if t "tt" nil)) 173 174 ;;(js:js-to-string '(cond)) 175 ;;(js:js-to-string '(cond (t "tt"))) 176 ;;(js:js-to-string '(cond ((and one two) "12") (nil "ff") (t "tt"))) 177 178 #+nil(define-js-compiler-macro do (decls termination &rest body) 179 (let ((vars (make-for-vars decls)) 180 (steps (make-for-steps decls)) 181 (check (js-compile-to-expression (list 'not (first termination)))) 182 (body (js-compile-to-body (cons 'progn body) :indent " "))) 183 (make-instance 'js-for 184 :vars vars 185 :steps steps 186 :check check 187 :body body))) 188 189 ;; modified to check for null array first! 190 (js:defjsmacro dolist (i-array &rest body) 191 (let ((var (first i-array)) 192 (array (second i-array)) 193 (arrvar (js::js-gensym "arr")) 194 (idx (js::js-gensym "i"))) 195 `(let ((,arrvar ,array)) 196 (when ,arrvar 197 (do ((,idx 0 (1+ ,idx))) 198 ((>= ,idx (slot-value ,arrvar 'length))) 199 (let ((,var (aref ,arrvar ,idx))) 200 ,@body)))))) 201 202 ;;(js:js-to-string '(dolist (i nil) (alert i))) 203 ;;(js:js-to-string '(dolist (i (list 1 2 3)) (alert i))) 204 ;;(js:js-to-string '(dolist (i (list 1 2 3) 4) (alert i)))