Here is the interesting content from the original picoWiki, which went live on 2008-10-08 Wed. The original picoWiki has been deprecated. For the official PicoLisp wiki, see http://picolisp.com.

Table of Contents

1 +Blob

Subclass of \{+Entity} for storing binary or large text data in separate file.

Example of relation definition:

(class +C +Entity)
(rel r (+Blob))

1.1 Text data

Example of \{gui} element to display text data:

(gui '(+BlobField) '(r : home obj) 70 25)

There is also \{+RteField} which can be used to edit blob text data.

1.2 Image data

It is probably useful to name the blob something like jpg instead of r.

Example of \{gui} element to manage image data:

   (gui '(+Able +UpField) '(not (: home obj r)) 45)
   (gui '(+Button) '(if (: home obj r) ,"Uninstall" ,"Install")
      '(if (: home obj r)
         (ask ,"Uninstall Picture?"
            (put!> (: home top 1 r) 'r NIL) )
         (let? F (val> (field -1))
            (blob! (: home obj) 'r (tmp F)) ) ) ) )

Example of \{gui} element to display image data:

(when (: home obj r)
   (<p> NIL (<img> (allow (blob (: home obj) 'r)) ,"Picture")) )

1.3 Other

The following functions can be quite useful too:

(de fempty (F)
   (use C
      (in F
            (NIL (setq C (char)) T)
            (T (not (member C (chop " ^I^M^J"))) NIL)))))

(de blob? (Obj Var)
   (when (and Obj (get Obj Var))
      (let B (blob Obj Var)
         (when (and (info B) (not (fempty B)))

The blob? function returns the blob file name only if the object has the blob slot, the blob file exists and contains something (not whitespace only). If the blob does not contain any useful data, it might be better not to store it in the first place though.

\{ToDo} what about checking the expected image type on upload?

\{ToDo} what about checking upload file size limit?

2 +Bool.txt

Subclass of \{+Entity} for storing T or NIL.

Example of relation definition:

(class +C +Entity)
(rel r (+Bool))

Example of \{gui} element:

(gui '(+E/R +Checkbox) '(r : home obj))

3 classes

4 Database

\{+Entity}: superclass of all database/persistent classes, see http://www.software-lab.de/ref.html#dbase

4.1 Primitive types like

\{+Symbol}: Symbolic data

\{+String}: Strings (just a general case of symbols)

\{+Number}: Integers and fixed-point numbers

\{+Date}: Calendar date values, represented by a number

\{+Time}: Time-of-the-day values, represented by a number

\{+Blob}: "Binary large objects" stored in separate files

4.2 Object-to-object relations

\{+Link}: A reference to some other entity

\{+Hook}: A reference to an entity holding object-local index trees

\{+Joint}: A bi-directional reference to some other entity

4.3 Container prefix classes like

\{+List}: A list of any of the other primitive or object relation types

\{+Bag}: A list containing a mixture of any of the other types

4.4 Index prefix classes

\{+Ref}: An index with other primitives or entities as key

\{+Key}: A unique index with other primitives or entities as key

\{+Idx}: A full-text index, typically for strings

\{+Sn}: Tolerant index, using the Soundex-Algorithm

4.5 Booleans

\{+Bool}: T or NIL

4.6 And a catch-all class


5 closure

Closure is "a class with one method, apply" (as Guy Steele succinctly noted on a mailing list I lost reference to) or to put it in another way, it is "a function that can access its outside lexical environment". See http://en.wikipedia.org/wiki/Lexical_closure for more elaborate description.

I would say that the difference between the class and function interpretations is at the syntax level, not in semantics.

http://www.software-lab.de/faq.html#closures has some explanation regarding closures in PicoLisp.

As closures are useful in various situations, lets discuss practical options how to use them in PicoLisp. Most of the summary here originated from http://www.mail-archive.com/picolisp@software-lab.de/msg00534.html mailing list.

5.1 Closures as functions

Question: Is there a better way of achieving the following?

(let @S '((I . 0))
   (def 'count1 (fill '(() (job '@S (inc 'I)))))
   (def 'reset (fill '(() (job '@S (zero I))))))

The two functions are closed over (share) the same variable I.

(count1) => 1
(count1) => 2
(reset) => 0
(count1) => 1

Answer 1: With a little trick, you could also use it here:

(let I '(0)
   (def 'count1 (curry (I) () (inc I)))
   (def 'reset (curry (I) () (set I 0))) )

Answer 2: There is a kind of middle way between our two solutions:

(let @S '((I . 0))
   (def 'count1 (curry (@S) () (job '@S (inc 'I))))
   (def 'reset (curry (@S) () (job '@S (zero I)))) )

BTW, all three solutions have in common that they depend on a shared data structure (a cell (I . 0) or (0)). If the 'let' is going to be used within some other function (instead of the top level here), it should better be

(let @S (list (cons 'I 0))


(let I (cons 0)

to use a locally encapsulated cell.

5.2 Closures as classes

…once the things inside the closures get complicated, it might be worth using objects to get better code factoring:

(class +Counter)
# i

(dm T ()
   (=: i 0) )

(dm count> ()
   (inc (:: i)) )

(dm reset> ()
   (=: i 0) )

(let @C (list (cons 'C (new '(+Counter))))
   (def 'count (curry (@C) () (job '@C (count> C))))
   (def 'reset (curry (@C) () (job '@C (reset> C)))) )

Or using objects directly so that I can have many independent counters…

6 GeoIP

Geographical IP look up to find where an IP address is located.

The fast way using GeoIP software:

# sudo apt-get install geoip-bin
(de ip2country (Ip)
   (in (list "geoiplookup" Ip)
      (use (@A @B @C)
         (match '(@A ":" " " @B "," " " @C) (line))
         (mapcar pack (list @B @C)))))
: (ip2country "")
-> ("GB" "United Kingdom")

Or the slow way using http://gumby.appspot.com/ Gumby web service:

(load "@lib/http.l" "@lib/xml.l")
(de ip2country (Ip)
   (client "gumby.appspot.com" 80 (pack "/api/?format=xml&ip=" Ip)
      (from "^M^J^M^J")
      (when (xml?)
         (nth (xml) 5 4 3 1))))
: (ip2country "")
-> "GB"

7 gui

\{ToDo} misc gui stuff

\{+RteField} Rich Text Formatting for \{+Blob} with text data

8 multimethods

PicoLisp does not have multimethods. Sometimes, they are useful tool which can be implemented as described here. See for example http://en.wikipedia.org/wiki/Multimethods for more information on multimethods.

Suppose we have some classes and we want to define a function/method with behavior depending on the type of arguments. We could use:

However, the most convenient approach is to use multimethods, as implemented in http://en.wikipedia.org/wiki/Common_Lisp_Object_System for example. I will not go that far though.

So we want to achieve the following (dmm stands for define multimethod):

(class +Asteroid)
(class +Spaceship)

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prinl "AA"))

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prinl "AS"))

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prinl "SA"))

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prinl "SS"))

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(collide< A A) # => AA
(collide< A S) # => AS
(collide< S A) # => SA
(collide< S S) # => SS

We can "simply" define a dispatch table and a function that will look up the the function to handle specific arguments.

(put 'collide< 'mm
      (cons '((+Asteroid) (+Asteroid)) '((X Y) (prinl "aa")))
      (cons '((+Asteroid) (+Spaceship)) '((X Y) (prinl "as")))
      (cons '((+Spaceship) (+Asteroid)) '((X Y) (prinl "sa")))
      (cons '((+Spaceship) (+Spaceship)) '((X Y) (prinl "ss"))) ) )

…and a function collide\< would do the look up and \{ref:apply}.

I will try to be more sophisticated and allow for "don't care" cases, e.g. where any of the arguments can be of any type:

(cons '((+Asteroid) NIL) '((X Y) (prinl "a?")))

Here NIL means "don't care" or that the argument can be of any type.

Lets define a few useful functions:

(de mmApplicable (K M)
   (use (KK MM)
         (NIL (or K M) T)
         (setq KK (pop 'K) MM (pop 'M))
         (NIL (or (not MM) (= KK MM)) NIL))))

(de mmApply @
   (let (N (next) A (rest) K NIL)
      (for AA A
         (push 'K (type AA)))
      (setq K (flip K))
      (let *Mm (filter '((M) (mmApplicable K (car M))) (get N 'mm))
         (ifn *Mm
            (quit 'mm (list "No applicable method" N A K))
            (apply (cdr (pop '*Mm)) A)))))

(de mmDef (N P)
   (let L (get N 'mm)
      (ifn L
         (put N 'mm (list P))
         (use X
               (NIL L (put N 'mm (cons P (get N 'mm))))
               (setq X (pop 'L))
               (T (= (car P) (car X)) (con X (cdr P))) ) ) ) ) )

(de dmm A
   (let (N (car A) AA (cadr A) B (cddr A))
      (unless (val N)
         (def N (fill '(@ (pass mmApply 'N)) 'N)) )
      (mmDef N (cons
                  (mapcar '((X) (when (pair X) (cdr X))) AA)
                  (cons (mapcar '((X) (if (pair X) (car X) X)) AA) B) ) ) ) )

Now we can run the following example:

(put 'collide< 'mm
      (cons '((+Asteroid) (+Asteroid)) '((X Y) (prinl "aa")))
      (cons '((+Asteroid) (+Spaceship)) '((X Y) (prinl "as")))
      (cons '((+Spaceship) (+Asteroid)) '((X Y) (prinl "sa")))
      (cons '((+Spaceship) (+Spaceship)) '((X Y) (prinl "ss")))
      (cons '((+Asteroid) NIL) '((X Y) (prinl "a?")))
      (cons '((+Spaceship) NIL) '((X Y) (prinl "s?")))
      (cons '(NIL (+Asteroid)) '((X Y) (prinl "?a")))
      (cons '(NIL (+Spaceship)) '((X Y) (prinl "?s")))
      (cons '(NIL (+Spaceship)) '((X Y) (prinl "?s")))
      (cons '(NIL NIL) '((X Y) (prinl "??"))) ) )

(class +Asteroid)
(class +Spaceship)

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prinl "AA"))

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prinl "AS"))

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prinl "SA"))

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prinl "SS"))

(dmm collide< (X Y)
   (prinl "bang"))

(collide< A A) # => AA
(collide< A S) # => AS
(collide< S A) # => SA
(collide< S S) # => SS
(collide< A 1) # => a?
(collide< 2 A) # => ?a
(collide< S 3) # => s?
(collide< 4 S) # => ?s
(collide< 5 T) # => bang
(collide< T)   # => bang
(collide<)     # => bang

Notice that we defined the dispatch table first to get the right ordering and then we redefined some methods.

This implementation is not good enough yet though as we have to manually maintain the dispatch table (the proper ordering of methods).

Lets automate dispatch table maintainance and introduce function 'mmNext' equivalent to http://www.lispworks.com/documentation/HyperSpec/Body/f_call_n.htm (call-next-method) in CLOS.

(de subclass? (X Y)
   (if (pair Y)
         (NIL Y T)
         (NIL (subclass? X (pop 'Y))) )
      (let Q (if (pair X) X (val X)) # dfs
         (use H
               (NIL Q)
               (setq H (pop 'Q))
               (T (= H Y) T)
               (for HH (val H)
                  (push 'Q HH) ) ) ) ) ) )

(de mmApplicable (K M)
   (use (KK MM)
         (NIL (or K M) T)
         (setq KK (pop 'K) MM (pop 'M))
         (NIL (or (not MM) (= KK MM) (subclass? KK MM)) NIL) ) ) )

(de mmApply @
   (let ("N" (next)
         "A" (rest)
         "K" (mapcar type "A")
         "Mm" (filter '((M) (mmApplicable "K" (car M))) (get "N" 'mm)) )
      (ifn "Mm"
         (quit 'mm (list "No applicable method" "N" "A" "K"))
         (let mmNext '(()
                       (ifn (cdr (pop '"Mm"))
                          (quit 'mm (list "No other method" "N" "A" "K"))
                          (apply @ "A") ) )
            (apply (cdr (pop '"Mm")) "A") ) ) ) )

(de mmDef (N P)
   (let L (get N 'mm)
      (ifn L
         (put N 'mm (list P))
         (use X
               (NIL L (put N 'mm (mmSort (cons P (get N 'mm)))))
               (setq X (pop 'L))
               (T (= (car P) (car X)) (con X (cdr P))) ) ) ) ) )

(de dmm A
   (let (N (car A) AA (cadr A) B (cddr A))
      (unless (val N)
         (def N (fill '(@ (pass mmApply 'N)) 'N)) ) # bug shared!?
      (mmDef N (cons
                  (mapcar '((X) (when (pair X) (cdr X))) AA)
                  (cons (mapcar '((X) (if (pair X) (car X) X)) AA) B) ) ) ) )

(de mmLt (L R)
   (use (LH RH)
         (NIL (or L R))
         (setq LH (pop 'L) RH (pop 'R))
         (T (and (not LH) RH) NIL)
          (when LH
             (or (not RH) (and (<> LH RH) (subclass? LH RH))) )
          T ) ) ) )

(de mmSort (L)
   (order L '((L R) (mmLt (car L) (car R)))) )

(de order (Lst Lt) # TODO built-in or better sort log(N) instead of N^2
   (let Q NIL
      (for X Lst
         (let S 0
            (for Y Lst
               (when (apply Lt NIL (car X) (car Y))
                  (inc 'S) ) )
            (push 'Q (cons S X))) )
      (flip (mapcar cdr (by car sort Q))) ) )

We introduced the predicate 'subclass?' which uses depth-first search in the superclass tree. We also modified slightly 'mmApplicable', 'mmApply' and 'mmDef' functions. The new functions 'mmLt', 'order' and 'mmSort' are for dispatch table ordering.

We can use the code as follows:

(class +Asteroid)
(class +Spaceship)

(setq A (new '(+Asteroid)))
(setq S (new '(+Spaceship)))

(dmm collide< (X Y)
   (prin "?? Bang, what happened? ")
   (println X Y) )

(dmm collide< ((X +Asteroid) (Y +Asteroid))
   (prin "AA Look at the beautiful fireworks! ")
   (println X Y) )

(dmm collide< ((X +Asteroid) (Y +Spaceship))
   (prin "AS Is it fatal? ")
   (println X Y) )

(dmm collide< ((X +Spaceship) (Y +Asteroid))
   (prin "SA Is it fatal? ")
   (println X Y) )

(dmm collide< ((X +Spaceship) (Y +Spaceship))
   (prin "SS Who's fault was it? ")
   (println X Y) )

(collide< A A) # AA Look at the beautiful fireworks! $519672026 $519672026
(collide< A S) # AS Is it fatal? $519672026 $519672040
(collide< S A) # SA Is it fatal? $519672040 $519672026
(collide< S S) # SS Who's fault was it? $519672040 $519672040
(collide< A 1) # ?? Bang, what happened? $519672026 1
(collide< 2 A) # ?? Bang, what happened? 2 $519672026
(collide< S 3) # ?? Bang, what happened? $519672040 3
(collide< 4 S) # ?? Bang, what happened? 4 $519672040
(collide< 5 T) # ?? Bang, what happened? 5 T
(collide< T)   # ?? Bang, what happened? T NIL
(collide<)     # ?? Bang, what happened? NIL NIL

…or try the bank account example from PAIP:

(class +Acc)                        # account
(class +LtdAcc +Acc)                # account with withdrawal limit

(dmm withdraw< ((A +Acc) Amt)
   (with A
      (if (< (: bal) Amt)
         (dec (:: bal) Amt) ) ) )

(dmm withdraw< ((A +LtdAcc) Amt)
   (with A
      (if (< (: lim) Amt)
         (mmNext) ) ) )

(setq F (new '(+Acc) 'nm "Fred" 'bal 5000 'irt 6))
(setq G (new '(+LtdAcc) 'nm "George" 'bal 4000 'irt 5 'lim 1000))

(withdraw< F 6000) # -> insufficient-funds
(withdraw< F 1000) # -> 4000
(withdraw< G 2000) # -> over-limit
(withdraw< G 200)  # -> 3800

There are some improvements that could be implemented:

<ul> <li>Add before, after and around methods as in CLOS</li> <li>Undefine methods</li> <li>Dispatch on value, e.g. (dmm collide\< ((A +Asteroid) (B (= "Bill"))) …).</li> <li>Add other types to dispatch on, e.g. atom pair num sym etc., e.g. (dmm collide\< ((A +Asteroid) (B pair)) …)</li> <li>more types: num sym atom pair T NIL null etc.</li> </ul>

Note that we cannot add a dispatch on any user defined predicate as we would not be able to sort the dispatch table automatically.

9 non-blocking

http://logand.com/sw/nb contains code for non-blocking I/O functions for picoLisp.

9.1 Low level C functions

As part of the http://logand.com/sw/nb code, there are a few C functions to enable non-blocking i/o in PicoLisp:

(eagain) -> 'cnt

Return the value of errno -EAGAIN (as negative number) which "roughly" says that the data/file descriptor is not ready for i/o.

(block 'any 'flg) -> 'flg

Set the socket any to blocking (flg=T) or non-blocking (flg=NIL) mode.

(rdx 'lst 'cnt1 ['cnt2]) -> 'cnt|NIL

Read cnt1 number of bytes into the list lst starting from cnt2 element. Return number of bytes read, -errno (as negative number) on error.

(wrx 'lst 'cnt1 ['cnt2]) -> 'cnt|NIL

Write cnt1 bytes from the list lst starting from cnt2 element. Return number of bytes written, -errno (as negative number) on error.

9.2 Examples

There are a few examples of asynchronous servers using non-blocking i/o as part of the part of http://logand.com/sw/nb code.

9.2.1 Chat server

http://logand.com/sw/nb/chat.l To run the server, load the file chat.l and call (chat 4444). The server will run in background so your REPL will still be available. Then connect a few clients, e.g.

$ telnet localhost 4444

Lets discuss the implementation details.

The server handles requests coming on port 4444 and creates an asynchronous handler for each accepted request. If you type something in one client, the message will get sent to all connected clients.

So we need to keep track of all connected clients (list of handlers in *H variable).

(off *H)

Then we define our asynchronous handler. I settled for a class but it could be a \{closure} or simply functions with the necessary data (socket and write queue) kept in the elements of *H list.

(class +Handler)
# s [w]

(dm T (S)
   (=: s S)
   (=: w (new))
   (push '*H (cons S This)) )

(dm rm> ()
   (prinl "q " (: s))
   (task (: s))
   (close (: s))
   (setq *H (delq (assoc (: s) *H) *H)) )

The constructor T initializes the handler and adds it into the *H list. The method rm> closes the socket and removes the handler from the *H list.

Next, we need to handle non-blocking i/o. This is the tricky bit. We do not write the output messages directly as we would do with normal blocking i/o functions but we must write them in chunks that a client is able to read immediately (without blocking our server).

The actual write is deferred till a suitable moment. Until then, messages wait in a FIFO queue of each handler (client).

(dm wr> (Who Msg)
   (fifo (: w) (cons Who Msg)) )

The cb> method is the callback handling events on client sockets. If a message arrives on a client socket, the data is read in and put into write queues of all handlers. The handlers then tries to write all queued messages to the connected clients.

To avoid generating too much unnecessary garbage, we have a fixed size buffer shared by all handlers. Note that we are running the server in one process only so no locking or synchronization is ever required.

(setq *N 1024 *B (need *N)) # read buffer

(dm cb> ()
   (block (: s) NIL)
   (let N (in (: s) (rdx *B *N))
      (prinl "r " (: s) " " N)
         ((gt0 N) (for H *H (wr> (cdr H) S (head N *B))))
         ((= N (eagain)))
         (T (rm> This)) ) )
   (for H *H (fl> (cdr H))) )

(dm fl> ()
   (use X
         (and (setq X (cadr (val (: w)))) # peek head
              (let (S (cdr X)
                    M (length S)
                    N (out (: s) (wrx S M)))
                 (prinl "w " (: s) " " N "/" M)
                 (when (gt0 N)
                    (if (<= M N)
                       (fifo (: w))
                       (set (cdr (val (: w))) (tail (- M N) S)) ) ) ) ) ) ) )

The fl> method does the actual writing of a message from the write queue of a handler. It writes all data the client is ready to read.

The last thing we need is to start up the server and accept incoming connections:

(de chat (Port)
   (task (port Port)
      (when (accept @)
         (task @
            This (new '(+Handler) @)
            (cb> This) ) ) ) )

10 picoLisp

10.1 Getting started

The author and maintainer is \{Alexander Burger} so the best starting point is his http://www.software-lab.de/down.html website. The http://www.mail-archive.com/picolisp@software-lab.de picoLisp mailing list is a good source of information.

10.3 Some code

\{Jon Kleiser}: \{http://folk.uio.no/jkleiser/pico/ gl, china and other stuff}

\{Randall Dow}: \{http://randix.net/sources.html simple templating website generator}

\{Tomas Hlavaty}: \{http://logand.com/mplisp miniPicoLisp with FFI}

\{http://logand.com/gtk gtk-server example}

10.4 Libraries and other code

\{http://www.opengl.org OpenGL}: 2D and 3D computer graphics API. \{Jon Kleiser} wrote \{http://folk.uio.no/jkleiser/pico/ OpenGL bindings}. Based on his code, \{http://logand.com/mplisp miniPicoLisp with FFI} generates most of the original OpenGL code and it should be quite easy to add more foreign functions.

\{http://www.gtk.org Gtk}: A cross-platform widget toolkit for creating graphical user interfaces. The prototype picoLisp binding is part of the \{http://logand.com/mplisp miniPicoLisp with FFI}. The code is not complete, however. You can create UI but it is not possible to connect signals as callbacks have not been implemented (yet). In the mean time, if you want to use Gtk with picoLisp, you can try using \{http://www.gtk-server.org gtk-server}. There is a very minimal \{http://logand.com/gtk gtk-server example} available.

\{http://buddy.wiki.sourceforge.net BuDDy}: A Binary Decision Diagram Package. The picoLisp binding is part of the \{http://logand.com/mplisp miniPicoLisp with FFI}

\{http://en.wikipedia.org/wiki/Java_(programminglanguage) Java}: A programming language. picoLisp used to talk to Java but the code is now \{http://www.software-lab.de/down.html defunct}.

10.5 Code snippets

\{GeoIP}: Geographical IP look up.

\{trampoline}: tail call optimisation, control flow

\{non-blocking}: i/o and simple echo server

\{multimethods}: multiple dispatch

\{ToDo} put some useful stuff here instead of the things bellow

\{ToDo} \{classes}

\{ToDo} \{gui}


11 picoWiki

Welcome to picoWiki.

picoWiki is a PicoLisp \{http://en.wikipedia.org/wiki/Wiki wiki}. It contains links to and resources about PicoLisp and software implemented in PicoLisp.

Please use \{Sandbox} for experiments and learning the \{Formatting} markup.

11.1 TODO

<ul> <li>useful content</li> <li>search</li> <li>more markup</li> <li>diff</li> <li>lisp code and command-line : -></li> <li>RSS last two weeks or so only?</li> <li>XHTML validate</li> <li>case insensitive page name in url</li> </ul>

11.2 Bugs

<ul> <li>para between list items breaks ul, ol</li> <li>fix caching, the header should be the change time of the file, optional GET?</li> <li>fix implausible date in RSS feed</li> </ul>

11.3 Credits

picoWiki was more than inspired by \{http://www.cliki.net CLiki}.

12 rewriteUrl

The picoLisp built-in web server follows specific url conventions. Sometimes, it is useful to:

<ol> <li>have url format under control, i.e. having custom & "nice" application specific urls</li> <li>allow and collect any query parameters automatically</li> </ol>

The following code shows a sample web server which servers files from @publichtml/ directory (relative to picoLisp home, which is not a problem as you can always create a symlink), e.g. http://localhost:8080/index.html is served from @publichtml/index.html file.

(load "ext.l" "lib/http.l")

(de rewriteUrl (U)
   (chop (pack "public_html/" U)) )

# I'd recommend the following version of 'rewriteUrl'.
# It avoids the 'chop' following a 'pack' by using a constant
# pre-chopped "public..".
# (de rewriteUrl (U)
#    (append '`(chop "public_html/") (chop U)) )

(patch http
   '(if (<> *ConId *SesId) @X)
   (append '(if (<> *ConId *SesId))
      (list (car @X))
      (list '(setq @U (rewriteUrl @U)))
      (cdr @X) ) )

(redef http @
   (off *HtVars)
   (pass http) )

(redef _htSet @
   (push '*HtVars (cons (pack (next)) (next))) )

(allowed ("public_html/") "@start")

(de start ()
   (html 0 "Hello" NIL NIL
      "Hello World!" ) )

(server 8080 "@start")

Note that @start is never called but it could be if we used a more sophisticated rewriting function.

\{ToDo} SSI

13 +RteField.txt

Rich Text Formatting GUI element for \{+Blob} with text data. Uses \{http://tinymce.moxiecode.com TinyMCE} for the JavaScript part.

This class is not part of the PicoLisp distribution.

(class +RteField +BlobField)

(dm show> ("Var")
   (let (Id (pack *Form '- (: id))
         OnL ,"Plain text »"
         OffL ,"Rich formatting »")
      (<div> NIL
         (<div> (list (cons 'id (pack Id "d"))))
         (super "Var"))
      (prin "<script>rteSwitch('" Id "'," (if (able) "true" "false")
         ",'" OnL "','" OffL "');</script>")))


(class +C +Entity)
(rel r (+Blob))
(gui '(+RteField) '(r : home obj) 70 25)

See \{http://logand.com/ed/ed.js} for the JavaScript part.

14 trampoline

PicoLisp does not support tail call optimisation. However, there is a way around it, using a \{http://en.wikipedia.org/wiki/Trampoline_(computers) trampoline}:

Used in some LISP implementations, a trampoline is a loop that iteratively invokes thunk-returning functions. A single trampoline is sufficient to express all control transfers of a program; a program so expressed is trampolined or in "trampolined style"; converting a program to trampolined style is trampolining. Trampolined functions can be used to implement tail recursive function calls in stack-oriented languages.

First, lets see the final code and then discuss how to use and derive it:

(def 'continue list)

(de done (R)
   (cons NIL R) )

(de trampoline (F A)
   (use R
         (NIL (car (setq R (apply F A))) (cdr R))
         (setq F (car R) A (cdr R)) ) ) )

There was a \{http://www.mail-archive.com/picolisp@software-lab.de/msg00136.html discussion} on the topic suggesting that it is better to rewrite your recursive code using loops but there could be cases when recursion is a better abstraction.

Lets suppose we have the following, mutually recursive functions (the example was taken from \{http://bc.tech.coop/blog/040613.html here}):

(de f1 (N)
   (println N)
   (if (= N 0)
      (println 'Blastoff!)
      (f2 N)))

(de f2 (N)
   (f1 (- N 1)))

(f1 90000) # => crash

If we call 'f1' with sufficiently big number, picoLisp interpreter runs out of stack eventually. This need not to be so. We can rewrite the code as follows:

(de f1 (N)
   (println N)
   (if (= N 0)
      (throw 'done 'Blastoff!)
      (list f2 N)))

(de f2 (N)
   (list f1 (- N 1)))

(de run-trampolined (F A)
   (catch 'done
         (let R (apply F A)
            (setq F (car R) A (cdr R)) ) ) ) )

: (run-trampolined f1 '(9000))
-> Blastoff!

We could add some syntactic sugar:

(def 'continue list)

(de done (R)
   (throw 'trampoline R))

(de trampoline (F A)
   (catch 'trampoline
         (let R (apply F A)
            (setq F (car R) A (cdr R)) ) ) ) )

(de f1 (N)
   (println N)
   (if (= N 0)
      (done 'Blastoff!)
      (continue f2 N)))

(de f2 (N)
   (continue f1 (- N 1)))

(run-trampolined f1 '(9000))

Now lets try usual factorial example:

(de fact (N)
   (if (< N 2)
      (* N (fact (- N 1)))))

(fact 5) # => 120

We can rewrite 'fact' using tail call recursion:

(de fact/ (N R)
   (default R 1)
   (if (< N 2)
      (fact/ (- N 1) (* N R))))

(fact/ 5)

and now we are ready for a trampoline:

(de fact/t (N R)
   (default R 1)
   (if (< N 2)
      (done R)
      (continue fact/t (- N 1) (* N R))))

(trampoline fact/t '(5))

Actually, we do not need throw/catch:

(def 'continue list)

(de done (R)
   (cons NIL R))

(de trampoline (F A)
   (use R
         (NIL (car (setq R (apply F A))) (cdr R))
         (setq F (car R) A (cdr R)) ) ) )

What happens if we call 'fact/t' directly without 'trampoline'?

: (fact/t 5)
-> (((N R)
     (default R 1)
     (if (< N 2)
        (done R)
        (continue fact/t (- N 1) (* N R))))
    4 5)

In other words, we managed to split the original recursive call into a sequence of partial computations. The result above shows what function is to be called next (after the first iteration) and what arguments should be used.

As the \{http://en.wikipedia.org/wiki/Trampoline_(computers) Wikipedia article} suggests, a single trampoline is sufficient to express all control transfers of a program. That gives us very powerful tool which could be useful in some cases, especially when used together with the power of lisp to make higher level syntactic abstractions.

\{ToDo} continuations

\{ToDo} cps

\{ToDo} light-weight processes

\{ToDo} asynchronous server

Author: Tomas Hlavaty <tom at logand.com>

Date: 2013-03-31 18:30:03 CEST