swank-picolisp.l (13052B)
1 ### -*- picolisp -*- 2 ## 3 ## swank-picolisp.l Copyright (c) 2011 Tomas Hlavaty 4 ## 5 ## Permission is hereby granted, free of charge, to any person 6 ## obtaining a copy of this software and associated documentation 7 ## files (the "Software"), to deal in the Software without 8 ## restriction, including without limitation the rights to use, copy, 9 ## modify, merge, publish, distribute, sublicense, and/or sell copies 10 ## of the Software, and to permit persons to whom the Software is 11 ## furnished to do so, subject to the following conditions: 12 ## 13 ## The above copyright notice and this permission notice shall be 14 ## included in all copies or substantial portions of the Software. 15 ## 16 ## THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 ## EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 ## MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 ## NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 20 ## BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 21 ## ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 22 ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 ## SOFTWARE. 24 ## 25 ## === Set up === 26 ## 27 ## Put the following code in your .emacs file: 28 ## 29 ## --- start .emacs --- 30 ## 31 ## (add-to-list 'load-path "~/path/to/picolisp/lib/el/") 32 ## (require 'picolisp) 33 ## (add-to-list 'auto-mode-alist '("\\.l\\'" . picolisp-mode)) 34 ## 35 ## (add-hook 'picolisp-mode-hook (lambda () (slime-mode 1))) 36 ## 37 ## (setq slime-lisp-implementations 38 ## `((picolisp ("/path/to/picolisp/p") :init slime-init-picolisp))) 39 ## 40 ## (defun slime-init-picolisp (file _) 41 ## (setq slime-protocol-version 'ignore) 42 ## (format "%S\n" 43 ## `(prog (load ,(expand-file-name "/path/to/swank-picolisp.l")) 44 ## (swank-start ,file)))) 45 ## --- end .emacs --- 46 ## 47 ## Also, set up slime to your taste. 48 49 (de swank (Port) 50 (default Port 4005) 51 (swank-accept-connections Port NIL) ) 52 53 (de swank-start (PortFile) 54 (swank-accept-connections NIL PortFile) ) 55 56 (de swank-accept-connections (Port PortFile) 57 (let P (port (or Port 0) 'Port) 58 (prinl "## Listening on port " Port) 59 (when PortFile 60 (out @ (prinl Port)) ) 61 (use Sock 62 (loop 63 (setq Sock (listen P)) 64 (swank-loop Sock) 65 (close Sock) ) ) ) ) 66 67 (de swank-loop (Sock) 68 (while (swank-read-packet Sock) 69 (swank-dispatch Sock @) ) ) 70 71 (de swank-read-packet (Sock) 72 (in Sock 73 (read) ## TODO do not ignore length 74 (read) ) ) 75 76 (de swank-dispatch (Sock Form) 77 (println Form) 78 (case (car Form) 79 (":emacs-rex" (apply swank-emacs-rex (cdr Form) Sock)) 80 (T (throw "Unhandled swank event" Form)) ) ) 81 82 (de swank-send-to-emacs (Sock Form) 83 (let Payload (sym Form) 84 (out Sock 85 (prin (pad 6 (hex (length Payload))) Payload) 86 (flush) ) 87 (prinl (pad 6 (hex (length Payload))) Payload) 88 (flush) ) ) 89 90 (de swank-emacs-rex (Sock Form Pkg Thread Id) 91 (swank-send-to-emacs Sock (list ':return (list ':ok (eval Form)) Id)) ) 92 93 (de lisp-implementation-type () 94 (pack "PicoLisp" (if (== 64 64) 64 32)) ) 95 96 (de lisp-implementation-version () 97 (in (path "@CHANGES") 98 (use (@X) 99 (when (match '("*" " " @D "p" "i" "c" "o" "L" "i" "s" "p" "-" @V) 100 (line) ) 101 (pack @V) ) ) ) ) 102 103 (de lisp-implementation-program () 104 (path "@p") ) ## TODO compute properly e.g. p|dbg|bin/picolisp 105 106 (de machine-instance () 107 (in '("uname" "-n") 108 (line T) ) ) 109 110 (de machine-type () 111 (in '("uname" "-m") 112 (line T) ) ) 113 114 (de machine-version () 115 (in "/proc/cpuinfo" 116 (pack (tail -13 (do 5 (line)))) ) ) 117 118 (de swank:connection-info () 119 (list 120 ':pid *Pid 121 ':style 'nil 122 ':encoding '(:coding-systems "utf-8") 123 ':lisp-implementation (list 124 ':type (lisp-implementation-type) 125 ':name (lisp-implementation-type) 126 ':version (lisp-implementation-version) 127 ':program (lisp-implementation-program) ) 128 ':machine (list 129 ':instance (machine-instance) 130 ':type (machine-type) 131 ':version (machine-version) ) 132 ':features '(:dummy) 133 ':modules '("module1" "module2") 134 ':package '(:name "PIL1" :prompt "pil1") 135 ':version 'nil ) ) 136 137 (de *Swank:autodoc-built-in . NIL) 138 139 (de %swank:ensure-autodoc-built-in () 140 (unless *Swank:autodoc-built-in 141 (if (== 64 64) 142 (in (list "sh" 143 "-c" 144 (pack "grep -n '\^# (' " 145 (path "@src64") 146 "/*.l | grep -v '\^# (c)'" ) ) 147 (use (@F @N @A @Z) 148 (until (eof) 149 (when (match '(@F ":" @N ":" "#" " " "(" @A " " @Z) (line)) 150 ## TODO multiple lines, e.g.'for' 151 (push '*Swank:autodoc-built-in 152 (list 153 (pack @A) 154 (pack @Z) 155 (pack @F) 156 (format (pack @N)) ) ) ) ) ) ) 157 (in (list "sh" "-c" (pack "grep -n '\^// (' " (path "@src") "/*.c" )) 158 (use (@F @N @A @Z) 159 (until (eof) 160 (when (match '(@F ":" @N ":" "/" "/" " " "(" @A " " @Z) (line)) 161 ## TODO multiple lines, e.g.'for' 162 (push '*Swank:autodoc-built-in 163 (list 164 (pack @A) 165 (pack @Z) 166 (pack @F) 167 (format (pack @N)) ) ) ) ) ) ) ) ) 168 *Swank:autodoc-built-in ) 169 170 (de %swank:autodoc-built-in (Nm) 171 (let? X (cadr (assoc Nm (%swank:ensure-autodoc-built-in))) 172 (pack "(" X) ) ) 173 174 ##(%swank:autodoc-built-in "pack") 175 ##(%swank:autodoc-built-in "de") 176 ##(%swank:autodoc-built-in "for") 177 178 (de swank:autodoc (RawForm . @) 179 ## TODO highlighting "Arg1 ===> Arg2 <=== Arg3" 180 ## TODO Key PrintRightMargin 181 (let? Nm (intern (caar RawForm)) 182 (let Def (val Nm) 183 (cond 184 ((or (not Def) (= Nm Def)) (pack Nm " not defined")) 185 ((atom Def) (pack Nm " " Def " " (%swank:autodoc-built-in Nm))) 186 (T (pack Nm " " (sym (car Def)))) ) ) ) ) 187 188 (de swank:swank-require (Lst)) 189 190 (de swank:create-repl () 191 (list "PIL" "pil") ) 192 193 (de swank:listener-eval (Str) 194 (cons ':values (list (sym (mapc eval (str Str))))) ) 195 196 (de swank:interactive-eval (Str) 197 (sym (mapc eval (str Str))) ) 198 199 (de swank:clear-repl-results () 200 T ) 201 202 (de swank:buffer-first-change (File) 203 (println 'swank:buffer-first-change File) 204 (flush) ) 205 206 #"Two" "PIL2" :limit 300 :time-limit-in-msec 1500 207 (de swank:fuzzy-completions (Str Pkg . @) 208 ## TODO how to get list of all (interned) symbols for completion? 209 ##(list (head 10 (mapcar '((X) (list (sym X) 1 '((0 "a") (1 "b")) 'nil)) (all))) 'nil) 210 ## '((("multiple-value-bind" 26.588236 ((0 "m") (9 "v") (15 "b")) (:FBOUNDP :MACRO)) 211 ## ("multiple-value-bind" 26.588236 ((0 "m") (9 "v") (15 "b")) (:FBOUNDP :MACRO)) 212 ## ("multiple-value-bind" 26.588236 ((0 "m") (9 "v") (15 "b")) nil) ) 213 ## nil ) 214 ) 215 216 (de swank:fuzzy-completion-selected (Nm Compl) 217 ) 218 219 (de swank:find-definitions-for-emacs (Nm) 220 (let Sym (intern Nm) 221 (or 222 (let? X (get Sym '*Dbg) 223 (list (list Nm (list ':location 224 (list ':file (path (cadar X))) 225 (list ':line (caar X)) 226 () ) ) ) ) 227 (let? X (assoc Nm (%swank:ensure-autodoc-built-in)) 228 (list (list Nm (list ':location 229 (list ':file (caddr X)) 230 (list ':line (cadddr X)) 231 () ) ) ) ) ) ) ) 232 233 (de swank:swank-toggle-trace (Nm) 234 (trace (intern Nm))) 235 236 (de swank:swank-expand-1 (Form) 237 Form ) 238 239 (de *Swank:ref . NIL) 240 241 (de %swank:ensure-ref () 242 (setq *Swank:ref ## TODO really compute 243 (mapcar pack 244 '( ## Symbol Functions 245 new sym str char name sp? pat? fun? all intern extern ==== qsym loc box? str? ext? touch zap length size format chop pack glue pad align center text wrap pre? sub? low? upp? lowc uppc fold val getd set setq def de dm recur undef redef daemon patch xchg on off onOff zero one default expr subr let let? use accu push push1 pop cut del queue fifo idx lup cache locale dirname 246 ## Property Access 247 put get prop ; =: : :: putl getl wipe meta 248 ## Predicates 249 atom pair circ? lst? num? sym? flg? sp? pat? fun? box? str? ext? bool not == n== = <> =0 =T n0 nT < <= > >= match 250 ## Arithmetics 251 + - * / % */ ** inc dec >> lt0 le0 ge0 gt0 abs bit? & | x| sqrt seed rand max min length size accu format pad money round bin oct hex hax fmt64 252 ## List Processing 253 car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cadddr cddddr nth con cons conc circ rot list need range full make made chain link yoke copy mix append delete delq replace insert remove place strip split reverse flip trim clip head tail stem fin last member memq mmeq sect diff index offset prior assoc asoq rank sort uniq group length size val set xchg push push1 pop cut queue fifo idx balance get fill apply 254 ## Control Flow 255 load args next arg rest pass quote as lit eval run macro curry def de dm recur recurse undef box new type isa method meth send try super extra with bind job let let? use and or nand nor xor bool not nil t prog prog1 prog2 if if2 ifn when unless cond nond case state while until loop do at for catch throw finally co yield ! e $ sys call tick ipid opid kill quit task fork pipe later timeout abort bye 256 ## Mapping 257 apply pass maps map mapc maplist mapcar mapcon mapcan filter extract seek find pick cnt sum maxi mini fish by 258 ## Input/Output 259 path in out err ctl ipid opid pipe any sym str load hear tell key poll peek char skip eol eof from till line format scl read print println printsp prin prinl msg space beep tab flush rewind rd pr wr wait sync echo info file dir lines open close port listen accept host connect udp script once rc acquire release pretty pp show view here prEval mail 260 ## Object Orientation 261 *Class class dm rel var var: new type isa method meth send try object extend super extra with This can dep 262 ## Database 263 pool journal id seq lieu lock commit rollback mark free dbck dbs dbs+ db: tree db aux collect genKey useKey +relation +Any +Bag +Bool +Number +Date +Time +Symbol +String +Link +Joint +Blob +Hook +index +Key +Ref +Ref2 +Idx +Sn +Fold +Aux +Dep +List +Need +Mis +Alt blob dbSync new! set! put! inc! blob! upd rel request obj fmt64 root fetch store count leaf minKey maxKey init step scan iter prune zapTree chkTree db/3 db/4 db/5 val/3 lst/3 map/3 isa/2 same/3 bool/3 range/3 head/3 fold/3 part/3 tolr/3 select/3 remote/2 264 ## Pilog 265 prove -> unify be repeat asserta assertz retract rules goal fail pilog solve query ? repeat/0 fail/0 true/0 not/1 call/1 or/2 nil/1 equal/2 different/2 append/3 member/2 delete/3 permute/2 uniq/2 asserta/1 assertz/1 retract/1 clause/2 show/1 db/3 db/4 db/5 val/3 lst/3 map/3 isa/2 same/3 bool/3 range/3 head/3 fold/3 part/3 tolr/3 select/3 remote/2 266 ## Debugging 267 pretty pp show loc *Dbg doc more depth what who can dep debug d unbug u vi ld trace untrace traceAll proc hd bench edit lint lintAll select update 268 ## System Functions 269 cmd argv opt version gc raw alarm protect heap stack adr env up date time usec stamp dat$ $dat datSym datStr strDat expDat day week ultimo tim$ $tim telStr expTel locale allowed allow pwd cd chdir ctty info dir dirname errno native call tick kill quit task fork forked pipe timeout mail assert test bye 270 ## Globals 271 NIL *OS *DB T *Solo *PPid *Pid @ @@ @@@ This *Dbg *Zap *Scl *Class *Dbs *Run *Hup *Sig1 *Sig2 ^ *Err *Msg *Uni *Led *Tsm *Adr *Allow *Fork *Bye ) ) ) ) 272 273 (de swank-ref-file (Nm) 274 (pack 275 (path "@doc/ref") 276 (let X (chop Nm) 277 (cond 278 ((= "*" (car X)) 279 (uppc (cadr X)) ) 280 ((member (lowc (car X)) (chop "abcdefghijklmnopqrstuvwxyz")) 281 (uppc (car X)) ) 282 (T "_") ) ) 283 ".html" ) ) 284 285 (de swank:describe-symbol (Nm) 286 (ifn (member Nm (%swank:ensure-ref)) 287 (pack "Unknown symbol '" Nm "'") 288 (let File (swank-ref-file Nm) 289 (let Url (pack "file://" File "#" Nm) 290 (glue "^J" ## TODO turn of ^J escaping! 291 (make 292 (link (pack "Symbol '" Nm "' " Url)) 293 ## (in File ## TODO filter requested content and render html 294 ## (until (eof) 295 ## (link (line)) ) ) 296 (link "TODO display actual content of the link") ) ) ) ) ) ) 297 298 (de swank:init-inspector (Form) 299 ) 300 301 (de swank:quit-lisp () 302 (bye) )