picolisp-3.1.5.2.orig/0000755000000000000000000000000012265263724013150 5ustar rootrootpicolisp-3.1.5.2.orig/doc/0000755000000000000000000000000012265263724013715 5ustar rootrootpicolisp-3.1.5.2.orig/doc/ref_.html0000644000000000000000000004300412265263724015517 0ustar rootroot Other

Other

(! . exe) -> any
Low level breakpoint function: The current execution environment is saved and the I/O channels are redirected to the console. Then exe is displayed, and a read-eval-print-loop is entered (with ! as its prompt character), to evaluate expressions and examine the current program environment. An empty input line terminates the read-eval-print-loop, the environment and I/O channels are restored, and the result of exe is returned. ! is normally inserted into existing programs with the debug function. See also e, ^ and *Dbg.

: (de foo (N) (and (println 1) (! println N) (println 2)))
-> foo
: (foo 7)
1                 # Executed '(println 1)'
(println N)       # Entered breakpoint
! N               # Examine the value of 'N'
-> 7
! (e)             # Evaluate '^', i.e. (println N)
7
-> 7
! (e @)           # Evaluate '@' -> the result of '(println 1)'
-> 1
!                 # Empty line: continue
7                 # Executed '(println N)'
2                 # Executed '(println 2)'
-> 2
($ sym|lst lst . prg) -> any
Low level trace function: The first argument sym|lst is printed to the console with a proper indentation, followed by a colon :. If a function is traced, the first argument is the function symbol, else if a method is traced, it is a cons pair of message and class. The second argument lst should be a list of symbols, identical to the function's argument list. The current values of these symbols are printed, followed by a newline. Then prg is executed, and its return value printed in a similar way (this time with an equals sign = instead of a colon) and returned. $ is normally inserted into existing programs with the trace function.

: (de foo (A B) ($ foo (A B) (* A B)))
-> foo
: (foo 3 4)
 foo : 3 4        # Function entry, arguments 3 and 4
 foo = 12         # Function exit, return value 12
-> 12
($dat 'sym1 ['sym2]) -> dat
Converts a string sym1 in ISO format to a date, optionally using a delimiter character sym2. See also dat$, $tim, strDat and expDat.

: ($dat "20070601")
-> 733134
: ($dat "2007-06-01" "-")
-> 733134
($tim 'sym) -> tim
Converts a string to a time. The minutes and seconds are optional and default to zero. See also tim$ and $dat.

: (time ($tim "10:57:56"))
-> (10 57 56)
: (time ($tim "10:57"))
-> (10 57 0)
: (time ($tim "10"))
-> (10 0 0)
(% 'num ..) -> num
Returns the remainder from the divisions of successive num arguments. The sign of the result is that of the first argument. When one of the arguments evaluates to NIL, it is returned immediately. See also / and */ .

: (% 17 5)
-> 2
: (% -17 5)  # Sign is that of the first argument
-> -2
: (% 5 2)
-> 1
: (% 15 10)
-> 5
: (% 15 10 2)  # (% 15 10) -> 5, then (% 5 2) -> 1
-> 1
(& 'num ..) -> num
Returns the bitwise AND of all num arguments. When one of the arguments evaluates to NIL, it is returned immediately. See also |, x| and bit?.

: (& 6 3)
-> 2
: (& 7 3 1)
-> 1
(* 'num ..) -> num
Returns the product of all num arguments. When one of the arguments evaluates to NIL, it is returned immediately. See also /, */, + and -.

: (* 1 2 3)
-> 6
: (* 5 3 2 2)
-> 60
(** 'num1 'num2) -> num
Integer exponentiation: Returns num1 to the power of num2.

: (** 2 3)
-> 8
: (** 100 100)
-> 10000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000000000000000000000000000000000000000
00000000000000000000000000000000000000000000
(*/ 'num1 ['num2 ..] 'num3) -> num
Returns the product of num1 and all following num2 arguments, divided by the num3 argument. The result is rounded to the nearest integer value. When one of the arguments evaluates to NIL, it is returned immediately. Note that */ is especially useful for fixed point arithmetic, by multiplying with (or dividing by) the scale factor. See also *, /, +, - and sqrt.

: (*/ 3 4 2)
-> 6
: (*/ 1234 2 10)
-> 247
: (*/ 100 6)
-> 17

: (scl 2)
-> 2
: (format (*/ 3.0 1.5 1.0) *Scl)
-> "4.50"
(+ 'num ..) -> num
Returns the sum of all num arguments. When one of the arguments evaluates to NIL, it is returned immediately. See also inc, -, *, / and */.

: (+ 1 2 3)
-> 6
(- 'num ..) -> num
Returns the difference of the first num argument and all following arguments. If only a single argument is given, it is negated. When one of the arguments evaluates to NIL, it is returned immediately. See also dec, +, *, / and */.

: (- 7)
-> -7
: (- 7 2 1)
-> 4
(-> any [num]) -> any
Searches for the value of any (typically a Pilog variable, or an expression of variables) at top level (or level num) in the current environment. See also prove and unify.

: (? (append (1 2 3) (4 5 6) @X) (^ @ (println 'X '= (-> @X))))
X = (1 2 3 4 5 6)
 @X=(1 2 3 4 5 6)
-> NIL
(/ 'num ..) -> num
Returns the first num argument successively divided by all following arguments. When one of the arguments evaluates to NIL, it is returned immediately. See also *, */, %, + and -.

: (/ 12 3)
-> 4
: (/ 60 -3 2 2)
-> -5
(: sym|0 [sym1|cnt ..]) -> any
Fetches a value any from the properties of a symbol, or from a list, by applying the get algorithm to This and the following arguments. Used typically in methods or with bodies. (: ..) is equivalent to (; This ..). See also ;, =: and ::.

: (put 'X 'a 1)
-> 1
: (with 'X (: a))
-> 1
(:: sym [sym1|cnt .. sym2]) -> var
Fetches a property for a property key sym or sym2 from a symbol. That symbol is This (if no other arguments are given), or a symbol found by applying the get algorithm to This and the following arguments. The property (the cons pair, not just its value) is returned, suitable for direct (destructive) manipulations with functions expecting a var argument. Used typically in methods or with bodies. See also =:, prop and :.

: (with 'X (=: cnt 0) (inc (:: cnt)) (: cnt))
-> 1
(; 'sym1|lst [sym2|cnt ..]) -> any
Fetches a value any from the properties of a symbol, or from a list, by applying the get algorithm to sym1|lst and the following arguments. See also :, =: and ::.

: (put 'A 'a 1)
-> 1
: (put 'A 'b 'B)
-> B
: (put 'B 'c 7)
-> 7
: (; 'A a)
-> 1
: (; 'A b c)
-> 7
(< 'any ..) -> flg
Returns T when all arguments any are in strictly increasing order. See also Comparing.

: (< 3 4)
-> T
: (< 'a 'b 'c)
-> T
: (< 999 'a)
-> T
(<= 'any ..) -> flg
Returns T when all arguments any are in strictly non-decreasing order. See also Comparing.

: (<= 3 3)
-> T
: (<= 1 2 3)
-> T
: (<= "abc" "abc" "def")
-> T
(<> 'any ..) -> flg
Returns T when not all any arguments are equal (structure equality). (<> 'any ..) is equivalent to (not (= 'any ..)). See also Comparing.

: (<> 'a 'b)
-> T
: (<> 'a 'b 'b)
-> T
: (<> 'a 'a 'a)
-> NIL
(= 'any ..) -> flg
Returns T when all any arguments are equal (structure equality). See also Comparing.

: (= 6 (* 1 2 3))
-> T
: (= "a" "a")
-> T
: (== "a" "a")
-> T
: (= (1 (2) 3) (1 (2) 3))
-> T
(=0 'any) -> 0 | NIL
Returns 0 when any is a number with value zero. See also n0, lt0, le0, ge0 and gt0.

: (=0 (- 6 3 2 1))
-> 0
: (=0 'a)
-> NIL
(=: sym|0 [sym1|cnt .. sym2|0] 'any)
Stores a new value any for a property key sym or sym2 (or in the symbol value for zero) in a symbol. That symbol is This (if no other arguments are given), or a symbol found by applying the get algorithm to This and the following arguments. Used typically in methods or with bodies. See also put, : and ::.

: (with 'X (=: a 1) (=: b 2))
-> 2
: (get 'X 'a)
-> 1
: (get 'X 'b)
-> 2
(== 'any ..) -> flg
Returns T when all any arguments are the same (pointer equality). See also n== and Comparing.

: (== 'a 'a)
-> T
: (== 'NIL NIL (val NIL) (car NIL) (cdr NIL))
-> T
: (== (1 2 3) (1 2 3))
-> NIL
(==== ['sym ..]) -> NIL
Close the current transient scope by clearing the transient index. All transient symbols become hidden and inaccessible by the reader. Then any optional sym arguments are (re-)inserted into the transient index. See also extern and intern.

: (setq S "abc")           # Read "abc"
-> "abc"
: (== S "abc")             # Read again, get the same symbol
-> T
: (====)                   # Close scope
-> NIL
: (== S "abc")             # Read again, get another symbol
-> NIL
(=T 'any) -> flg
Returns T when any is the symbol T. (=T X) is equivalent to (== T X). See also nT.

: (=T 0)
-> NIL
: (=T "T")
-> NIL
: (=T T)
-> T
(> 'any ..) -> flg
Returns T when all arguments any are in strictly decreasing order. See also Comparing.

: (> 4 3)
-> T
: (> 'A 999)
-> T
(>= 'any ..) -> flg
Returns T when all arguments any are in strictly non-increasing order. See also Comparing.

: (>= 'A 999)
-> T
: (>= 3 2 2 1)
-> T
(>> 'cnt 'num) -> num
Shifts right the num argument by cnt bit-positions. If cnt is negative, a corresponding left shift is performed.

: (>> 1 8)
-> 4
: (>> 3 16)
-> 2
: (>> -3 16)
-> 128
: (>> -1 -16)
-> -32
(? [sym ..] [pat 'any ..] . lst) -> flg
Top-level function for interactive Pilog queries. ? is a non-evaluating front-end to the query function. It displays each result, waits for console input, and terminates when a non-empty line is entered. If a preceding list of (non-pattern-) symbols is given, they will be taken as rules to be traced by prove. The list of variable/value pairs is passed to goal for an initial Pilog environment. See also pilog and solve.

: (? (append (a b c) (d e f) @X))
 @X=(a b c d e f)
-> NIL

: (? (append @X @Y (a b c)))
 @X=NIL @Y=(a b c)
 @X=(a) @Y=(b c)
 @X=(a b) @Y=(c)
 @X=(a b c) @Y=NIL
-> NIL

: (? (append @X @Y (a b c)))
 @X=NIL @Y=(a b c).                    # Stopped
-> NIL

: (? append (append @X @Y (a b c)))    # Trace 'append'
1 (append NIL (a b c) (a b c))
 @X=NIL @Y=(a b c)
2 (append (a . @X) @Y (a b c))
1 (append NIL (b c) (b c))
 @X=(a) @Y=(b c).                      # Stopped
-> NIL
@
Holds the result of the last top level expression in the current read-eval-print loop, or the result of the conditional expression during the evaluation of flow functions (see @ Result). When @ is used as a formal parameter in lambda expressions, it denotes a variable number of evaluated arguments.
@@
Holds the result of the second last top level expression in the current read-eval-print loop (see @ Result).
@@@
Holds the result of the third last top level expression in the current read-eval-print loop (see @ Result).
^
Holds the currently executed expression during a breakpoint or an error. See also debug, !, e and *Dbg.

: (* (+ 3 4) (/ 7 0))
!? (/ 7 0)
Div/0
? ^
-> (/ 7 0)
(| 'num ..) -> num
Returns the bitwise OR of all num arguments. When one of the arguments evaluates to NIL, it is returned immediately. See also x|, & and bit?.

: (| 1 2)
-> 3
: (| 1 2 4 8)
-> 15
picolisp-3.1.5.2.orig/doc/rlook.html0000644000000000000000000000251012265263724015727 0ustar rootroot PicoLisp RefLook picolisp-3.1.5.2.orig/doc/select.html0000644000000000000000000004363312265263724016073 0ustar rootroot The 'select' Predicate abu@software-lab.de

The 'select' Predicate

(c) Software Lab. Alexander Burger

The Pilog select/3 predicate is rather complex, and quite different from other predicates. This document tries to explain it in detail, and shows some typical use cases.


Syntax

select takes at least three arguments:

We will describe these arguments in the following, but demonstrate them first on a concrete example.


First Example

The examples in this document will use the demo application in "app/*.l" (see also "A Minimal Complete Application"). To get an interactive prompt, start it as


$ pil app/main.l -main +
:

As ever, you can terminate the interpreter by hitting Ctrl-D.

For a first, typical example, let's write a complete call to solve that returns a list of articles with numbers between 1 and 4, which contain "Part" in their description, and have a price less than 100:


(let (Nr (1 . 4)  Nm Part  Pr '(NIL . 100.00))
   (solve
      (quote
         @Nr Nr
         @Nm Nm
         @Pr Pr
         (select (@Item)
            ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr))
               (range @Nr @Item nr)
               (part @Nm @Item nm)
               (range @Pr @Item pr) ) )
      @Item ) )

This expression will return, with the default database setup of "app/init.l", a list of exactly one item ({3-2}), the item with the number 2.

The let statement assigns values to the search parameters for number Nr, description Nm and price Pr. The Pilog query (the first argument to solve) passes these values to the Pilog variables @Nr, @Nm and @Pr. Ranges of values are always specified by cons pairs, so (1 . 4) includes the numbers 1 through 4, while (NIL . 100.00) includes prices from minus infinite up to one hundred.

The list of unification variables is


   (@Item)

The list of generator clauses is


      ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr))

The filter clauses are


         (range @Nr @Item nr)
         (part @Nm @Item nm)
         (range @Pr @Item pr)


Unification Variables

As stated above, the first argument to select should be a list of variables. These variables communicate values (via unify) from the select environment to the enclosing Pilog environment.

The first variable in this list (@Item in the above example) is mandatory, it takes the direct return value of select. Additional optional variables may be unified by clauses in the body of select, and return further values.


Generator Clauses

The second argument to select is a list of "generator clauses". Each of these clauses specifies some kind of database B-Tree +index, to be traversed by select, step by step, where each step returns a suitable single database object. In the simplest case, they consist like here just of a relation name (e.g. nr), a class (e.g. +Item), an optional hook specifier (not in this example), and a pattern (values or ranges, e.g. (1 . 4) or "Part").

The generator clauses are the core of 'select'. In some way, they behave analog to or/2, as each of them generates a sequence of values. However, the generator clauses behave different, as they will not generate an exhaustive set of values upon backtracking, one after the other, where the next gets its turn when the previous one is exhausted. Instead, all clauses will generate their values quasi-parallel, with a built-in optimization so that successful clauses will be called with a higher probability. "Successful" means that the returned values successfully pass select's filter clauses.


B-Tree Stepping

In its basic form, a generator clause is equivalent to the db/3 predicate, stepping through a single B-Tree. The clause


(nr +Item @Nr)

generates the same values as would be produced by a stand-alone Pilog clause


(db nr +Item @Nr @Item)

as can be seen in the following two calls:


: (? (db nr +Item (1 . 4) @Item))
 @Item={3-1}
 @Item={3-2}
 @Item={3-3}
 @Item={3-4}
-> NIL
: (? (select (@Item) ((nr +Item (1 . 4)))))
 @Item={3-1}
 @Item={3-2}
 @Item={3-3}
 @Item={3-4}
-> NIL


Interaction of Generator Clauses

select is mostly useful if more than one generator clause is involved. The tree search parameters of all clauses are meant to form a logical AND. Only those objects should be returned, for which all search parameters (and the associated filter clauses) are valid. As soon as one of the clauses finishes stepping through its database (sub)tree, the whole call to select will terminate, because further values returned from other generator clauses cannot be part of the result set.

Therefore, select would find all results most quickly if it could simply call only the generator clause with the smallest (sub)tree. Unfortunately, this is usually not known in advance. It depends on the distribution of the data in the database, and on the search parameters to each generator clause.

Instead, select single-steps each generator clause in turn, in a round-robin scheme, applies the filter clauses to each generated object, and re-arranges the order of generator clauses so that the more successful clauses will be preferred. This process usually converges quickly and efficiently.


Combined Indexes

A generator clause can also combine several (similar) indexes into a single one. Then the clause is written actually as a list of clauses.

For example, a generator clause to search for a customer by phone number is


(tel +CuSu @Tel)
If we want to search for a customer without knowing whether a given number is a normal or a mobile phone number, then a combined generator clause searching both index trees could look like

((tel +CuSu @Tel  mob +CuSu @Tel))

The generator will first traverse all matching entries in the +Ref tree of the tel relation, and then, when these are exhausted, all matching entries in the mob index tree.


Indirect Object Associations

But generator clauses are not limited to the direct B-Tree interaction of db/3. They can also traverse trees of associated objects, and then follow +Link / +Joint relations, or tree relations like +Ref to arrive at database objects with a type suitable for return values from select.

To locate appropriate objects from associated objects, the generator clause can contain - in addition to the standard relation/class/pattern specification (see Generator Clauses above) - an arbitrary number of association specifiers. Each association specifier can be

  1. A symbol. Then a +Link or +Joint will be followed, or a +List of those will be traversed to locate appropriate objects.
  2. A list. Then this list should hold a relation and a class (and an optional hook) which specify some B-Tree +index to be traversed to locate appropriate objects.
In this way, a single generator clause can cause the traversal of a tree of object relations to generate the desired sequence of objects. An example can be found in "app/gui.l", in the 'choOrd' function which implements the search dialog for +Ord (order) objects. Orders can be searched for order number and date, customer name and city, item description and supplier name:

(select (@@)
   ((nr +Ord @Nr) (dat +Ord @Dat)
      (nm +CuSu @Cus (cus +Ord))
      (ort +CuSu @Ort (cus +Ord))
      (nm +Item @Item (itm +Pos) ord)
      (nm +CuSu @Sup (sup +Item) (itm +Pos) ord) )

While (nr +Ord @Nr) and (dat +Ord @Dat) are direct index traversals, (nm +CuSu @Cus (cus +Ord)) iterates the nm (name) index of customers/suppliers +CuSu, and then follows the +Ref +Link of the cus relation to the orders. The same applies to the search for city names via ort.

The most complex example is (nm +CuSu @Sup (sup +Item) (itm +Pos) ord), where the supplier name is searched in the nm tree of +CuSu, then the +Ref tree (sup +Item) tree is followed to locate items of that supplier, then all positions for those items are found using (itm +Pos), and finally the ord +Joint is followed to arrive at the order object(s).


Nested Pilog Queries

In the most general case, a generator clause can be an arbitrary Pilog query. Often this is a query to a database on a remote machine, using the remote/2 predicate, or some other resource not accessible via database indexes, like iterating a +List of +Links or +Joints.

Syntactically, such a generator clause is recognized by the fact that its CAR is a Pilog variable to denote the return value.

The second argument is a list of Pilog variables to communicate values (via unify) from the surrounding select environment.

The third argument is the actual list of clauses for the nested query.

Finally, an arbitrary number of association specifiers may follow, as described in the Indirect Object Associations section.

We can illustrate this with a somewhat useless (but simple) example, which replaces the standard generators for item number and supplier name


(select (@Item)
   (
      (nr +Item @Nr)
      (nm +CuSu @Sup (sup +Item))
   )
   ...

with the equivalent form


(select (@Item)
   (
      (@A (@Nr) ((db nr +Item @Nr @A)))
      (@B (@Sup) ((db nm +CuSu @Sup @B)) (sup +Item))
   )

That is, a query with the db/3 tree iteration predicate is used to generate appropriate values.


Filter Clauses

The generator clauses produce - independent from each other - lots of objects, which match the patterns of individual generator clauses, but not necessarily the desired result set of the total select call. Therefore, the filter clauses are needed to retain the good, and throw away the bad objects. In addition, they give feedback to the generator for optimizing its traversal priorities (as described in Generator Clauses).

select then collects all objects which passed through the filters into a unique list, to avoid duplicates which would otherwise appear, because most objects can be found by more than one generator clause.

Technically, the filters are normal Pilog clauses, which just happen to be evaluated in the context of select. Arbitrary Pilog predicates can be used, though there exist some predicates (e.g. isa/2, same/3, bool/3, range/3, head/3, fold/3, part/3 or tolr/3) especially suited for that task.


A Little Report

Assume we want to know how many pieces of item #2 were sold in the year 2007. Then we must find all +Pos (position) objects referring to that item and at the same time belonging to orders of the year 2007 (see the class definition for +Pos in "app/er.l"). The number of sold pieces is then in the cnt property of the +Pos objects.

As shown in the complete select below, we will hold the item number in the variable @Nr and the date range for the year in @Year.

Now, all positions referred by item #2 can be found by the generator clause


(nr +Item @Nr (itm +Pos))

and all positions sold in 2007 can be found by


(dat +Ord @Year pos)

However, the combination of both generator clauses


(select (@Pos)
   ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos)) )

will probably generate too many results, namely all positions with item #3 OR from the year 2007. Thus, we need two filter clauses. With them, the full search expression will be:


(?
   @Nr 2                                                 # Item number
   @Year (cons (date 2007 1 1) (date 2007 12 31))        # Date range 2007
   (select (@Pos)
      ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos))   # Generator clauses
      (same @Nr @Pos itm nr)                             # Filter item number
      (range @Year @Pos ord dat) ) )                     # Filter order date

For completeness, let's calculate the total count of sold items:


(let Cnt 0     # Counter variable
   (pilog
      (quote
         @Nr 2
         @Year (cons (date 2007 1 1) (date 2007 12 31))
         (select (@Pos)
            ((nr +Item @Nr (itm +Pos)) (dat +Ord @Year pos))
            (same @Nr @Pos itm nr)
            (range @Year @Pos ord dat) ) )
      (inc 'Cnt (get @Pos 'cnt)) )  # Increment total count
   Cnt )  # Return count


Filter Predicates

As mentioned under Filter Clauses, some predicates exists mainly for select filtering.

Some of these predicates are of general use: isa/2 can be used to check for a type, same/3 checks for a definite vaue, bool/3 looks if the value is non-NIL. These predicates are rather independent of the +relation type.

range/3 checks whether a value is within a given range. This could be used with any +relation type, but typically it will be used for numeric (+Number) or time ( +Date and +Time) relations.

Other predicates make only sense in the context of a certain +relation type:

picolisp-3.1.5.2.orig/doc/shape.l0000644000000000000000000000157112265263724015176 0ustar rootroot# 25jun07abu # (c) Software Lab. Alexander Burger # The Shape base class (class +Shape) # x y (dm T (X Y) (=: x X) (=: y Y) ) (dm move> (DX DY) (inc (:: x) DX) (inc (:: y) DY) ) # The Rectangle class (class +Rectangle +Shape) # dx dy (dm T (X Y DX DY) (super X Y) (=: dx DX) (=: dy DY) ) (dm area> () (* (: dx) (: dy)) ) (dm perimeter> () (* 2 (+ (: dx) (: dy))) ) (dm draw> () (drawRect (: x) (: y) (: dx) (: dy)) ) # Hypothetical function 'drawRect' # The Circle class (class +Circle +Shape) # r (dm T (X Y R) (super X Y) (=: r R) ) (dm area> () (*/ (: r) (: r) 31415927 10000000) ) (dm perimeter> () (*/ 2 (: r) 31415927 10000000) ) (dm draw> () (drawCircle (: x) (: y) (: r)) ) # Hypothetical function 'drawCircle' # The Fixed prefix class (class +Fixed) (dm move> (DX DY)) # A do-nothing method # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/doc/structures0000644000000000000000000000475412265263724016075 0ustar rootroot Primary data types: xxxxxxxxxxxxxxxxxxxxxxxxxxxxx010 Number xxxxxxxxxxxxxxxxxxxxxxxxxxxxx100 Symbol xxxxxxxxxxxxxxxxxxxxxxxxxxxxx000 Pair Number | V +-----+-----+ | DIG | | | +-----+--+--+ | V +-----+-----+ | DIG | | | +-----+--+--+ | V +-----+-----+ | DIG | / | +-----+-----+ Pair | V +-----+-----+ | CAR | CDR | +-----+-----+ Symbol | V +-----+-----+ | | | VAL | +--+--+-----+ | tail | V name +-----+-----+ +-----+-----+ +-----+-----+ +-----+-----+ | | | ---+---> | KEY | ---+---> | | | ---+---> |'cba'| / | +--+--+-----+ +-----+-----+ +--+--+-----+ +-----+-----+ | | V V +-----+-----+ +-----+-----+ | VAL | KEY | | VAL | KEY | +-----+-----+ +-----+-----+ NIL: / | V +-----+-----+-----+-----+ | / | / | / | / | +-----+--+--+-----+-----+ External Symbols: +-------------+-+-------------+-+----+ Block 0: | Free 0| Next 0| << | +-------------+-+-------------+-+----+ 0 BLK 2*Blk+1 +-------------+-+ Free: | Link 0| +-------------+-+ 0 +-------------+-+---- ID-Block: | Link 1| Data +-------------+-+---- 0 BLK +-------------+-+---- EXT-Block: | Link n| Data +-------------+-+---- 0 BLK Assumptions: - 8 bits per byte - word: sizeof(void*) == sizeof(unsigned long) - word2: sizeof(unsigned long long) == 2 * sizeof(unsigned long) - gcc Functions aligned to 4-byte boundaries Zero- or variable-length arrays Conditionals with Omitted Operands Unused argument attributes Noreturn attributes picolisp-3.1.5.2.orig/doc/toc.html0000644000000000000000000000156012265263724015372 0ustar rootroot PicoLisp Doc TOC

PicoLisp Docs

picolisp-3.1.5.2.orig/doc/travel0000644000000000000000000000271512265263724015142 0ustar rootroot Rheine Osnabrueck O-----------42----------O-----------------48-------------+ | | | |39 +--------+ | | | |43 | | +---51---+ | | | | | Warendorf Guetersloh | O-----+-----28--------+-O-+--------27--------O-----16----O Bielefeld | Muenster | | | | | | | | | +-----+ | | +--+ | +--+ | | | | | | | Rheda | | | | 27| |27 +-24---O---10---+ | | |46 +---+ | | |31 | | | | +--+-----+ | |39 | | | Beckum | | | | | +--------------O---11---O-----24-+ | |32 | | Ahlen | | | | | | | 26| | +--------+-----+ | +-----38----+ | | | | +---27---O---------------41---------------+ Soest Paderborn picolisp-3.1.5.2.orig/doc/tut.html0000644000000000000000000025344612265263724015435 0ustar rootroot PicoLisp Tutorial abu@software-lab.de

A PicoLisp Tutorial

(c) Software Lab. Alexander Burger

About this document

This document demonstrates some aspects of the PicoLisp system in detail and example. For a general description of the PicoLisp kernel please look at the PicoLisp Reference.

This is not a Lisp tutorial, as it assumes some basic knowledge of programming, Lisp, and even PicoLisp. Please read these sections before coming back here: Introduction and The PicoLisp Machine. This tutorial concentrates on the specificities of PicoLisp, and its differences with other Lisp dialects.

Now let's start

If not stated otherwise, all examples assume that PicoLisp was started from a global installation (see Installation) from the shell prompt as


$ pil +
:

It loads the PicoLisp base system and the debugging environment, and waits for you to enter input lines at the interpreter prompt (:). You can terminate the interpreter and return to the shell at any time, by either hitting the Ctrl-D key, or by executing the function (bye).

Please note that special handling is done during character input. This one is incompatible with rlwrap for example but is more powerful.

If you prefer to use Emacs, please use the picolisp-mode bundled in the "el/" directory (that is "@lib/el" for a local installation, or some system dependent directory for a global installation).

If you feel that you absolutely have to use an IDE, rlwrap or another input front-end, please create an empty "~/.pil/editor" file. This effectively disables the command line editor. Note that in this case, however, you will not have the TAB symbol completion feature available during command line editing.

Table of content

If you are new to PicoLisp, you might want to read the following sections in the given order, as some of them assume knowledge about previous ones. Otherwise just jump anywhere you are interested in.


Command Line Editing

PicoLisp permanently reads input from the current input channel (i.e. the console in interactive mode), evaluates it, and prints the result to the current output channel. This is called a "read-eval-print-loop" (REPL).

'vi'-style

This is the default line editor, as it needs less system resources and works also on dumb terminals. It is similar to - though simpler than - the 'vi' edit modes of the 'korn' and 'bash' shells. For an analog 'emacs' style editor, please see below.

It is very helpful - though not absolutely necessary - when you know how to use the vi text editor.

To alleviate the task of manual line input, a command line editor is provided which is similar to (though much simpler than) the readline feature of the bash shell. Only a subset of the vi mode is supported, which is restricted to single-key commands (the "real" vi supports multi-key commands and the modification of most commands with count prefixes). It is loaded at startup in debug mode, you find its source in "lib/led.l".

You can enter lines in the normal way, correcting mistypes with the BACKSPACE key, and terminating them with the ENTER key. This is the Insert Mode.

If you hit ESC, you get into Command Mode. Now you can navigate horizontally in the current input line, or vertically in the history of previously entered lines, with key commands borrowed from the vi editor (only h, j, k and l and not arrows). Note, however, that there is always only a single line visible.

Let's say you did some calculation


: (* (+ 2 3) (- 7 2))
-> 25
:

If you want to repeat a modified version of this command, using 8 instead of 7, you don't have to re-type the whole command, but type

Then you hit ENTER to execute the modified line. Instead of jumping to the 7 with the "find" command, you may also type l (move "right") repeatedly till you reach the correct position.

The key commands in the Command Mode are listed below. Some commands change the mode back to Insert Mode as indicated in parentheses. Deleting or changing a "word" take either the current atom (number or symbol), or a whole expression when the cursor is at a left parenthesis.

Notes:

The following two key-combinations work both in Insert and Command Mode:

Besides these two keys, in Insert Mode only the following keys have a special meaning:

'emacs'-style

You can switch the command line editor to an 'emacs' style, if you call the function (em) (i.e. without arguments). A single call is enough. Alternatively, you could invoke PicoLisp at least once with the -em command line option


$ pil -em +
:

The style will be remembered in a file "~/.pil/editor", and used in all subsequent PicoLisp sessions.

To switch back to 'vi' style, call (vi), use the -vi command line option, or simply remove "~/.pil/editor".

Conclusion

Please take some time to experiment and to get used to command line editing. It will make life much easier in the future :-)


Browsing

PicoLisp provides some functionality for inspecting pieces of data and code within the running system.

Basic tools

The really basic tools are of course available and their name alone is enough to know: print, size ...

But you will appreciate some more powerful tools like:

Inspect a symbol with show

The most commonly used tool is probably the show function. It takes a symbolic argument, and shows the symbol's name (if any), followed by its value, and then the contents of the property list on the following lines (assignment of such things to a symbol can be done with set, setq, and put).


: (setq A '(This is the value))  # Set the value of 'A'
-> (This is the value)
: (put 'A 'key1 'val1)           # Store property 'key1'
-> val1
: (put 'A 'key2 'val2)           # and 'key2'
-> val2
: (show 'A)                      # Now 'show' the symbol 'A'
A (This is the value)
   key2 val2
   key1 val1
-> A

show accepts an arbitrary number of arguments which are processed according to the rules of get, resulting in a symbol which is showed then.


: (put 'B 'a 'A)        # Put 'A' under the 'a'-property of 'B'
-> A
: (setq Lst '(A B C))   # Create a list with 'B' as second argument
-> (A B C)
: (show Lst 2 'a)       # Show the property 'a of the 2nd element of 'Lst'
A (This is the value)   # (which is 'A' again)
   key2 val2
   key1 val1
-> A

Inspect and edit with edit

Similar to show is edit. It takes an arbitrary number of symbolic arguments, writes them to a temporary file in a format similar to show, and starts the vim editor with that file.


: (edit 'A 'B)

The vim window will look like


A (This is the value)
key1 val1
key2 val2

(********)

B NIL
a A  # (This is the value)

(********)

Now you can modify values or properties. You should not touch the parenthesized asterisks, as they serve as delimiters. If you position the cursor on the first character of a symbol name and type 'K' ("Keyword lookup"), the editor will be restarted with that symbol added to the editor window. 'Q' (for "Quit") will bring you back to the previous view.

edit is also very useful to browse in a database. You can follow the links between objects with 'K', and even - e.g. for low-level repairs - modify the data (but only if you are really sure about what you are doing, and don't forget to commit when you are done).

Built-in pretty print with pp

The pretty-print function pp takes a symbol that has a function defined (or two symbols that specify message and class for a method definition), and displays that definition in a formatted and indented way.


: (pp 'pretty)
(de pretty (X N . @)
   (setq N (abs (space (or N 0))))
   (while (args)
      (printsp (next)) )
   (if (or (atom X) (>= 12 (size X)))
      (print X)
      (while (== 'quote (car X))
         (prin "'")
         (pop 'X) )
      (let Z X
         (prin "(")
         (cond
            ((and (pair (car X)) (> (size @) 12))
               (pretty (pop 'X) (- -3 N)) )
            ((memq (print (pop 'X)) *PP)
               (cond
                  ((memq (car Z) *PP1)
                     (if (and (pair (car X)) (pair (cdar X)))
                        (when (>= 12 (size (car X)))
                           (space)
                           (print (pop 'X)) )
                        (space)
                        (print (pop 'X))
                        (when (or (atom (car X)) (>= 12 (size (car X))))
                           (space)
                           (print (pop 'X)) ) ) )
                  ((memq (car Z) *PP2)
                     (inc 'N 3)
                     (loop
                        (prinl)
                        (pretty (cadr X) N (car X))
                        (NIL (setq X (cddr X)) (space)) ) )
                  ((or (atom (car X)) (>= 12 (size (car X))))
                     (space)
                     (print (pop 'X)) ) ) )
            ((and (memq (car Z) *PP3) (>= 12 (size (head 2 X))))
               (space)
               (print (pop 'X) (pop 'X)) ) )
         (when X
            (loop
               (T (== Z X) (prin " ."))
               (T (atom X) (prin " . ") (print X))
               (prinl)
               (pretty (pop 'X) (+ 3 N))
               (NIL X) )
            (space) )
         (prin ")") ) ) )
-> pretty

The style is the same as we use in source files:

Inspect elements one by one with more

more is a simple tool that displays the elements of a list one by one. It stops after each element and waits for input. If you just hit ENTER, more continues with the next element, otherwise (usually I type a dot (.) followed by ENTER) it terminates.


: (more (1 2 3 4 5 6))
1                          # Hit ENTER
2.                         # Hit '.' and ENTER
-> T                       # stopped

Optionally more takes a function as a second argument and applies that function to each element (instead of the default print). Here, often show or pp (see below) is used.


: (more '(A B))            # Step through 'A' and 'B'
A
B
-> NIL
: (more '(A B) show)       # Step through 'A' and 'B' with 'show'
A (This is the value)      # showing 'A'
   key2 val2
   key1 val1
                           # Hit ENTER
B NIL                      # showing 'B'
   a A
-> NIL

Search through available symbols with what

The what function returns a list of all internal symbols in the system which match a given pattern (with '@' wildcard characters).


: (what "prin@")
-> (prin print prinl print> printsp println)

Search through values or properties of symbols with who

The function who returns "who contains that", i.e. a list of symbols that contain a given argument somewhere in their value or property list.


: (who 'print)
-> (query pretty pp msg more "edit" view show (print> . +Date) rules select
(print> . +relation))

A dotted pair indicates either a method definition or a property entry. So (print> . +relation) denotes the print> method of the +relation class.

who can be conveniently combined with more and pp:


: (more (who 'print) pp)
(de query ("Q" "Dbg")  # Pretty-print these functions one by one
   (use "R"
      (loop
         (NIL (prove "Q" "Dbg"))
         (T (=T (setq "R" @)) T)
         (for X "R"
            (space)
            (print (car X))
            (print '=)
            (print (cdr X))
            (flush) )
         (T (line)) ) ) )

(de pretty (X N . @)
   ...

The argument to who may also be a pattern list (see match):


: (who '(print @ (val @)))
-> (show)

: (more (who '(% @ 7)) pp)
(de day (Dat Lst)
   (get
      (or Lst *DayFmt)
      (inc (% (inc Dat) 7)) ) )

(de _week (Dat)
   (/ (- Dat (% (inc Dat) 7)) 7) )

Find what classes can accept a given message with can

The function can returns a list which indicates which classes can accept a given message. Again, this list is suitable for iteration with pp:


: (can 'del>)                                   # Which classes accept 'del>' ?
-> ((del> . +List) (del> . +Entity) (del> . +relation))

: (more (can 'del>) pp)                         # Inspect the methods with 'pp'
(dm (del> . +List) (Obj Old Val)
   (and ((<> Old Val) (delete Val Old)) )

(dm (del> . +Entity) (Var Val)
   (when
      (and
         Val
         (has> (meta This Var) Val (get This Var)) )
      (let Old (get This Var)
         (rel>
            (meta This Var)
            This
            Old
            (put This Var (del> (meta This Var) This Old @)) )
         (when (asoq Var (meta This 'Aux))
            (relAux This Var Old (cdr @)) )
         (upd> This Var Old) ) ) )

(dm (del> . +relation) (Obj Old Val)
   (and ((<> Old Val) Val) )

Inspect dependencies with dep

dep shows the dependencies in a class hierarchy. That is, for a given class it displays the tree of its (super)class(es) above it, and the tree of its subclasses below it.

To view the complete hierarchy of input fields, we start with the root class +relation:


: (dep '+relation)
+relation
   +Bag
   +Any
   +Blob
   +Link
      +Joint
   +Bool
   +Symbol
      +String
   +Number
      +Time
      +Date
-> +relation

If we are interested in +Link:


: (dep '+Link)
   +relation
+Link
   +Joint
-> +Link

This says that +Link is a subclass of +relation, and has a single subclass (+Joint).


Defining Functions

Most of the time during programming is spent defining functions (or methods). In the following we will concentrate on functions, but most will be true for methods as well except for using dm instead of de.

Functions with no argument

The notorious "Hello world" function must be defined:


: (de hello ()
   (prinl "Hello world") )
-> hello

The () in the first line indicates a function without arguments. The body of the function is in the second line, consisting of a single statement. The last line is the return value of de, which here is the defined symbol. From now on we will omit the return values of examples when they are unimportant.

Now you can call this function this way:


: (hello)
Hello world

Functions with one argument

A function with an argument might be defined this way:


: (de hello (X)
   (prinl "Hello " X) )
# hello redefined
-> hello

PicoLisp informs you that you have just redefined the function. This might be a useful warning in case you forgot that a bound symbol with that name already existed.


: (hello "world")
Hello world

: (hello "Alex")
Hello Alex

Preventing arguments evaluation and variable number of arguments

Normally, PicoLisp evaluates the arguments before it passes them to a function:


: (hello (+ 1 2 3))
Hello 6

: (setq A 1  B 2)       # Set 'A' to 1 and 'B' to 2
-> 2
: (de foo (X Y)         # 'foo' returns the list of its arguments
   (list X Y) )
-> foo
: (foo A B)             # Now call 'foo' with 'A' and 'B'
-> (1 2)                # -> We get a list of 1 and 2, the values of 'A' and 'B'

In some cases you don't want that. For some functions (setq for example) it is better if the function gets all arguments unevaluated, and can decide for itself what to do with them.

For such cases you do not define the function with a list of parameters, but give it a single atomic parameter instead. PicoLisp will then bind all (unevaluated) arguments as a list to that parameter.


: (de foo X
   (list (car X) (cadr X)) )        # 'foo' lists the first two arguments

: (foo A B)                         # Now call it again
-> (A B)                            # -> We don't get '(1 2)', but '(A B)'

: (de foo X
   (list (car X) (eval (cadr X))) ) # Now evaluate only the second argument

: (foo A B)
-> (A 2)                            # -> We get '(A 2)'

Mixing evaluated arguments and variable number of unevaluated arguments

As a logical consequence, you can combine these principles. To define a function with 2 evaluated and an arbitrary number of unevaluated arguments:


: (de foo (X Y . Z)     # Evaluate only the first two args
   (list X Y Z) )

: (foo A B C D E)
-> (1 2 (C D E))        # -> Get the value of 'A' and 'B' and the remaining list

Variable number of evaluated arguments

More common, in fact, is the case where you want to pass an arbitrary number of evaluated arguments to a function. For that, PicoLisp recognizes the symbol @ as a single atomic parameter and remembers all evaluated arguments in an internal frame. This frame can then be accessed sequentially with the args, next, arg and rest functions.


: (de foo @
   (list (next) (next)) )     # Get the first two arguments

: (foo A B)
-> (1 2)

Again, this can be combined:


: (de foo (X Y . @)
   (list X Y (next) (next)) ) # 'X' and 'Y' are fixed arguments

: (foo A B (+ 3 4) (* 3 4))
-> (1 2 7 12)                 # All arguments are evaluated

These examples are not very useful, because the advantage of a variable number of arguments is not used. A function that prints all its evaluated numeric arguments, each on a line followed by its squared value:


: (de foo @
   (while (args)                            # Check if there are some args left
      (println (next) (* (arg) (arg))) ) )  # Call the last arg (next) returned

: (foo (+ 2 3) (- 7 1) 1234 (* 9 9))
5 25
6 36
1234 1522756
81 6561
-> 6561

This next example shows the behaviour of args and rest:


: (de foo @
   (while (args)
      (next)
      (println (arg) (args) (rest)) ) )
: (foo 1 2 3)
1 T (2 3)
2 T (3)
3 NIL NIL

Finally, it is possible to pass all these evaluated arguments to another function, using pass:


: (de foo @
   (pass println 9 8 7)       # First print all arguments preceded by 9, 8, 7
   (pass + 9 8 7) )           # Then add all these values

: (foo (+ 2 3) (- 7 1) 1234 (* 9 9))
9 8 7 5 6 1234 81             # Printing ...
-> 1350                       # Return the result

Anonymous functions without the lambda keyword

There's no distinction between code and data in PicoLisp, quote will do what you want (see also this FAQ entry).

: ((quote (X) (* X X)) 9)
-> 81

: (setq f '((X) (* X X)))  # This is equivalent to (de f (X) (* X X))
-> ((X) (* X X))
: f
-> ((X) (* X X))
: (f 3)
-> 9


Debugging

There are two major ways to debug functions (and methods) at runtime: Tracing and single-stepping.

In this section we will use the REPL to explore the debugging facilities, but in the Scripting section, you will learn how to launch PicoLisp scripts with some selected functions debugged:


$ pil app/file1.l -"trace 'foo" -main -"debug 'bar" app/file2.l +

Tracing

Tracing means letting functions of interest print their name and arguments when they are entered, and their name again and the return value when they are exited.

For demonstration, let's define the unavoidable factorial function (or just load the file "@doc/fun.l"):


(de fact (N)
   (if (=0 N)
      1
      (* N (fact (dec N))) ) )

With trace we can put it in trace mode:


: (trace 'fact)
-> fact

Calling fact now will display its execution trace.


: (fact 3)
 fact : 3
  fact : 2
   fact : 1
    fact : 0
    fact = 1
   fact = 1
  fact = 2
 fact = 6
-> 6

As can be seen here, each level of function call will indent by an additional space. Upon function entry, the name is separated from the arguments with a colon (:), and upon function exit with an equals sign (=) from the return value.

trace works by modifying the function body, so generally it works only for functions defined as lists (lambda expressions, see Evaluation). Tracing a C-function is possible, however, when it is a function that evaluates all its arguments.

So let's trace the functions =0 and *:


: (trace '=0)
-> =0
: (trace '*)
-> *

If we call fact again, we see the additional output:


: (fact 3)
 fact : 3
  =0 : 3
  =0 = NIL
  fact : 2
   =0 : 2
   =0 = NIL
   fact : 1
    =0 : 1
    =0 = NIL
    fact : 0
     =0 : 0
     =0 = 0
    fact = 1
    * : 1 1
    * = 1
   fact = 1
   * : 2 1
   * = 2
  fact = 2
  * : 3 2
  * = 6
 fact = 6
-> 6

To reset a function to its untraced state, call untrace:


: (untrace 'fact)
-> fact
: (untrace '=0)
-> =0
: (untrace '*)
-> *

or simply use mapc:


: (mapc untrace '(fact =0 *))
-> *

Single-stepping

Single-stepping means to execute a function step by step, giving the programmer an opportunity to look more closely at what is happening. The function debug inserts a breakpoint into each top-level expression of a function. When the function is called, it stops at each breakpoint, displays the expression it is about to execute next (this expression is also stored into the global variable ^) and enters a read-eval-loop. The programmer can then

Thus, in the simplest case, single-stepping consists of just hitting ENTER repeatedly to step through the function.

To try it out, let's look at the stamp system function. You may need to have a look at

to understand this definition.

: (pp 'stamp)
(de stamp (Dat Tim)
   (and (=T Dat) (setq Dat (date T)))
   (default Dat (date) Tim (time T))
   (pack (dat$ Dat "-") " " (tim$ Tim T)) )
-> stamp

: (debug 'stamp)                       # Debug it
-> T
: (stamp)                              # Call it again
(and (=T Dat) (setq Dat (date T)))     # stopped at first expression
!                                      # ENTER
(default Dat (date) Tim (time T))      # second expression
!                                      # ENTER
(pack (dat$ Dat "-") " " (tim$ ...     # third expression
! Tim                                  # inspect 'Tim' variable
-> 41908
! (time Tim)                           # convert it
-> (11 38 28)
!                                      # ENTER
-> "2004-10-29 11:38:28"               # done, as there are only 3 expressions

Now we execute it again, but this time we want to look at what's happening inside the second expression.


: (stamp)                              # Call it again
(and (=T Dat) (setq Dat (date T)))
!                                      # ENTER
(default Dat (date) Tim (time T))
!                                      # ENTER
(pack (dat$ Dat "-") " " (tim$ ...     # here we want to look closer
! (d)                                  # debug this expression
-> T
!                                      # ENTER
(dat$ Dat "-")                         # stopped at first subexpression
! (e)                                  # evaluate it
-> "2004-10-29"
!                                      # ENTER
(tim$ Tim T)                           # stopped at second subexpression
! (e)                                  # evaluate it
-> "11:40:44"
!                                      # ENTER
-> "2004-10-29 11:40:44"               # done

The breakpoints still remain in the function body. We can see them when we pretty-print it:


: (pp 'stamp)
(de stamp (Dat Tim)
   (! and (=T Dat) (setq Dat (date T)))
   (! default Dat (date) Tim (time T))
   (! pack
      (! dat$ Dat "-")
      " "
      (! tim$ Tim T) ) )
-> stamp

To reset the function to its normal state, call unbug:


: (unbug 'stamp)

Often, you will not want to single-step a whole function. Just use edit (see above) to insert a single breakpoint (the exclamation mark followed by a space) as CAR of an expression, and run your program. Execution will then stop there as described above; you can inspect the environment and continue execution with ENTER when you are done.


Functional I/O

Input and output in PicoLisp is functional, in the sense that there are not variables assigned to file descriptors, which need then to be passed to I/O functions for reading, writing and closing. Instead, these functions operate on implicit input and output channels, which are created and maintained as dynamic environments.

Standard input and standard output are the default channels. Try reading a single expression:


: (read)
(a b c)        # Console input
-> (a b c)

To read from a file, we redirect the input with in. Note that comments and whitespace are automatically skipped by read:


: (in "@doc/fun.l" (read))
-> (de fact (N) (if (=0 N) 1 (* N (fact (dec N)))))

The skip function can also be used directly. To get the first non-white character in the file with char:


: (in "@doc/fun.l" (skip "#") (char))
-> "("

from searches through the input stream for given patterns. Typically, this is not done with Lisp source files (there are better ways), but for a simple example let's extract all items immediately following fact in the file,


: (in "@doc/fun.l" (while (from "fact ") (println (read))))
(N)
(dec N)

or the word following "(de " with till:


: (in "@doc/fun.l" (from "(de ") (till " " T)))
-> "fact"

With line, a line of characters is read, either into a single transient symbol (the type used by PicoLisp for strings),


: (in "@doc/tut.html" (line T))
-> "<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://..."

or into a list of symbols (characters):


: (in "@doc/tut.html" (line))
-> ("<" "!" "D" "O" "C" "T" "Y" "P" "E" " " "H" "T" "M" "L" ...

line is typically used to read tabular data from a file. Additional arguments can split the line into fixed-width fields, as described in the reference manual. If, however, the data are of variable width, delimited by some special character, the split function can be used to extract the fields. A typical way to import the contents of such a file is:


(load "@lib/import.l")

(in '("bin/utf2" "importFile.txt")              # Pipe: Convert to UTF-8
   (until (eof)                                 # Process whole file
      (let L (split (line) "^I")                # TAB-delimited data
         ... use 'getStr', 'getNum' etc ...     # process them

Some more examples with echo:


(in "a"                                         # Copy the first 40 Bytes
   (out "b"                                     # from file "a" to file "b"
      (echo 40) ) )

(in "@doc/tut.html"                             # Show the HTTP-header
   (line)
   (echo "<body>") )

(out "file.mac"                                 # Convert to Macintosh
   (in "file.txt"                               # from Unix or DOS format:
      (while (char)
         (prin
            (case @
               ("^M" NIL)                       # ignore CR
               ("^J" "^M")                      # convert CR to LF
               (T @) ) ) ) ) )                  # otherwise no change

(out "c"                                        # Merge the contents of "a"
   (in "b"                                      # and "b" into "c"
      (in "a"
         (while (read)                          # Read an item from "a",
            (println @ (in -1 (read))) ) ) ) )  # print it with an item from "b"


Scripting

There are two possibilities to get the PicoLisp interpreter into doing useful work: via command line arguments, or as a stand-alone script.

Command line arguments for the PicoLisp interpreter

The command line can specify either files for execution, or arbitrary Lisp expressions for direct evaluation (see Invocation): if an argument starts with a hyphen, it is evaluated, otherwise it is loaded as a file. A typical invocation might look like:


$ pil app/file1.l -main app/file2.l +

It loads the debugging environment, an application source file, calls the main function, and then loads another application source. In a typical development and debugging session, this line is often modified using the shell's history mechanisms, e.g. by inserting debugging statements:


$ pil app/file1.l -"trace 'foo" -main -"debug 'bar" app/file2.l +

Another convenience during debugging and testing is to put things into the command line (shell history) which would otherwise have to be done each time in the application's user interface:


$ pil app/file1.l -main app/file2.l -go -'login "name" "password"' +

The final production release of an application usually includes a shell script, which initializes the environment, does some bookkeeping and cleanup, and calls the application with a proper command line. It is no problem if the command line is long and complicated.

For small utility programs, however, this is overkill. Enter full PicoLisp scripts.

PicoLisp scripts

It is better to write a single executable file using the mechanisms of "interpreter files". If the first two characters in an executable file are "#!", the operating system kernel will pass this file to an interpreter program whose pathname is given in the first line (optionally followed by a single argument). This is fast and efficient, because the overhead of a subshell is avoided.

Let's assume you installed PicoLisp in the directory "/home/foo/picolisp/", and put links to the executable and the installation directory as:


$ ln -s /home/foo/picolisp /usr/lib/picolisp
$ ln -s /usr/lib/picolisp/bin/picolisp /usr/bin/picolisp
Then a simple hello-world script might look like:

#!/usr/bin/picolisp /usr/lib/picolisp/lib.l
(prinl "Hello world!")
(bye)

If you write this into a text file, and use chmod to set it to "executable", it can be executed like any other command. Note that (because # is the comment character in PicoLisp) the first line will not be interpreted, and you can still use that file as a normal command line argument to PicoLisp (useful during debugging).

Grab command line arguments from PicoLisp scripts

The fact that a hyphen causes evaluation of command line arguments can be used to simulate something like command line options. The following script defines two functions a and f, and then calls (load T) to process the rest of the command line (which otherwise would be ignored because of the (bye) statement):


#!/usr/bin/picolisp /usr/lib/picolisp/lib.l

(de a ()
   (println '-a '-> (opt)) )

(de f ()
   (println '-f '-> (opt)) )

(load T)
(bye)
(opt retrieves the next command line option)

Calling this script (let's say we named it "testOpts") gives:


$ ./testOpts -f abc
-f -> "abc"
$ ./testOpts -a xxx  -f yyy
-a -> "xxx"
-f -> "yyy"

We have to be aware of the fact, however, that the aggregation of arguments like


$ ./testOpts -axxx  -fyyy

or


$ ./testOpts -af yyy

cannot be achieved with this simple and general mechanism of command line processing.

Run scripts from arbitrary places on the host file system

Utilities are typically used outside the context of the PicoLisp environment. All examples above assumed that the current working directory is the PicoLisp installation directory, which is usually all right for applications developed in that environment. Command line file arguments like "app/file1.l" will be properly found.

To allow utilities to run in arbitrary places on the host file system, the concept of home directory substitution was introduced. The interpreter remembers internally at start-up the pathname of its first argument (usually "lib.l"), and substitutes any leading "@" character in subsequent file names with that pathname. Thus, to run the above example in some other place, simply write:


$ /home/foo/picolisp/pil @app/file1.l -main @app/file2.l +

that is, supply a full path name to the initial command (here 'p'), or put it into your PATH variable, and prefix each file which has to be loaded from the PicoLisp home directory with a @ character. "Normal" files (not prefixed by @) will be opened or created relative to the current working directory as usual.

Stand-alone scripts will often want to load additional modules from the PicoLisp environment, beyond the "lib.l" we provided in the first line of the hello-world script. Typically, at least a call to


(load "@lib/misc.l")

(note the home directory substitution) will be included near the beginning of the script.

As a more complete example, here is a script which extracts the date, name and size of the latest official PicoLisp release version from the download web site, and prints it to standard output:


#!/usr/bin/picolisp /usr/lib/picolisp/lib.l

(load "@lib/misc.l" "@lib/http.l")

(use (@Date @Name @Size)
   (when
      (match
         '(@Date ~(chop " - <a href=\"") @Name "\"" ">"
             @Name ~(chop "</a> (") @Size )
         (client "software-lab.de" 80 "down.html"
            (from "Release Archive")
            (from "<li>")
            (till ",") ) )
      (prinl @Name)
      (prinl @Date " -- " @Size) ) )

(bye)

Editing scripts

We recommend that you have a terminal window open, and try the examples by yourself. You may either type them in, directly to the PicoLisp interpreter, or edit a separate source file (e.g. "@doc/fun.l") in a second terminal window and load it into PicoLisp with


: (load "@doc/fun.l")

each time you have modified and saved it.

Editing scripts with vi

Once a function is loaded from a source file, you can call 'vim' directly on that function with


: (vi 'fact)

The function 'vi' opens the appropriate source file, and jumps to the right line where 'fact' is defined. When you modify it, you can simply call 'ld' to (re)load that source file


: (ld)


Objects and Classes

The PicoLisp object model is very simple, yet flexible and powerful. Objects as well as classes are both implemented as symbols. In fact, there is no formal difference between objects and classes; classes are more a conceptual design consideration in the head of the programmer than a physical reality.

Having said this, we declare that normally:

  1. A Class
  2. An Object

So the main difference between classes and objects is that the former ones usually are internal symbols. By convention, their names start with a '+'. Sometimes it makes sense, however, to create named objects (as global singletons, for example), or even anonymous classes.

Both classes and objects have a list in their value, consisting of method definitions (often empty for objects) and (super)class(es). And both classes and objects have local data in their property lists (often empty for classes). This implies, that any given object (as an instance of a class) may have private (object-local) methods defined.

It is rather difficult to contrive a simple OOP example. We constructed a hierarchy of geometric shapes, with a base class +Shape and two subclasses +Rectangle and +Circle.

The source code is included as "@doc/shape.l" in the PicoLisp distribution, so you don't have to type it in. Just load the file, or start it from the shell as:


$ pil @doc/shape.l +

Let's look at it piece by piece. Here's the base class:


(class +Shape)
# x y

(dm T (X Y)
   (=: x X)
   (=: y Y) )

(dm move> (DX DY)
   (inc (:: x) DX)
   (inc (:: y) DY) )

The first line '(class +Shape)' defines the symbol +Shape as a class without superclasses. The following method definitions will go to that class.

The comment '# x y' in the second line is just a convention, to indicate what instance variables (properties) that class uses. As PicoLisp is a dynamic language, a class can be extended at runtime with any number of properties, and there is nothing like a fixed object size or structure. This comment is a hint of what the programmer thinks to be essential and typical for that class. In the case of +Shape, x and y are the coordinates of the shape's origin.

Then we have two method definitions, using the keyword dm for "define method". The first method is special, in that its name is T. Each time a new object is created, and a method with that name is found in its class hierarchy, that method will be executed. Though this looks like a "constructor" in other programming languages, it should probably better be called "initializer". The T method of +Shape takes two arguments X and Y, and stores them in the object's property list.

The second method move> changes the object's origin by adding the offset values DX and DY to the object's origin.

Now to the first derived class:


(class +Rectangle +Shape)
# dx dy

(dm T (X Y DX DY)
   (super X Y)
   (=: dx DX)
   (=: dy DY) )

(dm area> ()
   (* (: dx) (: dy)) )

(dm perimeter> ()
   (* 2 (+ (: dx) (: dy))) )

(dm draw> ()
   (drawRect (: x) (: y) (: dx) (: dy)) )

+Rectangle is defined as a subclass of +Shape. The comment '# dx dy' indicates that +Rectangle has a width and a height in addition to the origin coordinates inherited from +Shape.

The T method passes the origin coordinates X and Y to the T method of the superclass (+Shape), then stores the width and height parameters into dx and dy.

Next we define the methods area> and perimeter> which do some obvious calculations, and a method draw> which is supposed to draw the shape on the screen by calling some hypothetical function drawRect.

Finally, we define a +Circle class in an analog way, postulating the hypothetical function drawCircle:


(class +Circle +Shape)
# r

(dm T (X Y R)
   (super X Y)
   (=: r R) )

(dm area> ()
   (*/ (: r) (: r) 31415927 10000000) )

(dm perimeter> ()
   (*/ 2 (: r) 31415927 10000000) )

(dm draw> ()
   (drawCircle (: x) (: y) (: r)) )

Now we can experiment with geometrical shapes. We create a rectangle at point (0,0) with a width of 30 and a height of 20, and keep it in the variable R:


: (setq R (new '(+Rectangle) 0 0 30 20))  # New rectangle
-> $134432824                             # returned anonymous symbol
: (show R)
$134432824 (+Rectangle)                   # Show the rectangle
   dy 20
   dx 30
   y 0
   x 0

We see that the symbol $134432824 has a list of classes '(+Rectangle)' in its value, and the coordinates, width and height in its property list.

Sending messages to that object


: (area> R)                               # Calculate area
-> 600
: (perimeter> R)                          # and perimeter
-> 100

will return the values for area and perimeter, respectively.

Then we move the object's origin:


: (move> R 10 5)                          # Move 10 right and 5 down
-> 5
: (show R)
$134432824 (+Rectangle)
   y 5                                    # Origin changed (0,0) -> (10,5)
   x 10
   dy 20
   dx 30

Though a method move> wasn't defined for the +Rectangle class, it is inherited from the +Shape superclass.

Similarly, we create and use a circle object:


: (setq C (new '(+Circle) 10 10 30))      # New circle
-> $134432607                             # returned anonymous symbol
: (show C)
$134432607 (+Circle)                      # Show the circle
   r 30
   y 10
   x 10
-> $134432607
: (area> C)                               # Calculate area
-> 2827
: (perimeter> C)                          # and perimeter
-> 188
: (move> C 10 5)                          # Move 10 right and 5 down
-> 15
: (show C)
$134432607 (+Circle)                      # Origin changed (10,10) -> (20,15)
   y 15
   x 20
   r 30

It is also easy to send messages to objects in a list:


: (mapcar 'area> (list R C))              # Get list of areas
-> (600 2827)
: (mapc
   '((Shape) (move> Shape 10 10))         # Move all 10 right and down
   (list R C) )
-> 25
: (show R)
$134431493 (+Rectangle)
   y 15
   x 20
   dy 20
   dx 30
-> $134431493
: (show C)
$134431523 (+Circle)
   y 25
   x 30
   r 30

Assume that we want to extend our shape system. From time to time, we need shapes that behave exactly like the ones above, but are tied to a fixed position. That is, they do not change their position even if they receive a move> message.

One solution would be to modify the move> method in the +Shape class to a no-operation. But this would require to duplicate the whole shape hierarchy (e.g. by defining +FixedShape, +FixedRectangle and +FixedCircle classes).

The PicoLisp Way is the use of Prefix Classes through multiple inheritance. It uses the fact that searching for method definitions is a depth-first, left-to-right search of the class tree. We define a prefix class:


: (class +Fixed)

(dm move> (DX DY))  # A do-nothing method

We can now create a fixed rectangle, and try to move it:


: (setq R (new '(+Fixed +Rectangle) 0 0 30 20))    # '+Fixed' prefix class
-> $134432881
: (move> R 10 5)                                   # Send 'move>' message
-> NIL
: (show R)
$134432881 (+Fixed +Rectangle)
   dy 20
   dx 30
   y 0                                             # Did not move!
   x 0

We see, prefix classes can surgically change the inheritance tree for selected objects or classes.

Alternatively, if fixed rectangles are needed often, it might make sense to define a new class +FixRect:


: (class +FixRect +Fixed +Rectangle)
-> +FixRect

and then use it directly:


: (setq R (new '(+FixRect) 0 0 30 20))
-> $13455710


Persistence (External Symbols)

PicoLisp has persistent objects built-in as a first class data type. With "first class" we mean not just the ability of being passed around, or returned from functions (that's a matter of course), but that they are a primary data type with their own interpreter tag bits. They are, in fact, a special type of symbolic atoms (called "External Symbols"), that happen to be read from pool file(s) when accessed, and written back automatically when modified.

In all other aspects they are normal symbols. They have a value, a property list and a name.

The name cannot be directly controlled by the programmer, as it is assigned when the symbol is created. It is an encoded index of the symbol's location in its database file. In its visual representation (output by the print functions and input by the read functions) it is surrounded by braces.

To make use of external symbols, you need to open a database first:


: (pool "test.db")

If a file with that name did not exist, it got created now. Also created at the same moment was {1}, the very first symbol in the file. This symbol is of great importance, and is handled especially by PicoLisp. Therefore a global constant *DB exists, which points to that symbol {1}, which should be used exclusively to access the symbol {1}, and which should never be modified by the programmer.


: *DB                   # The value of '*DB'
-> {1}                  # is '{1}'
: (show *DB)
{1} NIL                 # Value of '{1}' is NIL, property list empty

Now let's put something into the value and property list of {1}.


: (set *DB "Hello world")  # Set value of '{1}' to a transient symbol (string)
-> "Hello world"
: (put *DB 'a 1)           # Property 'a' to 1
-> 1
: (put *DB 'b 2)           # Property 'b' to 2
-> 2
: (show *DB)               # Now show the symbol '{1}'
{1} "Hello world"
   b 2
   a 1

Note that instead of '(set *DB "Hello world")', we might also have written '(setq {1} "Hello world")', and instead of '(put *DB 'a 1)' we might have written '(put '{1} 'a 1)'. This would have the same effect, but as a rule external symbols should never be be accessed literally in application programs, because the garbage collector might not be able to free these symbols and all symbols connected to them (and that might well be the whole database). It is all right, however, to access external symbols literally during interactive debugging.

Now we can create our first own external symbol. This can be done with new when a T argument is supplied:


: (new T)
-> {2}               # Got a new symbol

We store it in the database root {1}:


: (put *DB 'newSym '{2})   # Literal '{2}' (ok during debugging)
-> {2}
: (show *DB)
{1} "Hello world"
   newSym {2}              # '{2}' is now stored in '{1}'
   b 2
   a 1

Put some property value into '{2}'


: (put *DB 'newSym 'x 777) # Put 777 as 'x'-property of '{2}'
-> 777
: (show *DB 'newSym)       # Show '{2}' (indirectly)
{2} NIL
   x 777
-> {2}
: (show '{2})              # Show '{2}' (directly)
{2} NIL
   x 777

All modifications to - and creations of - external symbols done so far are not written to the database yet. We could call rollback (or simply exit PicoLisp) to undo all the changes. But as we want to keep them:


: (commit)           # Commit all changes
-> T
: (bye)              # Exit picolisp
$                    # back to the shell

So, the next time when ..


$ pil +                 # .. we start PicoLisp
: (pool "test.db")      # and open the database file,
-> T
: (show *DB)            # our two symbols are there again
{1} "Hello world"
   newSym {2}
   b 2
   a 1
-> {1}
: (show *DB 'newSym)
{2} NIL
   x 777
-> {2}


Database Programming

To a database, there is more than just persistence. PicoLisp includes an entity/relation class framework (see also Database) which allows a close mapping of the application data structure to the database.

We provided a simple yet complete database and GUI demo application in @doc/family.tgz and @doc/family64.tgz. Please unpack the first one if you use a 32-bit system, and the second one on a 64-bit system. Both contain the sources in @doc/family.l, and an initial database in the "family/" subdirectory.

To use it, please unpack it first in your current working directory, then start it up in the following way:


$ pil family.l -main +
:

This loads the source file, initializes the database by calling the main function, and prompts for user input.

The data model is small and simple. We define a class +Person and two subclasses +Man and +Woman.


(class +Person +Entity)

+Person is a subclass of the +Entity system class. Usually all objects in a database are of a direct or indirect subclass of +Entity. We can then define the relations to other data with the rel function.


(rel nm (+Need +Sn +Idx +String))      # Name

This defines the name property (nm) of a person. The first argument to rel is always a list of relation classes (subclasses of +relation), optionally followed by further arguments, causing relation daemon objects be created and stored in the class definition. These daemon objects control the entity's behavior later at runtime.

Relation daemons are a kind of metadata, controlling the interactions between entities, and maintaining database integrity. Like other classes, relation classes can be extended and refined, and in combination with proper prefix classes a fine-grained description of the application's structure can be produced.

Besides primitive relation classes, like +Number, +String or +Date, there are

In the case of the person's name (nm) above, the relation object is of type (+Need +Sn +Idx +String). Thus, the name of each person in this demo database is a mandatory attribute (+Need), searchable with the soundex algorithm (+Sn) and a full index (+Idx) of type +String.


(rel pa (+Joint) kids (+Man))          # Father
(rel ma (+Joint) kids (+Woman))        # Mother
(rel mate (+Joint) mate (+Person))     # Partner

The attributes for father (pa), Mother (ma) and partner (mate) are all defined as +Joints. A +Joint is probably the most powerful relation mechanism in PicoLisp; it establishes a bidirectional link between two objects.

The above declarations say that the father (pa) attribute points to an object of type +Man, and is joined with that object's kids attribute (which is a list of joints back to all his children).

The consistency of +Joints is maintained automatically by the relation daemons. These become active whenever a value is stored to a person's pa, ma, mate or kids property.

For example, interesting things happen when a person's mate is changed to a new value. Then the mate property of the old mate's object is cleared (she has no mate after that). Now when the person pointed to by the new value already has a mate, then that mate's mate property gets cleared, and the happy new two mates now get their joints both set correctly.

The programmer doesn't have to care about all that. He just declares these relations as +Joints.

The last four attributes of person objects are just static data:


(rel job (+Ref +String))               # Occupation
(rel dat (+Ref +Date))                 # Date of birth
(rel fin (+Ref +Date))                 # Date of death
(rel txt (+String))                    # Info

They are all searchable via a non-unique index (+Ref). Date values in PicoLisp are just numbers, representing the day number (starting first of March of the year zero).

A method url> is defined:


(dm url> ()
   (list "!person" '*ID This) )

It is needed later in the GUI, to cause a click on a link to switch to that object.

The classes +Man and +Woman are subclasses of +Person:


(class +Man +Person)
(rel kids (+List +Joint) pa (+Person)) # Children

(class +Woman +Person)
(rel kids (+List +Joint) ma (+Person)) # Children

They inherit everything from +Person, except for the kids attribute. This attribute joins with the pa or ma attribute of the child, depending on the parent's gender.

That's the whole data model for our demo database application.

It is followed by a call to dbs ("database sizes"). This call is optional. If it is not present, the whole database will reside in a single file, with a block size of 256 bytes. If it is given, it should specify a list of items, each having a number in its CAR, and a list in its CDR. The CARs taken together will be passed later to pool, causing an individual database file with that size to be created. The CDRs tell what entity classes (if an item is a symbol) or index trees (if an item is a list with a class in its CAR and a list of relations in its CDR) should be placed into that file.

A handful of access functions is provided, that know about database relationships and thus allows higher-level access modes to the external symbols in a database.

For one thing, the B-Trees created and maintained by the index daemons can be used directly. Though this is rarely done in a typical application, they form the base mechanisms of other access modes and should be understood first.

The function tree returns the tree structure for a given relation. To iterate over the whole tree, the functions iter and scan can be used:


(iter (tree 'dat '+Person) '((P) (println (datStr (get P 'dat)) (get P 'nm))))
"1770-08-03" "Friedrich Wilhelm III"
"1776-03-10" "Luise Augusta of Mecklenburg-Strelitz"
"1797-03-22" "Wilhelm I"
...

They take a function as the first argument. It will be applied to all objects found in the tree (to show only a part of the tree, an optional begin- and end-value can be supplied), producing a simple kind of report.

More useful is collect; it returns a list of all objects that fall into a range of index values:


: (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31))
-> ({2-M} {2-L} {2-E})

This returns all persons born between 1982 and 1988. Let's look at them with show:


: (more (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31)) show)
{2-M} (+Man)
   nm "William"
   dat 724023
   ma {2-K}
   pa {2-J}
   job "Heir to the throne"

{2-L} (+Man)
   nm "Henry"
   dat 724840
   ma {2-K}
   pa {2-J}
   job "Prince"

{2-E} (+Woman)
   nm "Beatrice"
   dat 726263
   ma {2-D}
   job "Princess"
   pa {2-B}

If you are only interested in a certain attribute, e.g. the name, you can return it directly:


: (collect 'dat '+Person (date 1982 1 1) (date 1988 12 31) 'nm)
-> ("William" "Henry" "Beatrice")

To find a single object in the database, the function db is used:


: (db 'nm '+Person "Edward")
-> {2-;}

If the key is not unique, additional arguments may be supplied:


: (db 'nm '+Person "Edward"  'job "Prince"  'dat (date 1964 3 10))
-> {2-;}

The programmer must know which combination of keys will suffice to specify the object uniquely. The tree search is performed using the first value ("Edward"), while all other attributes are used for filtering. Later, in the Pilog section, we will show how more general (and possibly more efficient) searches can be performed.


User Interface (GUI) Programming

The only types of GUI supported by the PicoLisp application server framework is either dynamically generated (but static by nature) HTML, or an interactive XHTML/CSS framework with the optional use of JavaScript.

Before we explain the GUI of our demo database application, we present a minimal example for a plain HTML-GUI in @doc/hello.l. Start the application server as:


$ pil @lib/http.l  --server 8080 @doc/hello.l  -wait

Now point your browser to the address 'http://localhost:8080'. You should see a very simple HTML page. You can come back here with the browser's BACK button.

You can call the page repeatedly, or concurrently with many clients if you like. To terminate the server, you have to send it a TERM signal (e.g. 'killall pil'), or type the Ctrl-C key in the console window.

In our demo database application, a single function person is responsible for the whole GUI. Again, please look at @doc/family.l.

To start the database and the application server, call:


$ pil family.l -main -go +

As before, the database is opened with main. The function go is also defined in @doc/family.l:


(de go ()
   (server 8080 "!person") )

It starts the HTTP server listening on TCP port 8080 (we did a similar thing in our minimal GUI example above directly on the command line). Each connect to that port will cause the function person to be invoked.

Again, point your browser to the address 'http://localhost:8080'.

You should see a new browser window with an input form created by the function person. We provided an initial database in "family/[1-4]". You can navigate through it by clicking on the pencil icons besides the input fields.

The chart with the children data can be scrolled using the down (v) and up (^) buttons.

A click on the button "Select" below opens a search dialog. You can scroll through the chart as before. Again, a click on a pencil will jump to that person. You can abort the dialog with a click on the "Cancel"-button.

The search fields in the upper part of the dialog allow a conjunctive search. If you enter "Edward" in the "Name" field and click "Search", you'll see all persons having the string "Edward" in their name. If you also enter "Duke" in the "Occupation" field, the result list will reduce to only two entries.

To create a new person, press the "New Man" or "New Woman" button. A new empty form will be displayed. Please type a name into the first field, and perhaps also an occupation and birth date. Any change of contents should be followed by a press on the "Done" button, though any other button (also Scroll or Select-buttons) will also do.

To assign a father attribute, you can either type a name directly into the field (if that person already exists in the database and you know the exact spelling), or use the "Set"-button (->) to the left of that field to open the search dialog. If you type in the name directly, your input must exactly match upper and lower case.

Alternatively, you may create a new person and assign a child in the "Children" chart.

On the console where you started PicoLisp, there should a prompt have appeared just when the browser connected. You can debug the application interactively while it is running. For example, the global variable *Top always contains the top level GUI object:


: (show *Top)

To take a look at the first field on the form:


: (show *Top 'gui 1)

A production application would be started in a slightly different way:


$ pil family.l -main -go -wait

In that case, no debug prompt will appear. In both cases, however, two pil processes will be running now. One is the initial server process which will continue to run until it is killed. The other is a child process holding the state of the GUI in the browser. It will terminate some time after the browser is closed, or when (bye) or a Ctrl-D is entered at the PicoLisp prompt.

Now back to the explanation of the GUI function person:


(de person ()
   (app)
   (action
      (html 0 (get (default *ID (val *DB)) 'nm) "@lib.css" NIL
         (form NIL
            (<h2> (<id> (: nm)))

For an in-depth explanation of that startup code, please refer to the guide to PicoLisp Application Development.

All components like fields and buttons are controlled by form. The function gui creates a single GUI component and takes the type (a list of classes) and a variable number of arguments depending on the needs of these classes.


   (gui '(+E/R +TextField) '(nm : home obj) 40 "Name")

This creates a +TextField with the label "Name" and a length of 40 characters. The +E/R (: Entity/Relation) prefix class connects that field to a database object, the nm attribute of a person in this case, so that the person's name is displayed in that text field, and any changes entered into that field are propagated to the database automatically.


   (gui '(+ClassField) '(: home obj) '(("Male" +Man) ("Female" +Woman)))

A +ClassField displays and changes the class of an object, in this case the person's sex from +Man to +Woman and vice versa.

As you see, there is no place where explicit accesses to the database have to be programmed, no select or update. This is all encapsulated in the GUI components, mainly in the +E/R prefix class. The above function person is fully functional as we present it and allows creation, modification and deletion of person objects in the database.

The two buttons on the bottom right generate simple reports:

The first one shows all contemporaries of the person that is currently displayed, i.e. all persons who did not die before, or were not born after that person. This is a typical PicoLisp report, in that in addition to the report's HTML page, a temporary file may be generated, suitable for download (and import into a spread sheet), and from which a PDF can be produced for print-out.

In PicoLisp, there is not a real difference between a plain HTML-GUI and a report. Again, the function html is used to generate the page.

The second report is much simpler. It produces a recursive structure of the family.

In both reports, links to the person objects are created which allow easy navigation through the database.


Pilog -- PicoLisp Prolog

This sections explains some cases of using Pilog in typical application programming, in combination with persistent objects and databases. Please refer to the Pilog section of the PicoLisp Reference for the basic usage of Pilog.

Again, we use our demo application @doc/family.l that was introduced in the Database Programming section.

Normally, Pilog is used either interactively to query the database during debugging, or in applications to generate export data and reports. In the following examples we use the interactive query front-end functions ? and select. An application will use goal and prove directly, or use convenience functions like pilog or solve.

All Pilog access to external symbols is done via the two predicates db/3 and select/3.

A predicate show/1 is pre-defined for debugging purposes (a simple glue to the Lisp-level function show, see Browsing). Searching with db/3 for all persons having the string "Edward" in their name:


: (? (db nm +Person "Edward" @P) (show @P))
{2-;} (+Man)
   nm "Edward"
   ma {2-:}
   pa {2-A}
   dat 717346
   job "Prince"
 @P={2-;}
{2-1B} (+Man)
   nm "Albert Edward"
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   job "Prince"
   mate {2-f}
   fin 680370
   dat 664554
 @P={2-1B}
...               # more results

To search for all persons with "Edward" in their name who are married to somebody with occupation "Queen":


: (? (db nm +Person "Edward" @P) (val "Queen" @P mate job) (show @P))
{2-1B} (+Man)
   mate {2-f}
   nm "Albert Edward"
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   job "Prince"
   fin 680370
   dat 664554
 @P={2-1B}
-> NIL            # only one result

If you are interested in the names of "Albert Edward"'s children:


: (? (db nm +Person "Albert Edward" @P) (lst @K @P kids) (val @Kid @K nm))
 @P={2-1B} @K={2-1C} @Kid="Beatrice Mary Victoria"
 @P={2-1B} @K={2-1D} @Kid="Leopold George Duncan"
 @P={2-1B} @K={2-1E} @Kid="Arthur William Patrick"
 @P={2-1B} @K={2-1F} @Kid="Louise Caroline Alberta"
 @P={2-1B} @K={2-1G} @Kid="Helena Augusta Victoria"
 @P={2-1B} @K={2-1H} @Kid="Alfred Ernest Albert"
 @P={2-1B} @K={2-1I} @Kid="Alice Maud Mary"
 @P={2-1B} @K={2-g} @Kid="Victoria Adelaide Mary"
 @P={2-1B} @K={2-a} @Kid="Edward VII"
-> NIL

db/3 can do a direct index access only for a single attribute (nm of +Person above). To search for several criteria at the same time, select/3 has to be used:


: (?
   (select (@P)
      ((nm +Person "Edward") (nm +Person "Augusta" pa))  # Generator clauses
      (tolr "Edward" @P nm)                              # Filter clauses
      (tolr "Augusta" @P kids nm) )
   (show @P) )
{2-1B} (+Man)
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   mate {2-f}
   nm "Albert Edward"
   job "Prince"
   fin 680370
   dat 664554
 @P={2-1B}
-> NIL

select/3 takes a list of generator clauses which are used to retrieve objects from the database, and a number of normal Pilog filter clauses. In the example above the generators are

All persons generated are possible candidates for our selection. The nm index tree of +Person is traversed twice in parallel, optimizing the search in such a way that successful hits get higher priority in the search, depending on the filter clauses. The process will stop as soon as any one of the generators is exhausted. Note that this is different from the standard Prolog search algorithm.

The filter clauses in this example both use the pre-defined predicate tolr/3 for tolerant string matches (according either to the soundex algorithm (see the section Database Programming) or to substring matches), and filter objects that

A more typical and extensive example for the usage of select can be found in the qPerson function in @doc/family.l. It is used in the search dialog of the demo application, and searches for a person with the name, the parents' and partner's names, the occupation and a time range for the birth date. The relevant index trees in the database are searched (actually only those trees where the user entered a search key in the corresponding dialog field), and a logical AND of the search attributes is applied to the result.

For example, press the "Select" button, enter "Elizabeth" into the "Mother" search field and "Phil" in the "Partner" search field, meaning to look for all persons whose mother's name is like "Elizabeth" and whose partner's name is like "Phil". As a result, two persons ("Elizabeth II" and "Anne") will show up.

In principle, db/3 can be seen as a special case of select/3. The following two queries are equivalent:


: (? (db nm +Person "Edward" @P))
 @P={2-;}
 @P={2-1B}
 @P={2-R}
 @P={2-1K}
 @P={2-a}
 @P={2-T}
-> NIL
: (? (select (@P) ((nm +Person "Edward"))))
 @P={2-;}
 @P={2-1B}
 @P={2-R}
 @P={2-1K}
 @P={2-a}
 @P={2-T}
-> NIL


Poor Man's SQL

select

For convenience, a select Lisp glue function is provided as a front-end to the select predicate. Note that this function does not evaluate its arguments (it is intended for interactive use), and that it supports only a subset of the predicate's functionality. The syntax resembles SELECT in the SQL language, for example:


# SELECT * FROM Person
: (select +Person)  # Step through the whole database
{2-o} (+Man)
   nm "Adalbert Ferdinand Berengar Viktor of Prussia"
   dat 688253
   ma {2-j}
   pa {2-h}
   fin 711698

{2-1B} (+Man)
   nm "Albert Edward"
   dat 664554
   job "Prince"
   mate {2-f}
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   fin 680370
...

# SELECT * FROM Person WHERE nm LIKE "%Edward%"
: (select +Person nm "Edward")  # Show all Edwards
{2-;} (+Man)
   nm "Edward"
   dat 717346
   job "Prince"
   ma {2-:}
   pa {2-A}

{2-1B} (+Man)
   nm "Albert Edward"
   dat 664554
   job "Prince"
   kids ({2-1C} {2-1D} {2-1E} {2-1F} {2-1G} {2-1H} {2-1I} {2-g} {2-a})
   mate {2-f}
   fin 680370
...

# SELECT nm, dat FROM Person WHERE nm LIKE "%Edward%"
: (select nm dat +Person nm "Edward")
"Edward" "1964-03-10" {2-;}
"Albert Edward" "1819-08-26" {2-1B}
"George Edward" NIL {2-R}
"Edward Augustus Hanover" NIL {2-1K}
...

# SELECT dat, fin, p1.nm, p2.nm
#    FROM Person p1, Person p2
#    WHERE p1.nm LIKE "%Edward%"
#    AND p1.job LIKE "King%"
#    AND p1.mate = p2.mate  -- Actually, in a SQL model we'd need
#                           -- another table here for the join
: (select dat fin nm (mate nm) +Person nm "Edward" job "King")
"1894-06-23" "1972-05-28" "Edward VIII" "Wallace Simpson" {2-T}
"1841-11-09" NIL "Edward VII" "Alexandra of Denmark" {2-a}
-> NIL

update

In addition (just to stay with the SQL terminology ;-), there is also an update function. It is a front-end to the set!> and put!> transaction methods, and should be used when single objects in the database have to be modified by hand.

In principle, it would also be possible to use the edit function to modify a database object. This is not recommended, however, because edit does not know about relations to other objects (like Links, Joints and index trees) and may easily cause database corruption.

In the most general case, the value of a property in a database object is changed with the put!> method. Let's look at "Edward" from the previous examples:


: (show '{2-;})
{2R} (+Man)
   job "Prince"
   nm "Edward"
   dat 717346
   ma {2-:}
   pa {20A}
-> {2-;}

We might change the name to "Johnny" with put!>:


: (put!> '{2-;} 'nm "Johnny")
-> "Johnny"

However, an easier and less error-prone prone way - especially when more than one property has to be changed - is using update. It presents the value (the list of classes) and then each property on its own line, allowing the user to change it with the command line editor.

Just hitting ENTER will leave that property unchanged. To modify it, you'll typically hit ESC to get into command mode, and move the cursor to the point of change.

For properties with nested list structures (+List +Bag), update will recurse into the data structure.


: (update '{2-;})
{2-;} (+Man)      # ENTER
nm "Johnny"       # Modified the name to "Johnny"
ma {2-:}          # ENTER
pa {2-A}          # ENTER
dat 1960-03-10    # Modified the year from "1964" to "1960"
job "Prince"      # ENTER
-> {2-;}

All changes are committed immediately, observing the rules of database synchronization so that any another user looking at the same object will have his GUI updated correctly.

To abort update, hit Ctrl-X.

If only a single property has to be changed, update can be called directly for that property:


: (update '{2-;} 'nm)
{2-;} nm "Edward"
...


References

[knuth73] Donald E. Knuth: ``The Art of Computer Programming'', Vol.3, Addison-Wesley, 1973, p. 392 picolisp-3.1.5.2.orig/doc/utf80000644000000000000000000000137112265263724014530 0ustar rootroot UTF-8 Format # Encoding for zero is different from Java # Special character 0xFF (char T) 0000 .. 007F 0xxxxxxx 6 0 0080 .. 07FF 110xxxxx 10xxxxxx A 6 5 0 0800 .. FFFF 1110xxxx 10xxxxxx 10xxxxxx F C B 6 5 0 Umlaute äöüÄÖÜß |Ä| # C3 84 <-> C4 |Ö| # C3 96 <-> D6 |Ü| # C3 9C <-> DC |ä| # C3 A4 <-> E4 |ö| # C3 B6 <-> F6 |ü| # C3 BC <-> FC |ß| # C3 9F <-> DF Paragraph # C2 A7 <-> A7 EUR (8364 "20AC") # E2 82 AC <-> A4 tr -d '\303' |tr '\204\226\234\244\266\274\237' '' (out "Nagoya" (prinl (char (hex "540D")) (char (hex "53E4")) (char (hex "5C4B"))) ) picolisp-3.1.5.2.orig/doc/vim-tsm0000644000000000000000000000144712265263724015242 0ustar rootroot26apr10abu (c) Software Lab. Alexander Burger Transient Symbol Markup for 'vim' ================================= 1. Compile 'vim' with Vince Negri's "Conceal" patch: http://vim.wikia.com/wiki/Patch_to_conceal_parts_of_lines patch -p0 < conceal-ownsyntax.diff make distclean ./configure --with-features=huge make VIMRUNTIMEDIR=~/local/vim72/runtime MAKE="make -e" cd ~/bin ln -s ~/local/vim72/src/vim ln vim vi ln vim view 2. Then put into your ".vimrc" or vim syntax file: if has("conceal") set conceallevel=2 syn region picoLispTransient concealends matchgroup=picoLispString start=/"/ skip=/\\\\\|\\"/ end=/"/ hi picoLispTransient gui=underline term=underline cterm=underline hi picoLispString ctermfg=red guifg=red endif picolisp-3.1.5.2.orig/doc/app.html0000644000000000000000000027534012265263724015376 0ustar rootroot PicoLisp Application Development abu@software-lab.de

PicoLisp Application Development

(c) Software Lab. Alexander Burger

This document presents an introduction to writing browser-based applications in PicoLisp.

It concentrates on the XHTML/CSS GUI-Framework (as opposed to the previous Java-AWT, Java-Swing and Plain-HTML frameworks), which is easier to use, more flexible in layout design, and does not depend on plug-ins, JavaScript, cookies or CSS.

A plain HTTP/HTML GUI has various advantages: It runs on any browser, and can be fully driven by scripts ("@lib/scrape.l").

To be precise: CSS can be used to enhance the layout. And browsers with JavaScript will respond faster and smoother. But this framework works just fine in browsers which do not know anything about CSS or JavaScript. All examples were also tested using the w3m text browser.

For basic informations about the PicoLisp system please look at the PicoLisp Reference and the PicoLisp Tutorial. Knowledge of HTML, and a bit of CSS and HTTP is assumed.

The examples assume that PicoLisp was started from a global installation (see Installation).


Static Pages

You can use PicoLisp to generate static HTML pages. This does not make much sense in itself, because you could directly write HTML code as well, but it forms the base for interactive applications, and allows us to introduce the application server and other fundamental concepts.


Hello World

To begin with a minimal application, please enter the following two lines into a generic source file named "project.l" in the PicoLisp installation directory.


########################################################################
(html 0 "Hello" "@lib.css" NIL
   "Hello World!" )
########################################################################

(We will modify and use this file in all following examples and experiments. Whenever you find such a program snippet between hash ('#') lines, just copy and paste it into your "project.l" file, and press the "reload" button of your browser to view the effects)

Start the application server

Open a second terminal window, and start a PicoLisp application server


$ pil @lib/http.l @lib/xhtml.l @lib/form.l  --server 8080 project.l  +

No prompt appears. The server just sits, and waits for connections. You can stop it later by hitting Ctrl-C in that terminal, or by executing 'killall pil' in some other window.

(In the following, we assume that this HTTP server is up and running)

Now open the URL 'http://localhost:8080' with your browser. You should see an empty page with a single line of text.

How does it work?

The above line loads the debugger (via the '+' switch), the HTTP server code ("@lib/http.l"), the XHTML functions ("@lib/xhtml.l") and the input form framework ("@lib/form.l", it will be needed later for interactive forms).

Then the server function is called with a port number and a default URL. It will listen on that port for incoming HTTP requests in an endless loop. Whenever a GET request arrives on port 8080, the file "project.l" will be (load)ed, causing the evaluation (= execution) of all its Lisp expressions.

During that execution, all data written to the current output channel is sent directly to to the browser. The code in "project.l" is responsible to produce HTML (or anything else the browser can understand).


URL Syntax

The PicoLisp application server uses a slightly specialized syntax when communicating URLs to and from a client. The "path" part of an URL - which remains when

are stripped off - is interpreted according so some rules. The most prominent ones are:

An application is free to extend or modify the *Mimes table with the mime function. For example


(mime "doc" "application/msword" 60)

defines a new mime type with a max-age of one minute.

Argument values in URLs, following the path and the question mark, are encoded in such a way that Lisp data types are preserved:

In that way, high-level data types can be directly passed to functions encoded in the URL, or assigned to global variables before a file is loaded.


Security

It is, of course, a huge security hole that - directly from the URL - any Lisp source file can be loaded, and any Lisp function can be called. For that reason, applications must take care to declare exactly which files and functions are to be allowed in URLs. The server checks a global variable *Allow, and - when its value is non-NIL - denies access to anything that does not match its contents.

Normally, *Allow is not manipulated directly, but set with the allowed and allow functions


(allowed ("app/")
   "!start" "!stop" "@lib.css" "!psh" )

This is usually called at the beginning of an application, and allows access to the directory "app/", to the functions 'start', 'stop' and 'psh', and to the file "@lib.css".

Later in the program, *Allow may be dynamically extended with allow


(allow "!foo")
(allow "newdir/" T)

This adds the function 'foo', and the directory "newdir/", to the set of allowed items.

The ".pw" File

For a variety of security checks (most notably for using the psh function, as in some later examples) it is necessary to create a file named ".pw" in the PicoLisp installation directory. This file should contain a single line of arbitrary data, to be used as a password for identifying local resources.

The recommeded way to create this file is to call the pw function, defined in "@lib/http.l"


$ pil @lib/http.l -'pw 12' -bye

Please execute this command.


The html Function

Now back to our "Hello World" example. In principle, you could write "project.l" as a sequence of print statements


########################################################################
(prinl "HTTP/1.0 200 OK^M")
(prinl "Content-Type: text/html; charset=utf-8")
(prinl "^M")
(prinl "<html>")
(prinl "Hello World!")
(prinl "</html>")
########################################################################

but using the html function is much more convenient.

Moreover, html is nothing more than a printing function. You can see this easily if you connect a PicoLisp Shell (psh) to the server process (you must have generated a ".pw" file for this), and enter the html statement


$ /usr/lib/picolisp/bin/psh 8080
: (html 0 "Hello" "@lib.css" NIL "Hello World!")
HTTP/1.0 200 OK
Server: PicoLisp
Date: Fri, 29 Dec 2006 07:28:58 GMT
Cache-Control: max-age=0
Cache-Control: no-cache
Content-Type: text/html; charset=utf-8

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
<title>Hello</title>
<base href="http://localhost:8080/"/>
<link rel="stylesheet" type="text/css" href="http://localhost:8080/@lib.css"/>
</head>
<body>Hello World!</body>
</html>
-> </html>
:  # (type Ctrl-D here to terminate PicoLisp)

These are the arguments to html:

  1. 0: A max-age value for cache-control (in seconds, zero means "no-cache"). You might pass a higher value for pages that change seldom, or NIL for no cache-control at all.
  2. "Hello": The page title.
  3. "@lib.css": A CSS-File name. Pass NIL if you do not want to use any CSS-File, or a list of file names if you want to give more than one CSS-File.
  4. NIL: A CSS style attribute specification (see the description of CSS Attributes below). It will be passed to the body tag.

After these four arguments, an arbitrary number of expressions may follow. They form the body of the resulting page, and are evaluated according to a special rule. This rule is slightly different from the evaluation of normal Lisp expressions:

Therefore, our source file might as well be written as:


########################################################################
(html 0 "Hello" "@lib.css" NIL
   (prinl "Hello World!") )
########################################################################

The most typical print statements will be some HTML-tags:


########################################################################
(html 0 "Hello" "@lib.css" NIL
   (<h1> NIL "Hello World!")
   (<br> "This is some text.")
   (ht:Prin "And this is a number: " (+ 1 2 3)) )
########################################################################

<h1> and <br> are tag functions. <h1> takes a CSS attribute as its first argument.

Note the use of ht:Prin instead of prin. ht:Prin should be used for all direct printing in HTML pages, because it takes care to escape special characters.


CSS Attributes

The html function above, and many of the HTML tag functions, accept a CSS attribute specification. This may be either an atom, a cons pair, or a list of cons pairs. We demonstrate the effects with the <h1> tag function.

An atom (usually a symbol or a string) is taken as a CSS class name


: (<h1> 'foo "Title")
<h1 class="foo">Title</h1>

For a cons pair, the CAR is taken as an attribute name, and the CDR as the attribute's value


: (<h1> '(id . bar) "Title")
<h1 id="bar">Title</h1>

Consequently, a list of cons pairs gives a set of attribute-value pairs


: (<h1> '((id . "abc") (lang . "de")) "Title")
<h1 id="abc" lang="de">Title</h1>


Tag Functions

All pre-defined XHTML tag functions can be found in "@lib/xhtml.l". We recommend to look at their sources, and to experiment a bit, by executing them at a PicoLisp prompt, or by pressing the browser's "Reload" button after editing the "project.l" file.

For a suitable PicoLisp prompt, either execute (in a separate terminal window) the PicoLisp Shell (psh) command (works only if the application server is running, and you did generate a ".pw" file)


$ /usr/lib/picolisp/bin/psh 8080
:

or start the interpreter stand-alone, with "@lib/xhtml.l" loaded


$ pil @lib/http.l @lib/xhtml.l +
:

Note that for all these tag functions the above tag body evaluation rule applies.

Simple Tags

Most tag functions are simple and straightforward. Some of them just print their arguments


: (<br> "Hello world")
Hello world<br/>

: (<em> "Hello world")
<em>Hello world</em>

while most of them take a CSS attribute specification as their first argument (like the <h1> tag above)


: (<div> 'main "Hello world")
<div class="main">Hello world</div>

: (<p> NIL "Hello world")
<p>Hello world</p>

: (<p> 'info "Hello world")
<p class="info">Hello world</p>

All of these functions take an arbitrary number of arguments, and may nest to an arbitrary depth (as long as the resulting HTML is legal)


: (<div> 'main
   (<h1> NIL "Head")
   (<p> NIL
      (<br> "Line 1")
      "Line"
      (<nbsp>)
      (+ 1 1) ) )
<div class="main"><h1>Head</h1>
<p>Line 1<br/>
Line 2</p>
</div>

(Un)ordered Lists

HTML-lists, implemented by the <ol> and <ul> tags, let you define hierarchical structures. You might want to paste the following code into your copy of "project.l":


########################################################################
(html 0 "Unordered List" "@lib.css" NIL
   (<ul> NIL
      (<li> NIL "Item 1")
      (<li> NIL
         "Sublist 1"
         (<ul> NIL
            (<li> NIL "Item 1-1")
            (<li> NIL "Item 1-2") ) )
      (<li> NIL "Item 2")
      (<li> NIL
         "Sublist 2"
         (<ul> NIL
            (<li> NIL "Item 2-1")
            (<li> NIL "Item 2-2") ) )
      (<li> NIL "Item 3") ) )
########################################################################

Here, too, you can put arbitrary code into each node of that tree, including other tag functions.

Tables

Like the hierarchical structures with the list functions, you can generate two-dimensional tables with the <table> and <row> functions.

The following example prints a table of numbers and their squares:


########################################################################
(html 0 "Table" "@lib.css" NIL
   (<table> NIL NIL NIL
      (for N 10                                    # A table with 10 rows
         (<row> NIL N (prin (* N N))) ) ) )     # and 2 columns
########################################################################

The first argument to <table> is the usual CSS attribute, the second an optional title ("caption"), and the third an optional list specifying the column headers. In that list, you may supply a list for a each column, with a CSS attribute in its CAR, and a tag body in its CDR for the contents of the column header.

The body of <table> contains calls to the <row> function. This function is special in that each expression in its body will go to a separate column of the table. If both for the column header and the row function an CSS attribute is given, they will be combined by a space and passed to the HTML <td> tag. This permits distinct CSS specifications for each column and row.

As an extension of the above table example, let's pass some attributes for the table itself (not recommended - better define such styles in a CSS file and then just pass the class name to <table>), right-align both columns, and print each row in an alternating red and blue color


########################################################################
(html 0 "Table" "@lib.css" NIL
   (<table>
      '((width . "200px") (style . "border: dotted 1px;"))    # table style
      "Square Numbers"                                        # caption
      '((align "Number") (align "Square"))                    # 2 headers
      (for N 10                                                  # 10 rows
         (<row> (xchg '(red) '(blue))                         # red or blue
            N                                                 # 2 columns
            (prin (* N N) ) ) ) ) )
########################################################################

If you wish to concatenate two or more cells in a table, so that a single cell spans several columns, you can pass the symbol '-' for the additional cell data to <row>. This will cause the data given to the left of the '-' symbols to expand to the right.

You can also directly specify table structures with the simple <th>, <tr> and <td> tag functions.

If you just need a two-dimensional arrangement of components, the even simpler <grid> function might be convenient:


########################################################################
(html 0 "Grid" "@lib.css" NIL
   (<grid> 3
      "A" "B" "C"
      123 456 789 ) )
########################################################################

It just takes a specification for the number of columns (here: 3) as its first argument, and then a single expression for each cell. Instead of a number, you can also pass a list of CSS attributes. Then the length of that list will determine the number of columns. You can change the second line in the above example to


   (<grid> '(NIL NIL right)

Then the third column will be right aligned.

Menus and Tabs

The two most powerful tag functions are <menu> and <tab>. Used separately or in combination, they form a navigation framework with

The following example is not very useful, because the URLs of all items link to the same "project.l" page, but it should suffice to demonstrate the functionality:


########################################################################
(html 0 "Menu+Tab" "@lib.css" NIL
   (<div> '(id . menu)
      (<menu>
         ("Item" "project.l")                      # Top level item
         (NIL (<hr>))                              # Plain HTML
         (T "Submenu 1"                            # Submenu
            ("Subitem 1.1" "project.l")
            (T "Submenu 1.2"
               ("Subitem 1.2.1" "project.l")
               ("Subitem 1.2.2" "project.l")
               ("Subitem 1.2.3" "project.l") )
            ("Subitem 1.3" "project.l") )
         (T "Submenu 2"
            ("Subitem 2.1" "project.l")
            ("Subitem 2.2" "project.l") ) ) )
   (<div> '(id . main)
      (<h1> NIL "Menu+Tab")
      (<tab>
         ("Tab1"
            (<h3> NIL "This is Tab 1") )
         ("Tab2"
            (<h3> NIL "This is Tab 2") )
         ("Tab3"
            (<h3> NIL "This is Tab 3") ) ) ) )
########################################################################

<menu> takes a sequence of menu items. Each menu item is a list, with its CAR either

<tab> takes a list of subpages. Each page is simply a tab name, followed by arbitrary code (typically HTML tags).

Note that only a single menu and a single tab may be active at the same time.


Interactive Forms

In HTML, the only possibility for user input is via <form> and <input> elements, using the HTTP POST method to communicate with the server.

"@lib/xhtml.l" defines a function called <post>, and a collection of input tag functions, which allow direct programming of HTML forms. We will supply only one simple example:


########################################################################
(html 0 "Simple Form" "@lib.css" NIL
   (<post> NIL "project.l"
      (<field> 10 '*Text)
      (<submit> "Save") ) )
########################################################################

This associates a text input field with a global variable *Text. The field displays the current value of *Text, and pressing the submit button causes a reload of "project.l" with *Text set to any string entered by the user.

An application program could then use that variable to do something useful, for example store its value in a database.

The problem with such a straightforward use of forms is that

  1. they require the application programmer to take care of maintaining lots of global variables. Each input field on the page needs an associated variable for the round trip between server and client.
  2. they do not preserve an application's internal state. Each POST request spawns an individual process on the server, which sets the global variables to their new values, generates the HTML page, and terminates thereafter. The application state has to be passed along explicitly, e.g. using <hidden> tags.
  3. they are not very interactive. There is typically only a single submit button. The user fills out a possibly large number of input fields, but changes will take effect only when the submit button is pressed.

Though we wrote a few applications in that style, we recommend the GUI framework provided by "@lib/form.l". It does not need any variables for the client/server communication, but implements a class hierarchy of GUI components for the abstraction of application logic, button actions and data linkage.


Sessions

First of all, we need to establish a persistent environment on the server, to handle each individual session (for each connected client).

Technically, this is just a child process of the server we started above, which does not terminate immediately after it sent its page to the browser. It is achieved by calling the app function somewhere in the application's startup code.


########################################################################
(app)  # Start a session

(html 0 "Simple Session" "@lib.css" NIL
   (<post> NIL "project.l"
      (<field> 10 '*Text)
      (<submit> "Save") ) )
########################################################################

Nothing else changed from the previous example. However, when you connect your browser and then look at the terminal window where you started the application server, you'll notice a colon, the PicoLisp prompt


$ pil @lib/http.l @lib/xhtml.l @lib/form.l  --server 8080 project.l  +
:

Tools like the Unix ps utility will tell you that now two picolisp processes are running, the first being the parent of the second.

If you enter some text, say "abcdef", into the text field in the browser window, press the submit button, and inspect the Lisp *Text variable,


: *Text
-> "abcdef"

you see that we now have a dedicated PicoLisp process, "connected" to the client.

You can terminate this process (like any interactive PicoLisp) by hitting Ctrl-D on an empty line. Otherwise, it will terminate by itself if no other browser requests arrive within a default timeout period of 5 minutes.

To start a (non-debug) production version, the server is commonly started without the '+' flag, and with -wait


$ pil @lib/http.l @lib/xhtml.l @lib/form.l  --server 8080 project.l  -wait

In that way, no command line prompt appears when a client connects.


Action Forms

Now that we have a persistent session for each client, we can set up an active GUI framework.

This is done by wrapping the call to the html function with action. Inside the body of html can be - in addition to all other kinds of tag functions - one or more calls to form


########################################################################
(app)                                              # Start session

(action                                            # Action handler
   (html 0 "Form" "@lib.css" NIL                   # HTTP/HTML protocol
      (form NIL                                    # Form
         (gui 'a '(+TextField) 10)                 # Text Field
         (gui '(+Button) "Print"                   # Button
            '(msg (val> (: home a))) ) ) ) )
########################################################################

Note that there is no longer a global variable like *Text to hold the contents of the input field. Instead, we gave a local, symbolic name 'a' to a +TextField component


         (gui 'a '(+TextField) 10)                 # Text Field

Other components can refer to it


            '(msg (val> (: home a)))

(: home) is always the form which contains this GUI component. So (: home a) evaluates to the component 'a' in the current form. As msg prints its argument to standard error, and the val> method retrieves the current contents of a component, we will see on the console the text typed into the text field when we press the button.

An action without embedded forms - or a form without a surrounding action - does not make much sense by itself. Inside html and form, however, calls to HTML functions (and any other Lisp functions, for that matter) can be freely mixed.

In general, a typical page may have the form


(action                                            # Action handler
   (html ..                                        # HTTP/HTML protocol
      (<h1> ..)                                    # HTML tags
      (form NIL                                    # Form
         (<h3> ..)
         (gui ..)                                  # GUI component(s)
         (gui ..)
         .. )
      (<h2> ..)
      (form NIL                                    # Another form
         (<h3> ..)
         (gui ..)                                  # GUI component(s)
         .. )
      (<br> ..)
      .. ) )

The gui Function

The most prominent function in a form body is gui. It is the workhorse of GUI construction.

Outside of a form body, gui is undefined. Otherwise, it takes an optional alias name, a list of classes, and additional arguments as needed by the constructors of these classes. We saw this example before


         (gui 'a '(+TextField) 10)                 # Text Field
Here, 'a' is an alias name for a component of type (+TextField). The numeric argument 10 is passed to the text field, specifying its width. See the chapter on GUI Classes for more examples.

During a GET request, gui is basically a front-end to new. It builds a component, stores it in the internal structures of the current form, and initializes it by sending the init> message to the component. Finally, it sends it the show> message, to produce HTML code and transmit it to the browser.

During a POST request, gui does not build any new components. Instead, the existing components are re-used. So gui does not have much more to do than sending the show> message to a component.

Control Flow

HTTP has only two methods to change a browser window: GET and POST. We employ these two methods in a certain defined, specialized way:

A button's action code can do almost anything: Read and modify the contents of input fields, communicate with the database, display alerts and dialogs, or even fake the POST request to a GET, with the effect of showing a completely different document (See Switching URLs).

GET builds up all GUI components on the server. These components are objects which encapsulate state and behavior of the HTML page in the browser. Whenever a button is pressed, the page is reloaded via a POST request. Then - before any output is sent to the browser - the action function takes control. It performs error checks on all components, processes possible user input on the HTML page, and stores the values in correct format (text, number, date, object etc.) in each component.

The state of a form is preserved over time. When the user returns to a previous page with the browser's BACK button, that state is reactivated, and may be POSTed again.

The following silly example displays two text fields. If you enter some text into the "Source" field, you can copy it in upper or lower case to the "Destination" field by pressing one of the buttons


########################################################################
(app)

(action
   (html 0 "Case Conversion" "@lib.css" NIL
      (form NIL
         (<grid> 2
            "Source" (gui 'src '(+TextField) 30)
            "Destination" (gui 'dst '(+Lock +TextField) 30) )
         (gui '(+JS +Button) "Upper Case"
            '(set> (: home dst)
               (uppc (val> (: home src))) ) )
         (gui '(+JS +Button) "Lower Case"
            '(set> (: home dst)
               (lowc (val> (: home src))) ) ) ) ) )
########################################################################

The +Lock prefix class in the "Destination" field makes that field read-only. The only way to get some text into that field is by using one of the buttons.

Switching URLs

Because an action code runs before html has a chance to output an HTTP header, it can abort the current page and present something different to the user. This might, of course, be another HTML page, but would not be very interesting as a normal link would suffice. Instead, it can cause the download of dynamically generated data.

The next example shows a text area and two buttons. Any text entered into the text area is exported either as a text file via the first button, or a PDF document via the second button


########################################################################
(load "@lib/ps.l")

(app)

(action
   (html 0 "Export" "@lib.css" NIL
      (form NIL
         (gui '(+TextField) 30 8)
         (gui '(+Button) "Text"
            '(let Txt (tmp "export.txt")
               (out Txt (prinl (val> (: home gui 1))))
               (url Txt) ) )
         (gui '(+Button) "PDF"
            '(psOut NIL "foo"
               (a4)
               (indent 40 40)
               (down 60)
               (hline 3)
               (font (14 . "Times-Roman")
                  (ps (val> (: home gui 1))) )
               (hline 3)
               (page) ) ) ) ) )
########################################################################

(a text area is built when you supply two numeric arguments (columns and rows) to a +TextField class)

The action code of the first button creates a temporary file (i.e. a file named "export.txt" in the current process's temporary space), prints the value of the text area (this time we did not bother to give it a name, we simply refer to it as the form's first gui list element) into that file, and then calls the url function with the file name.

The second button uses the PostScript library "@lib/ps.l" to create a temporary file "foo.pdf". Here, the temporary file creation and the call to the url function is hidden in the internal mechanisms of psOut. The effect is that the browser receives a PDF document and displays it.

Alerts and Dialogs

Alerts and dialogs are not really what they used to be ;-)

They do not "pop up". In this framework, they are just a kind of simple-to-use, pre-fabricated form. They can be invoked by a button's action code, and appear always on the current page, immediately preceding the form which created them.

Let's look at an example which uses two alerts and a dialog. In the beginning, it displays a simple form, with a locked text field, and two buttons


########################################################################
(app)

(action
   (html 0 "Alerts and Dialogs" "@lib.css" NIL
      (form NIL
         (gui '(+Init +Lock +TextField) "Initial Text" 20 "My Text")
         (gui '(+Button) "Alert"
            '(alert NIL "This is an alert " (okButton)) )
         (gui '(+Button) "Dialog"
            '(dialog NIL
               (<br> "This is a dialog.")
               (<br>
                  "You can change the text here "
                  (gui '(+Init +TextField) (val> (: top 1 gui 1)) 20) )
               (<br> "and then re-submit it to the form.")
               (gui '(+Button) "Re-Submit"
                  '(alert NIL "Are you sure? "
                     (yesButton
                        '(set> (: home top 2 gui 1)
                           (val> (: home top 1 gui 1)) ) )
                     (noButton) ) )
               (cancelButton) ) ) ) ) )
########################################################################

The +Init prefix class initializes the "My Text" field with the string "Initial Text". As the field is locked, you cannot modify this value directly.

The first button brings up an alert saying "This is an alert.". You can dispose it by pressing "OK".

The second button brings up a dialog with an editable text field, containing a copy of the value from the form's locked text field. You can modify this value, and send it back to the form, if you press "Re-Submit" and answer "Yes" to the "Are you sure?" alert.

A Calculator Example

Now let's forget our "project.l" test file for a moment, and move on to a more substantial and practical, stand-alone, example. Using what we have learned so far, we want to build a simple bignum calculator. ("bignum" because PicoLisp can do only bignums)

It uses a single form, a single numeric input field, and lots of buttons. It can be found in the PicoLisp distribution (e.g. under "/usr/share/picolisp/") in "misc/calc.l", together with a directly executable wrapper script "misc/calc".

To use it, change to the PicoLisp installation directory, and start it as


$ misc/calc

or call it with an absolute path, e.g.


$ /usr/share/picolisp/misc/calc

If you like to get a PicoLisp prompt for inspection, start it instead as


$ pil misc/calc.l -main -go +

Then - as before - point your browser to 'http://localhost:8080'.

The code for the calculator logic and the GUI is rather straightforward. The entry point is the single function calculator. It is called directly (as described in URL Syntax) as the server's default URL, and implicitly in all POST requests. No further file access is needed once the calculator is running.

Note that for a production application, we inserted an allow-statement (as recommended by the Security chapter)


(allowed NIL "!calculator" "@lib.css")

at the beginning of "misc/calc.l". This will restrict external access to that single function.

The calculator uses three global variables, *Init, *Accu and *Stack. *Init is a boolean flag set by the operator buttons to indicate that the next digit should initialize the accumulator to zero. *Accu is the accumulator. It is always displayed in the numeric input field, accepts user input, and it holds the results of calculations. *Stack is a push-down stack, holding postponed calculations (operators, priorities and intermediate results) with lower-priority operators, while calculations with higher-priority operators are performed.

The function digit is called by the digit buttons, and adds another digit to the accumulator.

The function calc does an actual calculation step. It pops the stack, checks for division by zero, and displays an error alert if necessary.

operand processes an operand button, accepting a function and a priority as arguments. It compares the priority with that in the top-of-stack element, and delays the calculation if it is less.

finish is used to calculate the final result.

The calculator function has one numeric input field, with a width of 60 characters


         (gui '(+Var +NumField) '*Accu 60)

The +Var prefix class associates this field with the global variable *Accu. All changes to the field will show up in that variable, and modification of that variable's value will appear in the field.

The square root operator button has an +Able prefix class


         (gui '(+Able +JS +Button) '(ge0 *Accu) (char 8730)
            '(setq *Accu (sqrt *Accu)) )

with an argument expression which checks that the current value in the accumulator is positive, and disables the button if otherwise.

The rest of the form is just an array (grid) of buttons, encapsulating all functionality of the calculator. The user can enter numbers into the input field, either by using the digit buttons, or by directly typing them in, and perform calculations with the operator buttons. Supported operations are addition, subtraction, multiplication, division, sign inversion, square root and power (all in bignum integer arithmetic). The 'C' button just clears the accumulator, while the 'A' button also clears all pending calculations.

All that in 53 lines of code!


Charts

Charts are virtual components, maintaining the internal representation of two-dimensional data.

Typically, these data are nested lists, database selections, or some kind of dynamically generated tabular information. Charts make it possible to view them in rows and columns (usually in HTML tables), scroll up and down, and associate them with their corresponding visible GUI components.

In fact, the logic to handle charts makes up a substantial part of the whole framework, with large impact on all internal mechanisms. Each GUI component must know whether it is part of a chart or not, to be able to handle its contents properly during updates and user interactions.

Let's assume we want to collect textual and numerical data. We might create a table


########################################################################
(app)

(action
   (html 0 "Table" "@lib.css" NIL
      (form NIL
         (<table> NIL NIL '((NIL "Text") (NIL "Number"))
            (do 4
               (<row> NIL
                  (gui '(+TextField) 20)
                  (gui '(+NumField) 10) ) ) )
         (<submit> "Save") ) ) )
########################################################################

with two columns "Text" and "Number", and four rows, each containing a +TextField and a +NumField.

You can enter text into the first column, and numbers into the second. Pressing the "Save" button stores these values in the components on the server (or produces an error message if a string in the second column is not a legal number).

There are two problems with this solution:

  1. Though you can get at the user input for the individual fields, e.g.
    
    : (val> (get *Top 'gui 2))  # Value in the first row, second column
    -> 123
    
    there is no direct way to get the whole data structure as a single list. Instead, you have to traverse all GUI components and collect the data.
  2. The user cannot input more than four rows of data, because there is no easy way to scroll down and make space for more.

A chart can handle these things:


########################################################################
(app)

(action
   (html 0 "Chart" "@lib.css" NIL
      (form NIL
         (gui '(+Chart) 2)                         # Inserted a +Chart
         (<table> NIL NIL '((NIL "Text") (NIL "Number"))
            (do 4
               (<row> NIL
                  (gui 1 '(+TextField) 20)         # Inserted '1'
                  (gui 2 '(+NumField) 10) ) ) )    # Inserted '2'
         (<submit> "Save") ) ) )
########################################################################

Note that we inserted a +Chart component before the GUI components which should be managed by the chart. The argument '2' tells the chart that it has to expect two columns.

Each component got an index number (here '1' and '2') as the first argument to gui, indicating the column into which this component should go within the chart.

Now - if you entered "a", "b" and "c" into the first, and 1, 2, and 3 into the second column - we can retrieve the chart's complete contents by sending it the val> message


: (val> (get *Top 'chart 1))  # Retrieve the value of the first chart
-> (("a" 1) ("b" 2) ("c" 3))

BTW, a more convenient function is chart


: (val> (chart))  # Retrieve the value of the current chart
-> (("a" 1) ("b" 2) ("c" 3))

chart can be used instead of the above construct when we want to access the "current" chart, i.e. the chart most recently processed in the current form.

Scrolling

To enable scrolling, let's also insert two buttons. We use the pre-defined classes +UpButton and +DnButton


########################################################################
(app)

(action
   (html 0 "Scrollable Chart" "@lib.css" NIL
      (form NIL
         (gui '(+Chart) 2)
         (<table> NIL NIL '((NIL "Text") (NIL "Number"))
            (do 4
               (<row> NIL
                  (gui 1 '(+TextField) 20)
                  (gui 2 '(+NumField) 10) ) ) )
         (gui '(+UpButton) 1)                   # Inserted two buttons
         (gui '(+DnButton) 1)
         (----)
         (<submit> "Save") ) ) )
########################################################################

to scroll down and up a single (argument '1') line at a time.

Now it is possible to enter a few rows of data, scroll down, and continue. It is not necessary (except in the beginning, when the scroll buttons are still disabled) to press the "Save" button, because any button in the form will send changes to the server's internal structures before any action is performed.

Put and Get Functions

As we said, a chart is a virtual component to edit two-dimensional data. Therefore, a chart's native data format is a list of lists: Each sublist represents a single row of data, and each element of a row corresponds to a single GUI component.

In the example above, we saw a row like


   ("a" 1)

being mapped to


   (gui 1 '(+TextField) 20)
   (gui 2 '(+NumField) 10)

Quite often, however, such a one-to-one relationship is not desired. The internal data structures may have to be presented in a different form to the user, and user input may need conversion to an internal representation.

For that, a chart accepts - in addition to the "number of columns" argument - two optional function arguments. The first function is invoked to 'put' the internal representation into the GUI components, and the second to 'get' data from the GUI into the internal representation.

A typical example is a chart displaying customers in a database. While the internal representation is a (one-dimensional) list of customer objects, 'put' expands each object to a list with, say, the customer's first and second name, telephone number, address and so on. When the user enters a customer's name, 'get' locates the matching object in the database and stores it in the internal representation. In the following, 'put' will in turn expand it to the GUI.

For now, let's stick with a simpler example: A chart that holds just a list of numbers, but expands in the GUI to show also a textual form of each number (in German).


########################################################################
(app)

(load "@lib/zahlwort.l")

(action
   (html 0 "Numerals" "@lib.css" NIL
      (form NIL
         (gui '(+Init +Chart) (1 5 7) 2
            '((N) (list N (zahlwort N)))
            car )
         (<table> NIL NIL '((NIL "Numeral") (NIL "German"))
            (do 4
               (<row> NIL
                  (gui 1 '(+NumField) 9)
                  (gui 2 '(+Lock +TextField) 90) ) ) )
         (gui '(+UpButton) 1)
         (gui '(+DnButton) 1)
         (----)
         (<submit> "Save") ) ) )
########################################################################

"@lib/zahlwort.l" defines the utility function zahlwort, which is required later by the 'put' function. zahlwort accepts a number and returns its wording in German.

Now look at the code


         (gui '(+Init +Chart) (1 5 7) 2
            '((N) (list N (zahlwort N)))
            car )

We prefix the +Chart class with +Init, and pass it a list of numbers (1 5 7) for the initial value of the chart. Then, following the '2' (the chart has two columns), we pass a 'put' function


            '((N) (list N (zahlwort N)))

which takes a number and returns a list of that number and its wording, and a 'get' function


            car )

which in turn accepts such a list and returns a number, which happens to be the list's first element.

You can see from this example that 'get' is the inverse function of 'put'. 'get' can be omitted, however, if the chart is read-only (contains no (or only locked) input fields).

The field in the second column


                  (gui 2 '(+Lock +TextField) 90) ) ) )

is locked, because it displays the text generated by 'put', and is not supposed to accept any user input.

When you start up this form in your browser, you'll see three pre-filled lines with "1/eins", "5/fünf" and "7/sieben", according to the +Init argument (1 5 7). Typing a number somewhere into the first column, and pressing ENTER or one of the buttons, will show a suitable text in the second column.


GUI Classes

In previous chapters we saw examples of GUI classes like +TextField, +NumField or +Button, often in combination with prefix classes like +Lock, +Init or +Able. Now we take a broader look at the whole hierarchy, and try more examples.

The abstract class +gui is the base of all GUI classes. A live view of the class hierarchy can be obtained with the dep ("dependencies") function:


: (dep '+gui)
+gui
   +JsField
   +Button
      +UpButton
      +PickButton
         +DstButton
      +ClrButton
      +ChoButton
         +Choice
      +GoButton
      +BubbleButton
      +DelRowButton
      +ShowButton
      +DnButton
   +Img
   +field
      +Checkbox
      +TextField
         +FileField
         +ClassField
         +numField
            +NumField
            +FixField
         +BlobField
         +DateField
         +SymField
         +UpField
         +MailField
         +SexField
         +AtomField
         +PwField
         +ListTextField
         +LinesField
         +TelField
         +TimeField
         +HttpField
      +Radio
-> +gui

We see, for example, that +DnButton is a subclass of +Button, which in turn is a subclass of +gui. Inspecting +DnButton directly


: (dep '+DnButton)
   +Tiny
   +Rid
   +JS
   +Able
      +gui
   +Button
+DnButton
-> +DnButton

shows that +DnButton inherits from +Tiny, +Rid, +Able and +Button. The actual definition of +DnButton can be found in "@lib/form.l"


(class +DnButton +Tiny +Rid +JS +Able +Button)
...

In general, "@lib/form.l" is the ultimate reference to the framework, and should be freely consulted.


Input Fields

Input fields implement the visual display of application data, and allow - when enabled - input and modification of these data.

On the HTML level, they can take the form of

Except for checkboxes, which are implemented by the Checkbox class, all these HTML representations are generated by +TextField and its content-specific subclasses like +NumField, +DateField etc. Their actual appearance (as one of the above forms) depends on their arguments:

We saw already "normal" text fields. They are created with a single numeric argument. This example creates an editable field with a width of 10 characters:


   (gui '(+TextField) 10)

If you supply a second numeric for the line count ('4' in this case), you'll get a text area:


   (gui '(+TextField) 10 4)

Supplying a list of values instead of a count yields a drop-down selection (combo box):


   (gui '(+TextField) '("Value 1" "Value 2" "Value 3"))

In addition to these arguments, you can pass a string. Then the field is created with a label:


   (gui '(+TextField) 10 "Plain")
   (gui '(+TextField) 10 4 "Text Area")
   (gui '(+TextField) '("Value 1" "Value 2" "Value 3") "Selection")

Finally, without any arguments, the field will appear as a plain HTML text:


   (gui '(+TextField))

This makes mainly sense in combination with prefix classes like +Var and +Obj, to manage the contents of these fields, and achieve special behavior as HTML links or scrollable chart values.

Numeric Input Fields

A +NumField returns a number from its val> method, and accepts a number for its set> method. It issues an error message when user input cannot be converted to a number.

Large numbers are shown with a thousands-separator, as determined by the current locale.


########################################################################
(app)

(action
   (html 0 "+NumField" "@lib.css" NIL
      (form NIL
         (gui '(+NumField) 10)
         (gui '(+JS +Button) "Print value"
            '(msg (val> (: home gui 1))) )
         (gui '(+JS +Button) "Set to 123"
            '(set> (: home gui 1) 123) ) ) ) )
########################################################################

A +FixField needs an additional scale factor argument, and accepts/returns scaled fixpoint numbers.

The decimal separator is determined by the current locale.


########################################################################
(app)

(action
   (html 0 "+FixField" "@lib.css" NIL
      (form NIL
         (gui '(+FixField) 3 10)
         (gui '(+JS +Button) "Print value"
            '(msg (format (val> (: home gui 1)) 3)) )
         (gui '(+JS +Button) "Set to 123.456"
            '(set> (: home gui 1) 123456) ) ) ) )
########################################################################

Time & Date

A +DateField accepts and returns a date value.


########################################################################
(app)

(action
   (html 0 "+DateField" "@lib.css" NIL
      (form NIL
         (gui '(+DateField) 10)
         (gui '(+JS +Button) "Print value"
            '(msg (datStr (val> (: home gui 1)))) )
         (gui '(+JS +Button) "Set to \"today\""
            '(set> (: home gui 1) (date)) ) ) ) )
########################################################################

The format displayed to - and entered by - the user depends on the current locale (see datStr and expDat). You can change it, for example to


: (locale "DE" "de")
-> NIL

If no locale is set, the format is YYYY-MM-DD. Some pre-defined locales use patterns like DD.MM.YYYY (DE), YYYY/MM/DD (JP), DD/MM/YYYY (UK), or MM/DD/YYYY (US).

An error is issued when user input does not match the current locale's date format.

Independent from the locale setting, a +DateField tries to expand abbreviated input from the user. A small number is taken as that day of the current month, larger numbers expand to day and month, or to day, month and year:

Similar is the +TimeField. It accepts and returns a time value.


########################################################################
(app)

(action
   (html 0 "+TimeField" "@lib.css" NIL
      (form NIL
         (gui '(+TimeField) 8)
         (gui '(+JS +Button) "Print value"
            '(msg (tim$ (val> (: home gui 1)))) )
         (gui '(+JS +Button) "Set to \"now\""
            '(set> (: home gui 1) (time)) ) ) ) )
########################################################################

When the field width is '8', like in this example, time is displayed in the format HH:MM:SS. Another possible value would be '5', causing +TimeField to display its value as HH:MM.

An error is issued when user input cannot be converted to a time value.

The user may omit the colons. If he inputs just a small number, it should be between '0' and '23', and will be taken as a full hour. '125' expands to "12:05", '124517' to "12:45:17", and so on.

Telephone Numbers

Telephone numbers are represented internally by the country code (without a leading plus sign or zero) followed by the local phone number (ideally separated by spaces) and the phone extension (ideally separated by a hyphen). The exact format of the phone number string is not enforced by the GUI, but further processing (e.g. database searches) normally uses fold for better reproducibility.

To display a phone number, +TelField replaces the country code with a single zero if it is the country code of the current locale, or prepends it with a plus sign if it is a foreign country (see telStr).

For user input, a plus sign or a double zero is simply dropped, while a single leading zero is replaced with the current locale's country code (see expTel).


########################################################################
(app)
(locale "DE" "de")

(action
   (html 0 "+TelField" "@lib.css" NIL
      (form NIL
         (gui '(+TelField) 20)
         (gui '(+JS +Button) "Print value"
            '(msg (val> (: home gui 1))) )
         (gui '(+JS +Button) "Set to \"49 1234 5678-0\""
            '(set> (: home gui 1) "49 1234 5678-0") ) ) ) )
########################################################################

Checkboxes

A +Checkbox is straightforward. User interaction is restricted to clicking it on and off. It accepts boolean (NIL or non-NIL) values, and returns T or NIL.


########################################################################
(app)

(action
   (html 0 "+Checkbox" "@lib.css" NIL
      (form NIL
         (gui '(+Checkbox))
         (gui '(+JS +Button) "Print value"
            '(msg (val> (: home gui 1))) )
         (gui '(+JS +Button) "On"
            '(set> (: home gui 1) T) )
         (gui '(+JS +Button) "Off"
            '(set> (: home gui 1) NIL) ) ) ) )
########################################################################


Field Prefix Classes

A big part of this framework's power is owed to the combinatorial flexibility of prefix classes for GUI- and DB-objects. They allow to surgically override individual methods in the inheritance tree, and can be combined in various ways to achieve any desired behavior.

Technically, there is nothing special about prefix classes. They are just normal classes. They are called "prefix" because they are intended to be written before other classes in a class's or object's list of superclasses.

Usually they take their own arguments for their T method from the list of arguments to the gui function.

Initialization

+Init overrides the init> method for that component. The init> message is sent to a +gui component when the page is loaded for the first time (during a GET request). +Init takes an expression for the initial value of that field.


   (gui '(+Init +TextField) "This is the initial text" 30)

Other classes which automatically give a value to a field are +Var (linking the field to a variable) and +E/R (linking the field to a database entity/relation).

+Cue can be used, for example in "mandatory" fields, to give a hint to the user about what he is supposed to enter. It will display the argument value, in angular brackets, if and only if the field's value is NIL, and the val> method will return NIL despite the fact that this value is displayed.

Cause an empty field to display "<Please enter some text here>":


   (gui '(+Cue +TextField) "Please enter some text here" 30)

Disabling and Enabling

An important feature of an interactive GUI is the context-sensitive disabling and enabling of individual components, or of a whole form.

The +Able prefix class takes an argument expression, and disables the component if this expression returns NIL. We saw an example for its usage already in the square root button of the calculator example. Or, for illustration purposes, imagine a button which is supposed to be enabled only after Christmas


   (gui '(+Able +Button)
      '(>= (cdr (date (date))) (12 24))
      "Close this year"
      '(endOfYearProcessing) )

or a password field that is disabled as long as somebody is logged in


   (gui '(+Able +PwField) '(not *Login) 10 "Password")

A special case is the +Lock prefix, which permanently and unconditionally disables a component. It takes no arguments


   (gui '(+Lock +NumField) 10 "Count")

('10' and "Count" are for the +NumField), and creates a read-only field.

The whole form can be disabled by calling disable with a non-NIL argument. This affects all components in this form. Staying with the above example, we can make the form read-only until Christmas


   (form NIL
      (disable (> (12 24) (cdr (date (date)))))  # Disable whole form
      (gui ..)
      .. )

Even in a completely disabled form, however, it is often necessary to re-enable certain components, as they are needed for navigation, scrolling, or other activities which don't affect the contents of the form. This is done by prefixing these fields with +Rid (i.e. getting "rid" of the lock).


   (form NIL
      (disable (> (12 24) (cdr (date (date)))))
      (gui ..)
      ..
      (gui '(+Rid +Button) ..)  # Button is enabled despite the disabled form
      .. )

Formatting

GUI prefix classes allow a fine-grained control of how values are stored in - and retrieved from - components. As in predefined classes like +NumField or +DateField, they override the set> and/or val> methods.

+Set takes an argument function which is called whenever that field is set to some value. To convert all user input to upper case


   (gui '(+Set +TextField) uppc 30)

+Val is the complement to +Set. It takes a function which is called whenever the field's value is retrieved. To return the square of a field's value


   (gui '(+Val +NumField) '((N) (* N N)) 10)

+Fmt is just a combination of +Set and +Val, and takes two functional arguments. This example will display upper case characters, while returning lower case characters internally


   (gui '(+Fmt +TextField) uppc lowc 30)

+Map does (like +Fmt) a two-way translation. It uses a list of cons pairs for a linear lookup, where the CARs represent the displayed values which are internally mapped to the values in the CDRs. If a value is not found in this list during set> or val>, it is passed through unchanged.

Normally, +Map is used in combination with the combo box incarnation of text fields (see Input Fields). This example displays "One", "Two" and "Three" to the user, but returns a number 1, 2 or 3 internally


########################################################################
(app)

(action
   (html 0 "+Map" "@lib.css" NIL
      (form NIL
         (gui '(+Map +TextField)
            '(("One" . 1) ("Two" . 2) ("Three" . 3))
            '("One" "Two" "Three") )
         (gui '(+Button) "Print"
            '(msg (val> (field -1))) ) ) ) )
########################################################################

Side Effects

Whenever a button is pressed in the GUI, any changes caused by action in the current environment (e.g. the database or application state) need to be reflected in the corresponding GUI fields. For that, the upd> message is sent to all components. Each component then takes appropriate measures (e.g. refresh from database objects, load values from variables, or calculate a new value) to update its value.

While the upd> method is mainly used internally, it can be overridden in existing classes via the +Upd prefix class. Let's print updated values to standard error


########################################################################
(app)
(default *Number 0)

(action
   (html 0 "+Upd" "@lib.css" NIL
      (form NIL
         (gui '(+Upd +Var +NumField)
            '(prog (extra) (msg *Number))
            '*Number 8 )
         (gui '(+JS +Button) "Increment"
            '(inc '*Number) ) ) ) )
########################################################################

Validation

To allow automatic validation of user input, the chk> message is sent to all components at appropriate times. The corresponding method should return NIL if the value is all right, or a string describing the error otherwise.

Many of the built-in classes have a chk> method. The +NumField class checks for legal numeric input, or the +DateField for a valid calendar date.

An on-the-fly check can be implemented with the +Chk prefix class. The following code only accepts numbers not bigger than 9: The or expression first delegates the check to the main +NumField class, and - if it does not give an error - returns an error string when the current value is greater than 9.


########################################################################
(app)

(action
   (html 0 "+Chk" "@lib.css" NIL
      (form NIL
         (gui '(+Chk +NumField)
            '(or
               (extra)
               (and (> (val> This) 9) "Number too big") )
            12 )
         (gui '(+JS +Button) "Print"
            '(msg (val> (field -1))) ) ) ) )
########################################################################

A more direct kind of validation is built-in via the +Limit class. It controls the maxlength attribute of the generated HTML input field component. Thus, it is impossible to type to more characters than allowed into the field.


########################################################################
(app)

(action
   (html 0 "+Limit" "@lib.css" NIL
      (form NIL
         (gui '(+Limit +TextField) 4 8)
         (gui '(+JS +Button) "Print"
            '(msg (val> (field -1))) ) ) ) )
########################################################################

Data Linkage

Although set> and val> are the official methods to get a value in and out of a GUI component, they are not very often used explicitly. Instead, components are directly linked to internal Lisp data structures, which are usually either variables or database objects.

The +Var prefix class takes a variable (described as the var data type - either a symbol or a cons pair - in the Function Reference). In the following example, we initialize a global variable with the value "abc", and let a +TextField operate on it. The "Print" button can be used to display its current value.


########################################################################
(app)

(setq *TextVariable "abc")

(action
   (html 0 "+Var" "@lib.css" NIL
      (form NIL
         (gui '(+Var +TextField) '*TextVariable 8)
         (gui '(+JS +Button) "Print"
            '(msg *TextVariable) ) ) ) )
########################################################################

+E/R takes an entity/relation specification. This is a cons pair, with a relation in its CAR (e.g. nm, for an object's name), and an expression in its CDR (typically (: home obj), the object stored in the obj property of the current form).

For an isolated, simple example, we create a temporary database, and access the nr and nm properties of an object stored in a global variable *Obj.


########################################################################
(when (app)                # On start of session
   (class +Tst +Entity)    # Define data model
   (rel nr (+Number))      # with a number
   (rel nm (+String))      # and a string
   (pool (tmp "db"))       # Create temporary DB
   (setq *Obj              # and a single object
      (new! '(+Tst) 'nr 1 'nm "New Object") ) )

(action
   (html 0 "+E/R" "@lib.css" NIL
      (form NIL
         (gui '(+E/R +NumField) '(nr . *Obj) 8)    # Linkage to 'nr'
         (gui '(+E/R +TextField) '(nm . *Obj) 20)  # Linkage to 'nm'
         (gui '(+JS +Button) "Show"                # Show the object
            '(out 2 (show *Obj)) ) ) ) )           # on standard error
########################################################################


Buttons

Buttons are, as explained in Control Flow, the only way (via POST requests) for an application to communicate with the server.

Basically, a +Button takes

Here is a minimal button, with just a label and an expression:


   (gui '(+Button) "Label" '(doSomething))

And this is a button displaying different labels, depending on the state:


   (gui '(+Button) "Enabled" "Disabled" '(doSomething))

To show an image instead of plain text, the label(s) must be preceeded by the T symbol:


   (gui '(+Button) T "img/enabled.png" "img/disabled.png" '(doSomething))

The expression will be executed during action handling (see Action Forms), when this button was pressed.

Like other components, buttons can be extended and combined with prefix classes, and a variety of predefined classes and class combinations are available.

Dialog Buttons

Buttons are essential for the handling of alerts and dialogs. Besides buttons for normal functions, like scrolling in charts or other side effects, special buttons exist which can close an alert or dialog in addition to doing their principal job.

Such buttons are usually subclasses of +Close, and most of them can be called easily with ready-made functions like closeButton, cancelButton, yesButton or noButton. We saw a few examples in Alerts and Dialogs.

Active JavaScript

When a button inherits from the +JS class (and JavaScript is enabled in the browser), that button will possibly show a much faster response in its action.

The reason is that the activation of a +JS button will - instead of doing a normal POST - first try to send only the contents of all GUI components via an XMLHttpRequest to the server, and receive the updated values in response. This avoids the flicker caused by reloading and rendering of the whole page, is much faster, and also does not jump to the beginning of the page if it is larger than the browser window. The effect is especially noticeable while scrolling in charts.

Only if this fails, for example because an error message was issued, or a dialog popped up, it will fall back, and the form will be POSTed in the normal way.

Thus it makes no sense to use the +JS prefix for buttons that cause a change of the HTML code, open a dialog, or jump to another page. In such cases, overall performance will even be worse, because the XMLHttpRequest is tried first (but in vain).

When JavaScript is disabled int the browser, the XMLHttpRequest will not be tried at all. The form will be fully usable, though, with identical functionality and behavior, just a bit slower and not so smooth.


A Minimal Complete Application

The PicoLisp release includes in the "app/" directory a minimal, yet complete reference application. This application is typical, in the sense that it implements many of the techniques described in this document, and it can be easily modified and extended. In fact, we use it as templates for our own production application development.

It is a kind of simplified ERP system, containing customers/suppliers, products (items), orders, and other data. The order input form performs live updates of customer and product selections, price, inventory and totals calculations, and generates on-the-fly PDF documents. Fine-grained access permissions are controlled via users, roles and permissions. It comes localized in six languages (English, Spanish, German, Norwegian, Russian and Japanese), with some initial data and two sample reports.


Getting Started

For a global installation (see Installation), please create a symbolic link to the place where the program files are installed. This is necessary because the application needs read/write access to the current working directory (for the database and other runtime data).


$ ln -s /usr/share/picolisp/app

As ever, you may start up the application in debugging mode


$ pil app/main.l -main -go +

or in (non-debug) production mode


$ pil app/main.l -main -go -wait

and go to 'http://localhost:8080' with your browser. You can login as user "admin", with password "admin". The demo data contain several other users, but those are more restricted in their role permissions.

Another possibility is to try the online version of this application at app.7fach.de.

Localization

Before or after you logged in, you can select another language, and click on the "Change" button. This will effect all GUI components (though not text from the database), and also the numeric, date and telephone number formats.

Navigation

The navigation menu on the left side shows two items "Home" and "logout", and three submenus "Data", "Report" and "System".

Both "Home" and "logout" bring you back to the initial login form. Use "logout" if you want to switch to another user (say, for another set of permissions), and - more important - before you close your browser, to release possible locks and process resources on the server.

The "Data" submenu gives access to application specific data entry and maintenance: Orders, product items, customers and suppliers. The "Report" submenu contains two simple inventory and sales reports. And the "System" submenu leads to role and user administration.

You can open and close each submenu individually. Keeping more than one submenu open at a time lets you switch rapidly between different parts of the application.

The currently active menu item is indicated by a highlighted list style (no matter whether you arrived at this page directly via the menu or by clicking on a link somewhere else).

Choosing Objects

Each item in the "Data" or "System" submenu opens a search dialog for that class of entities. You can specify a search pattern, press the top right "Search" button (or just ENTER), and scroll through the list of results.

While the "Role" and "User" entities present simple dialogs (searching just by name), other entities can be searched by a variety of criteria. In those cases, a "Reset" button clears the contents of the whole dialog. A new object can be created with bottom right "New" button.

In any case, the first column will contain either a "@"-link (to jump to that object) or a "@"-button (to insert a reference to that object into the current form).

By default, the search will list all database objects with an attribute value greater than or equal to the search criterion. The comparison is done arithmetically for numbers, and alphabetically (case sensitive!) for text. This means, if you type "Free" in the "City" field of the "Customer/Supplier" dialog, the value of "Freetown" will be matched. On the other hand, an entry of "free" or "town" will yield no hits.

Some search fields, however, show a different behavior depending on the application:

Using the bottom left scroll buttons, you can scroll through the result list without limit. Clicking on a link will bring up the corresponding object. Be careful here to select the right column: Some dialogs (those for "Item" and "Order") also provide links for related entities (e.g. "Supplier").

Editing

A database object is usually displayed in its own individual form, which is determined by its entity class.

The basic layout should be consistent for all classes: Below the heading (which is usually the same as the invoking menu item) is the object's identifier (name, number, etc.), and then a row with an "Edit" button on the left, and "Delete" button, a "Select" button and two navigation links on the right side.

The form is brought up initially in read-only mode. This is necessary to prevent more than one user from modifying an object at the same time (and contrary to the previous PicoLisp Java frameworks, where this was not a problem because all changes were immediately reflected in the GUIs of other users).

So if you want to modify an object, you have to gain exclusive access by clicking on the "Edit" button. The form will be enabled, and the "Edit" button changes to "Done". Should any other user already have reserved this object, you will see a message telling his name and process ID.

An exception to this are objects that were just created with "New". They will automatically be reserved for you, and the "Edit" button will show up as "Done".

The "Delete" button pops up an alert, asking for confirmation. If the object is indeed deleted, this button changes to "Restore" and allows to undelete the object. Note that objects are never completely deleted from the database as long as there are any references from other objects. When a "deleted" object is shown, its identifier appears in square brackets.

The "Select" button (re-)displays the search dialog for this class of entities. The search criteria are preserved between invocations of each dialog, so that you can conveniently browse objects in this context.

The navigation links, pointing left and right, serve a similar purpose. They let you step sequentially through all objects of this class, in the order of the identifier's index.

Other buttons, depending on the entity, are usually arranged at the bottom of the form. The bottom rightmost one should always be another "Edit" / "Done" button.

As we said in the chapter on Scrolling, any button in the form will save changes to the underlying data model. As a special case, however, the "Done" button releases the object and reverts to "Edit". Besides this, the edit mode will also cease as soon as another object is displayed, be it by clicking on an object link (the pencil icon), the top right navigation links, or a link in a search dialog.

Buttons vs. Links

The only way to interact with a HTTP-based application server is to click either on a HTML link, or on a submit button (see also Control Flow). It is essential to understand the different effects of such a click on data entered or modified in the current form.

For that reason the layout design should clearly differentiate between links and buttons. Image buttons are not a good idea when in other places images are used for links. The standard button components should be preferred; they are usually rendered by the browser in a non-ambiguous three-dimensional look and feel.

Note that if JavaScript is enabled in the browser, changes will be automatically committed to the server.

The enabled or disabled state of a button is an integral part of the application logic. It must be indicated to the user with appropriate styles.


The Data Model

The data model for this mini application consists of only six entity classes (see the E/R diagram at the beginning of "app/er.l"):

The classes +Role and +User are defined in "@lib/adm.l". A +Role has a name, a list of permissions, and a list of users assigned to this role. A +User has a name, a password and a role.

In "app/er.l", the +Role class is extended to define an url> method for it. Any object whose class has such a method is able to display itself in the GUI. In this case, the file "app/role.l" will be loaded - with the global variable *ID pointing to it - whenever an HTML link to this role object is activated.

The +User class is also extended. In addition to the login name, a full name, telephone number and email address is declared. And, of course, the ubiquitous url> method.

The application logic is centered around orders. An order has a number, a date, a customer (an instance of +CuSu) and a list of positions (+Pos objects). The sum> method calculates the total amount of this order.

Each position has an +Item object, a price and a quantity. The price in the position overrides the default price from the item.

Each item has a number, a description, a supplier (also an instance of +CuSu), an inventory count (the number of these items that were counted at the last inventory taking), and a price. The cnt> method calculates the current stock of this item as the difference of the inventory and the sold item counts.

The call to dbs at the end of "app/er.l" configures the physical database storage. Each of the supplied lists has a number in its CAR which determines the block size as (64 << N) of the corresponding database file. The CDR says that the instances of this class (if the element is a class symbol) or the tree nodes (if the element is a list of a class symbol and a property name) are to be placed into that file. This allows for some optimizations in the database layout.


Usage

When you are connected to the application (see Getting Started) you might try to do some "real" work with it. Via the "Data" menu (see Navigation) you can create or modify customers, suppliers, items and orders, and produce simple overviews via the "Report" menu.

Customer/Supplier

Source in "app/cusu.l"

The Customer/Supplier search dialog (choCuSu in "app/gui.l") supports a lot of search criteria. These become necessary when the database contains a large number of customers, and can filter by zip, by phone number prefixes, and so on.

In addition to the basic layout (see Editing), the form is divided into four separate tabs. Splitting a form into several tabs helps to reduce traffic, with possibly better GUI response. In this case, four tabs are perhaps overkill, but ok for demonstration purposes, and they leave room for extensions.

Be aware that when data were modified in one of the tabs, the "Done" button has to be pressed before another tab is clicked, because tabs are implemented as HTML links (see Buttons vs. Links).

New customers or suppliers will automatically be assigned the next free number. You can enter another number, but an error will result if you try to use an existing number. The "Name" field is mandatory, you need to overwrite the "<Name>" clue.

Phone and fax numbers in the "Contact" tab must be entered in the correct format, depending on the locale (see Telephone Numbers).

The "Memo" tab contains a single text area. It is no problem to use it for large pieces of text, as it gets stored in a database blob internally.

Item

Source in "app/item.l"

Items also have a unique number, and a mandatory "Description" field.

To assign a supplier, click on the "+" button. The Customer/Supplier search dialog will appear, and you can pick the desired supplier with the "@" button in the first column. Alternatively, if you are sure to know the exact spelling of the supplier's name, you can also enter it directly into the text field.

In the search dialog you may also click on a link, for example to inspect a possible supplier, and then return to the search dialog with the browser's back button. The "Edit" mode will then be lost, however, as another object has been visited (this is described in the last part of Editing).

You can enter an inventory count, the number of items currently in stock. The following field will automatically reflect the remaining pieces after some of these items were sold (i.e. referenced in order positions). It cannot be changed manually.

The price should be entered with the decimal separator according to the current locale. It will be formatted with two places after the decimal separator.

The "Memo" is for an arbitrary info text, like in Customer/Supplier above, stored in a database blob.

Finally, a JPEG picture can be stored in a blob for this item. Choose a file with the browser's file select control, and click on the "Install" button. The picture will appear at the bottom of the page, and the "Install" button changes to "Uninstall", allowing the picture's removal.

Order

Source in "app/ord.l"

Oders are identified by number and date.

The number must be unique. It is assigned when the order is created, and cannot be changed for compliance reasons.

The date is initialized to "today" for a newly created order, but may be changed manually. The date format depends on the locale. It is YYYY-MM-DD (ISO) by default, DD.MM.YYYY in the German and YYYY/MM/DD in the Japanese locale. As described in Time & Date, this field allows input shortcuts, e.g. just enter the day to get the full date in the current month.

To assign a customer to this order, click on the "+" button. The Customer/Supplier search dialog will appear, and you can pick the desired customer with the "@" button in the first column (or enter the name directly into the text field), just as described above for Items.

Now enter order the positions: Choose an item with the "+" button. The "Price" field will be preset with the item's default price, you may change it manually. Then enter a quantity, and click a button (typically the "+" button to select the next item, or a scroll button go down in the chart). The form will be automatically recalculated to show the total prices for this position and the whole order.

Instead of the "+" or scroll buttons, as recommended above, you could of course also press the "Done" button to commit changes. This is all right, but has the disadvantage that the button must be pressed a second time (now "Edit") if you want to continue with the entry of more positions.

The "x" button at the right of each position deletes that position without further confirmation. It has to be used with care!

The "^" button is a "bubble" button. It exchanges a row with the row above it. Therefore, it can be used to rearrange all items in a chart, by "bubbling" them to their desired positions.

The "PDF-Print" button generates and displays a PDF document for this order. The browser should be configured to display downloaded PDF documents in an appropriate viewer. The source for the postscript generating method is in "app/lib.l". It produces one or several A4 sized pages, depending on the number of positions.

Reports

Sources in "app/inventory.l and "app/sales.l"

The two reports ("Inventory" and "Sales") come up with a few search fields and a "Show" button.

If no search criteria are entered, the "Show" button will produce a listing of the relevant part of the whole database. This may take a long time and cause a heavy load on the browser if the database is large.

So in the normal case, you will limit the domain by stating a range of item numbers, a description pattern, and/or a supplier for the inventory report, or a range of order dates and/or a customer for the sales report. If a value in a range specification is omitted, the range is considered open in that direction.

At the end of each report appears a "CSV" link. It downloads a file with the TAB-separated values generated by this report. picolisp-3.1.5.2.orig/doc/db0000644000000000000000000000700512265263724014227 0ustar rootroot Max DB-Size: 7 digits -> 2**42 (4 Tera) Blocks Blocksize 64 -> (2**48 Bytes (256 TB)) Tree NIL -> (val *DB) {x} -> (val '{x}) (var . {x}) -> (get '{x} 'var) (var . +Cls) -> (get *DB '+Cls 'var) (var +Cls . {x}) -> (get '{x} '+Cls 'var) B-Tree root: (cnt . node) B-Tree node: (less (key more . value) (key more . value) ..) (less ((key . value) more) ((key . value) more) ..) Per node BEG EXTERN <6> .. NIX 6+1+1+6+1 = 15 Per key BEG TRANSIENT EXTERN <7> DOT EXTERN <7> 1+1++1+6+1+1+7 = 18 + Key Arguments for DB- and Pilog-functions: 123, {abc} -> (123) (123 . T) T -> All "abc" -> ("abc") ("abcT" . T) (a b) -> (a b) (a b . T) ((a 1) b 2) -> (a 1) (b 2 . T) ((1 . 3) (4 . 7)) -> (33 . 61) (a . b) -> (a) (b . T) (b . a) -> (b . T) (a) loaded/dirty/deleted | | | | | (1) | (2) | (3) | | | | | ---------+-----------------+-----------------+-----------------+ | load | load | empty | NIL | -> loaded | -> dirty | -> deleted | | | | | ---------+-----------------+-----------------+-----------------+ | | | empty | loaded | | -> dirty | -> deleted | | | | | ---------+-----------------+-----------------+-----------------+ | | | empty | dirty | | | -> deleted | | | | | ---------+-----------------+-----------------+-----------------+ | | | | deleted | | | | | | | | | | | | commit | rollback | | | | -------------+-----------------+-----------------+ | | | NIL | | | | | | -------------+-----------------+-----------------+ | | empty | (1) loaded | | -> NIL | | | | -------------+-----------------+-----------------+ | save | empty | (2) dirty | -> loaded | -> NIL | | | | -------------+-----------------+-----------------+ | empty | empty | (3) deleted | -> NIL | -> NIL | | | | +-----+-----+ | V1 | | | +-----+--+--+ | V +-----+-----+ +-----+-----+ | P1 | ---+---> | N | ---+---> @@ +-----+-----+ +-----+-----+ picolisp-3.1.5.2.orig/doc/doc.css0000644000000000000000000000073012265263724015174 0ustar rootroot/* 19may07abu * 06dec12jk * (c) Software Lab. Alexander Burger */ html { background-color: #ddd; } body { margin: auto; max-width: 48em; border: 1px solid #bbb; background-color: white; padding: 2em 7% 4em 10%; } h5 { font-size: 95%; margin-bottom: 1em; } dt { margin: 0.4em -2em 0 0; font-weight: 600; color: #444; } dd { margin-top: 0.3em; margin-bottom: 0.4em; } code { color: rgb(0%,40%,0%); } dt code { word-spacing: -0.04em; } picolisp-3.1.5.2.orig/doc/family.l0000644000000000000000000002261012265263724015354 0ustar rootroot# 19jul13abu # (c) Software Lab. Alexander Burger (load "@lib/http.l" "@lib/xhtml.l" "@lib/form.l" "@lib/ps.l") ### DB ### (class +Person +Entity) (rel nm (+Need +Sn +Idx +String)) # Name (rel pa (+Joint) kids (+Man)) # Father (rel ma (+Joint) kids (+Woman)) # Mother (rel mate (+Joint) mate (+Person)) # Partner (rel job (+Ref +String)) # Occupation (rel dat (+Ref +Date)) # born (rel fin (+Ref +Date)) # died (rel txt (+String)) # Info (dm url> (Tab) (list "!person" '*ID This) ) (class +Man +Person) (rel kids (+List +Joint) pa (+Person)) # Children (class +Woman +Person) (rel kids (+List +Joint) ma (+Person)) # Children (dbs (0) # (1 . 64) (2 +Person) # (2 . 256) (3 (+Person nm)) # (3 . 512) (3 (+Person job dat fin)) ) # (4 . 512) ### GUI ### (de choPerson (Dst) (diaform '(Dst) ( "--.-.-." "Name" (gui 'nm '(+Focus +Var +TextField) '*PrsNm 20) "Occupation" (gui 'job '(+Var +TextField) '*PrsJob 20) "born" (prog (gui 'dat1 '(+Var +DateField) '*PrsDat1 10) (gui 'dat2 '(+Var +DateField) '*PrsDat2 10) ) (searchButton '(init> (: home query))) "Father" (gui 'pa '(+Var +TextField) '*PrsPa 20) "Mother" (gui 'ma '(+Var +TextField) '*PrsMa 20) "Partner" (gui 'mate '(+Var +TextField) '*PrsMate 20) (resetButton '(nm pa ma mate job dat1 dat2 query)) ) (gui 'query '(+QueryChart) (cho) '(goal (quote @Nm *PrsNm @Pa *PrsPa @Ma *PrsMa @Mate *PrsMate @Job *PrsJob @Dat (and (or *PrsDat1 *PrsDat2) (cons *PrsDat1 (or *PrsDat2 T))) (select (@@) ((nm +Person @Nm) (nm +Person @Pa kids) (nm +Person @Ma kids) (nm +Person @Mate mate) (job +Person @Job) (dat +Person @Dat) ) (tolr @Nm @@ nm) (tolr @Pa @@ pa nm) (tolr @Ma @@ ma nm) (tolr @Mate @@ mate nm) (head @Job @@ job) (range @Dat @@ dat) ) ) ) 7 '((This) (list This This (: pa) (: ma) (: mate) (: job) (: dat))) ) ( 'chart NIL '((btn) (NIL "Name") (NIL "Father") (NIL "Mother") (NIL "Partner") (NIL "Occupation") (NIL "born")) (do (cho) ( (alternating) (gui 1 '(+DstButton) Dst) (gui 2 '(+ObjView +TextField) '(: nm)) (gui 3 '(+ObjView +TextField) '(: nm)) (gui 4 '(+ObjView +TextField) '(: nm)) (gui 5 '(+ObjView +TextField) '(: nm)) (gui 6 '(+TextField)) (gui 7 '(+DateField)) ) ) ) ( (scroll (cho)) ( 4) (prin "Man") (newButton T Dst '(+Man) 'nm *PrsNm) () (prin "Woman") (newButton T Dst '(+Woman) 'nm *PrsNm) ( 4) (cancelButton) ) ) ) # Person HTML Page (de person () (app) (action (html 0 (get (default *ID (val *DB)) 'nm) "@lib.css" NIL (form NIL (

NIL ( (: nm))) (panel T "Person '@1'" T '(choPerson) 'nm '+Person) (

NIL (gui '(+E/R +TextField) '(nm : home obj) 40 "Name") (gui '(+ClassField) '(: home obj) '(("Male" +Man) ("Female" +Woman))) ) ( 5 "Occupation" (gui '(+E/R +TextField) '(job : home obj) 20) "Father" (choPerson 0) (gui '(+E/R +Obj +TextField) '(pa : home obj) '(nm +Man) 30) "born" (gui '(+E/R +DateField) '(dat : home obj) 10) "Mother" (choPerson 0) (gui '(+E/R +Obj +TextField) '(ma : home obj) '(nm +Woman) 30) "died" (gui '(+E/R +DateField) '(fin : home obj) 10) "Partner" (choPerson 0) (gui '(+E/R +Obj +TextField) '(mate : home obj) '(nm +Person) 30) ) (gui '(+E/R +Chart) '(kids : home obj) 5 '((This) (list NIL This (: dat) (: pa) (: ma))) cadr ) (

NIL NIL '(NIL (NIL "Children") (NIL "born") (NIL "Father") (NIL "Mother")) (do 4 ( NIL (choPerson 1) (gui 2 '(+Obj +TextField) '(nm +Person) 20) (gui 3 '(+E/R +DateField) '(dat curr) 10) (gui 4 '(+ObjView +TextField) '(: nm) 20) (gui 5 '(+ObjView +TextField) '(: nm) 20) ) ) ( NIL NIL (scroll 4)) ) (----) (gui '(+E/R +TextField) '(txt : home obj) 40 4) (gui '(+Rid +Button) "Contemporaries" '(url "!contemporaries" (: home obj)) ) (gui '(+Rid +Button) "Tree View" '(url "!treeReport" (: home obj)) ) (editButton T) ) ) ) ) ### Reports ### # Show all contemporaries of a person (de contemporaries (*ID) (action (html 0 "Contemporaries" "@lib.css" NIL (form NIL (

NIL ( "Contemporaries of " (: nm))) (ifn (: obj dat) (

NIL (ht:Prin "No birth date for " (: obj nm))) (gui '(+QueryChart) 12 '(goal (quote @Obj (: home obj) @Dat (: home obj dat) @Beg (- (: home obj dat) 36525) @Fin (or (: home obj fin) (+ (: home obj dat) 36525)) (db dat +Person (@Beg . @Fin) @@) (different @@ @Obj) (^ @ (>= (get (-> @@) 'fin) (-> @Dat))) (^ @ (<= (get (-> @@) 'dat) (-> @Fin))) ) ) 7 '((This) (list This (: job) (: dat) (: fin) (: pa) (: ma) (: mate)) ) ) (

NIL (pack (datStr (: obj dat)) " - " (datStr (: obj fin))) (quote (NIL "Name") (NIL "Occupation") (NIL "born") (NIL "died") (NIL "Father") (NIL "Mother") (NIL "Partner") ) (do 12 ( NIL (gui 1 '(+ObjView +TextField) '(: nm)) (gui 2 '(+TextField)) (gui 3 '(+DateField)) (gui 4 '(+DateField)) (gui 5 '(+ObjView +TextField) '(: nm)) (gui 6 '(+ObjView +TextField) '(: nm)) (gui 7 '(+ObjView +TextField) '(: nm)) ) ) ) (scroll 12) (----) (gui '(+Rid +Button) "Textfile" '(let Txt (tmp "Contemporaries.txt") (out Txt (txt> (chart))) (url Txt) ) ) (gui '(+Rid +Button) "PDF" '(psOut NIL "Contemporaries" (out (tmp "Contemporaries.txt") (txt> (chart)) ) (in (tmp "Contemporaries.txt") (let (Page 1 Fmt (200 120 50 50 120 120 120) Ttl (line T)) (a4L "Contemporaries") (font (7 . "Helvetica")) (indent 30 10) (down 12) (font 9 (ps Ttl)) (down 12) (table Fmt "Name" "Occupation" "born" "died" "Father" "Mother" "Partner" ) (down 6) (pages 560 (page T) (down 12) (ps (pack Ttl ", Page " (inc 'Page))) (down 12) ) (until (eof) (let L (split (line) "^I") (down 8) (table Fmt (font "Helvetica-Bold" (ps (head 50 (car L)))) (ps (head 30 (cadr L))) (ps (get L 3)) (ps (get L 4)) (ps (head 30 (get L 5))) (ps (head 30 (get L 6))) (ps (head 30 (get L 7))) ) (down 4) ) ) ) ) (page) ) ) ) ) ) ) ) # Tree display of a person's descendants (de treeReport (This) (html 0 "Family Tree View" "@lib.css" NIL (

NIL "Family Tree View") (
    NIL (recur (This) (when (try 'url> This 1) (
  • NIL ( (: nm) (mkUrl @)) (when (try 'url> (: mate) 1) (prin " -- ") ( (: mate nm) (mkUrl @)) ) ) (when (: kids) (
      NIL (mapc recurse (: kids))) ) ) ) ) ) ) ### RUN ### (de main () (pool "family/" *Dbs) (unless (val *DB) (put> (set *DB (request '(+Man) 'nm "Adam")) 'mate (request '(+Woman) 'nm "Eve") ) (commit) ) ) (de go () (rollback) (server 8080 "!person") ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/doc/family.tgz0000644000000000000000000003350512265263724015732 0ustar rootrootQ=klye |_{jwRIߋD_"E(-=c$FbI8n8 BFZE? J!:QHGrvޏYrEnFֵ-m\|;bq* T.t bw),[6+Mm5G!V8 %!ؒb&grj+dc-!+,32Nbnh~w0~iϹ:&|;je# ܴ 9۪;5\aG`lZ?ئr9F\n0{Pu;Tłޜ3Iٮ4>y8|NOb i.Q|%uj)۪ E] CT ә[VTE\;gb|k0.˕je̓M7zOOj#0ܕ#C$qbr_+)R!;[`}l,H-z7 RM-cb*  HV3ܴ0jp-UTMx*,ۇ2;d|2,[kGG#F8 .2hO\Sr Ӛob>]iUbg`, MӨWeZ xRC.6jAfpEcȬeZk6' ?F-nnrAqi}N"yAP,< HB: !p0! k! ?(`z=Ua XԍMz5C92lm4I(TpL0mdNō.mvMƲPu'&,PL)}U)]j]\or㪬W檌(9<7 vS2t2!ͦCRkgAMXxA+|Eni6D6{AቱJ_ղ2aRrD׋x~<у4ee0?jH' xio&;=bDa)'1*9VλN"iq̽ SڑL;%S9gf1)c}mhI 6r3aB1F;:jp`zI0\4=enaWXn7֑[78v]/(td .Ӧf`ޡPbiqC)§[Fѹsqو188㾀 IY[0ֶ O 1fXlՖiQ|ݷ bQ}g;Azm[JݖaUqZfmhlʴkUXjx $ h!aÌEX+[I.;;bv)dnf0ىb/#(T 3cgM+ 7čL`MwXHbɫeVYBc ppT!6{N:;+5&x^D'!XBܘ~1)8@;>MphYTuvl3hvX/{x9cM6M,\=IQ,Xd[hwRL[T٥Hyf*V Ζ|h= [QI {؍f4A֐FѴP(x:c^Ǹiny$NCa604\,t<:?|r-zHn⢸\n+0e!eNrժGV0 93S18 nG8j )Z?uY{*:)K:+Zsl> `xDVӶZr"jVOi #WYv6 "ڂ -VA{hX45 vfnW7餜iV is5[M6ۚgΒl`}sua(`<jT[ǟK׍nw߷mom̲:[ҍu^ڿoDZw^45ɉǫ'UZFqhҌVjn 8VtNqݾQ˩0y1tս-& fסdql;%}¥PcS^B-z2G [ '~]Lυؼaig̟ಮCg &oYh]0P_ ZE/?_ffc  'N/DYRBG=/C=38Ek_l4+s͑?T=Մk6M]1ͷ_ a+䟇+7L^xeRH(& =L]XV.XE^f δpC :}U᰸q`G#/ϪV)UuobO}+e$ U%DڦN+| ~?Ugh*_7MOޠX+퇇ӞS+`:J{9C1s:ߗI껅w8uZxڏϥ]9~- }+KW#jԹ=Je={J]3n8LƜZ~5[h[Ϋ(ui/JSN{I[t"u{4Ԥgһ4dPSG:SG·?O{ `A,7 ȿJC |b(/(CK S 0%IY@ݞM}8+QDYm4ӣh/HQ^])  3TYЙkՋ_+_#ͽ#bSoH(-)D[)@ x /]|$.+.?N y1֕ FG_c)+4t:r5?D xk+N$׺>>T]Gy: ɃiAx_z nZQ/X1Zq9lՒ[M{yŴW2ZL]¤ӴW޾Ba?u1L}z7i?1z_Nߥ;#SGx)~&Mކ`޾RnM]꣎pPGNQgNv=iOֵnzO@s?#K͚lr-O P龆q&~[GusIsIԔjsB*lTpffòMC:\&L(໑W۲_F @o$`W܊dSIS֫ćG "ab@`?ҍv$7Z\cƸjlۆyWNzA~`WedxF&8/ve'8/ #~HD] )C 7sdzhz!pWS["݋'4e:3ֹ;ae`ϧ~. e H&oIkFgG3XaE싶=;4eZ=//l IPL"ģS e]6!( (J07G`pN^,UMm&h+!bWꞈaQ]1G8x$ND>xHD'Njb qB8Fatoz濎ǀCNZ2t-qtX?gƸl/n;hE -ASGFu{=cJ*9aCF<aC-IBS"nsKD`071}楀1I VOa߾qKwۏ@ {Ff7C*C@N>/H?Me z7P0h}憠nDF āsFZ)r-/rÈߤa=ٶ?p5)n5N8$6ze1a*g,+{JEDH ˼FLH./:L[Lw&TH Ep;hH (k$GR9L|QH&sbs@i4Xt_CXG0)aHm5%Ѵ er1ݝCմ)o00:D/9dΜUaL`Gp#-2ɰOxKZR >h |H<|*xSE<ٳ3Ł'u?IۑhK(~Tte 0N,~Ma1A'EK)ӜmsR-?k`ooGvOk5w7´wb蟓[pxms"S;~"}5z*"zu)z#"A~q)!$R B;MC /֢pMV0c&<sh@-OO>|t4g Yak UAKMy"eۢB\|Ƒ[K-&oN*WיKYu $:5.b9o8`8jހ]= B$=&6g)@sUXM@%I<:yphB{^MHoQ<CU/-J C;,09;nq/`+)d7N[kNARP/BJtXP7~,pȆ=x:9ɩ~q?:LڶZ Z \EE4MEV8XʁpUCH LjsQqnʺ=k1@Ot<")R^z8䥌oKy%b`W;% 8z< dhx!AGyY^ '~Ii6|sypVP/8qBS-:䊶MPo;W_s=m{W"ו] IwxE/#Ԗe0_TJ- &euGnnY^&E 2d ݀7 0 $&0dE]!={ϩ䑭Rap{^ջ?瞟d{O?dp _|WlsGB! w߉G)oO盐shOE!`{{7\…C]3?Y^=MZa (zwAx}'d/ a ϽqNp'QYܺTa F a?sA!a.<~~7XlJi!io+ Im7wAn%)6>z ` NmEWDY 2'1&U(9pt5yb?dÏ>95L[i`3 E'o|OaMPw/`xU4/& Fo  1-hNTJ)fw[S؍_~+}ۻ'Z*'ߺl\ CNbkx}0y??"y~<o08x_:sD:i޳b_s!큍1do{S8=ߝÎۻ-o}7ǞT\.2<徸`0R505"ؿ  W݀$@bGASNk/%cW#,UaﮎvmPDX7+?=z[4_22GՑۄ;}?1Q] : R=-GWG1ˎ$}_+4o`W6׶=69ޞ_+Wg_ óS(WlUtC7s9wZ`T;zV[" X[-[~t=d k}w]1wׇV[ NEWLܕ𹾿/jvts/\n^÷}XKN!2\Vj HV aUz`d X7߳]YZMYU?m_wρ1y3޷3C'H8G!u:z!w<+[4Cj܇j`@*C$3|xWG7DÅ0K2YT[pӝSN0}cb?,/Bӥgp`h nCqq} 9+WkiEu@ N`/@> #i힕 [QZرzV^Q⟏7`m=l1 { ·Mϕ6ls]ҸVMҥoIOHVD's=ASarLakDYI[B nF 8%}<  ^%CPv^Bp ɡ.u gﻯ؇g?vf9=+j?yNh;-A\ݰz&nnbRXv:`eE;pDE p.,ك;x#X?}:( {VDW/v;d> (d#g<',VBTC=ZJZɮP|lTp#}IKSC Mqcz˩;]w`k#ZeVcO2&JS՞Vⅶ]E'u~߱|?b5&[ WGGZ9B#AԻ}ٗ iMw7nL0>L@q"ϋDCiѠkQ&"=}o d>esxY\B:S|S1vf )gֻm?f{ {ׂmg[Vܛie9 \ƁT}/B~^pcvL"1N]pS/ŧ\~҅:S+ y}n:zgC_v/"Wmf<+[{/=k!*Rzד G?a~ 뢴8Y vh =-m;XOx#/A c >{Gm톎۵Jn;m- l*ϞqI?(LgAKHIRk aoͅ-G(yLsq,9mҧ!O~}3;_%*zB~t߃Z`x{kly7^AxwR@//5M@^7wo0 lSŊ$:,z P-|w~ w[E"OC`&I.1c5o怛gs7ܴ+",ػ+A5#{׻7Q->C$ݓ,q5[h/芰-AQ=1}~7ә4_FtGӃ~)$sL)3J!Ӏ\rȥ?"y2T tᥓNJY9\ йv**y5RTrb"D(QR{&IR?Ȃ%?S;F"E*%***Őʥ,%c:@L` ( qNԢ=!YISj?5&eTCJ+%ޜF-D8^v A $fש+"馴;]|Y !H 8my-Do6*O B 1BWtW[q Œΰ.6ZP'r9t˥BF'ɮ:dcel^l|17ZmqyADa2e 1UX"HA..w9diKdz\ub(=ue ]BCx)..Π_k "xυ1vw%ܛUW-ppp0\ڙP=p{kxQj/W?Zbْz[Et㙚(D١*+2W<8}ZqI`yv^Uj!g샀~`{(9>LO~ +}W/*Y|*!H^kPKEm\գ0-n6歶v,V?u|Vpz1=_+ OB0<Y#*(- ާ9?i_ޔF;' }otH#l +. k ďsg}fѳVj"xYu%qes|z*HYJ>̭|`s]c9l貱  P wՓp6\U!y04l臿YtwcƀTMzכ[ tP t*ngns"U/{V~B6l@`/zːN ΃ko?}PQDXli{원 D, &.bPPN[") Ş/ˁ]fL1)=1'tpXp$O7p Lt&.t'UiN(V1ny.<Hזɠh~%zי|ثР/BE(;5gbx;tH7h!n4P0b4 QŶa6bEbحiۥW( 7B>Pm2uZѮհi_fGV,B bt*%%G0Fh%@ɧaC' f*Ŏ wG+yPm3eB`2P 뚺UÖIƹ}=(>nHm-e2w1W+xO%Dg}S{*+)E(,,֕*еgҬZdȏ46-VDd%'+=Y JNV6]1sp9pL #,Rɚʤ&oJnx5%D̡׏-do'dѮה1fF{1;$V]!ϼoFr^JP߇次 b.7d >~q|#UqixG\0C>~&N٥2 KDVZ%r*V |J`Uh㡝iG%MJJzt UfwT06nHK >ѬQEx#pe? !NR^:UB+rI4x"_ TEpuR7Ti|RP[Շ+p%ÕPy W k$V[’j]9P=Rf4E҈)#3F@"g--`Y S7x/<7C 234K,/C Ͳ2S!{T{VȢAwJ7@u`̻1!_ Ǜ(n* E!߾!UPV9ݯ8O_ :!wmH)o_ ʊ [_D@J{x`[$ZCtDnSQLZAxcO2必gpT#TCRPL{IǑ4E/E MkN:Mkkdg=*kf@Z*Tm tӦ6Op0H(8.DZ3*1r<%P3ߐf! ͎lŦ333R779\薻"eȼF8Ʃx&jSHA{֩GȔNge ;zfFKO]B=V'ciVHBDZjHZj,BY|V=U/ڴ0%0#4ZTIQ%3*A1"ǜY놔)Twj$׎KGQQQQ%ATYD PeuU' Bvש'f7:E~4 h0@%.s8q~&&j!{sN?efvXfYB?*_Ftݖ vZi,VYN8fQ:`Pk_JPe \ɚ#dKoFBg$6ps ΄3gJHٹ~lէ*u̹y+ձ#n=urXv!Gq~.Vb;/&'y 8,,+o#6c8ۂɲ7_LEIsR&x V 3'pFB3_jvfҮfҖf~J=CTU ZB̗=)c"x2^ˀ]@J;&,cHi^6XbN1c8pƏ3|gVY蠨bq9@*9x@ \ k7 KoituPb(2X]#F 1+y;!fU8:56:(! 5)c8lOk,XlMAL"Ή.^BPY>)/Ü"FNᘡpHR,e>Ykޟr /?}t~#]XW@R[#ΎŒx-ΡlޒH2CiЊ X0AAѤxP."hRA(:3s5#1w,(JvR< bH0飙QN n)o X#gGK xZ~}lsf5Xo9.'?0!tHbGSw}o FO@#dMk@M3,.\|0ɚ[U߾Ec7z$닋/_{>kCq Bȉkt7k)Z_/Qxgccg·cۋ)mG#xc8uH[\w bG Ptivڄ> ;r|yv99E}xR9dk{Tw|c1 mQ'EhN&Urp_GNX D, !{v$d.[#K!A ͭl$@&֛9T<x:f»{mR Fw:tlrb%y8mQ]]]U>UQ;:bCkm0 x/ڎtu EQS;w^ @ɏ ?KQ2kt wzo:_<& J;Q˹Rs<'!FX2xVf;3Wkgޘ-J9yT%e4 vB7Yì61VNo@<8˭̦bk|5%ԏ k˵sqQ D޹VT;~}DDV ^6hTM7tBn(]9>wvrm، o{X"$ө`A=’gN$԰tp%t.J" H;;h"g (TD5 ^sHB(C:߳ޙdm!0 ji Į8_p\Ğw3O\-VD$UT2OWes⯱!kF<.]N `(m7]@`h=ȌKbSw2 n~#f V]k!KqmKq+%.&N+Sj7IA. FM$lM@`\5ԓOOPp4S0:oW .ꗃs{6g7g{8o0iWF\!3NC3|_KE{݂9T@볢6F"mu1{ APGE/r. tf+'a𜣎ƐX\ɘbޮ3bV{OVZ5 \Q$yǵjPt%]п:q&WY *eO k_V>kfs 9; 'Wg³o]3 lLf>oJh&Ova~:Èjc@`v*Du<-Hsg& =ɂ{.ܘb-EIyAViRod7_bد_Ğ(^UIh~1ӳxdC{҅Ǔh<ɺ5f*?b4Ufr@]Ӿ.$|!Eщ6}=3^p!׽d=/FD[/ я\ĪN_{3.s]T-'2rvAy!zZQ^􂱟G2QHU$OR4|Χbո`D¿y [DͪO*7+ 30"WSD`l>| ENʙn=j av 2 !3??Ƌl w^[߆zWK:|3F@?X t p%C7(|0MEE&_n,4-Nl,ϑVէn&Nr0 DA,]{:GP4nά&ӸH,js#uNjUgŴY<3E@2agU:M$<%y}PWO+0-L#HQ_MeD;džctC v^Q=x",6cGZg~< (OPOd >l|H/ϨĹ!Qƍ?/x֌̭ k^߄͍ƜNg?%r6[[uV朧Q^Gkk~֩Ϳpz~k`1x911Fek:_W?+Gڙ{~0Hn0vfLwzɏ,'\'Od>Cn.==p$4qY{{W}qq _Wp}Y.cO?'?Gҵ%z_Бtv{j5jj }L [б{Ozk1&O`` c3`Zac-5o 11ry[!LKC+,*sW[k 2p:F5ޗ/Xzȡ8eSJ AVqfՇ֯S9MkM:rؠyApemy)k@>b <چxU'c/ ;n)tk뒂>` 2!+萡C ҕIAuVPy9o.ݘ6Cob}GEq6Fu^ lN ܦ̻:[~óX55XOG̺%L0: 0bt wKp a1G)`[K,ѻgK4Fpo"8Æ.p 3uA%nPרԗ-[ аY3]Zâ͓a>B/3'OC9I`P O( ^C|RoKb-t^s|y"ܛ*M7K0Xi~.+IJar m(XMaf:T6d&;G> ;.ʟaRʾ}1mϑ)?բ'op(;>4@AdkPzH.r ڦlT(aA=$ KO3ԪHM1KM/K䲔M-KIJM+K٤dŜ@qzsN( _iyYz3 {8* b + (y - m +\#n}pd'(9AA9aceU&sc!QR-BiWIK4(\y"!{^3/²:jT ˿a- &hwjRޥw Yp;p׋O.Gfq6k+xԠDiTu4_Pz0K+l= S\g)_Y̝[%FJ,ӗ?0򇟳+xH^{Jv' /jPXT 1 ֽ" tMD64HTE*S]/i՗( h~4ڤו8:0#)LԱlAǍ#QPǃnUW_v;dމ=CK;D"{j?0ТZWӥ 5,كm6mڥrTP?"Zzi]3r.§RvCe^z,eRJI)+RV JJJJJJݶJնJfۿ߬{:j&llRZPۉ$clqn;G"TRzEB)P"E!ď'ʛs̜Q'׾#${f3g)``w.}6=%$\̴c}eOFVY4؇q,B`g< HX~=wLF oUs)*LC#>;!‘U(\+JWNBI"\JXH9 kJԓ+OX 2Vኝ'BߓC>Ηcx@$ذMA9*G.٦<+ 4.X$g=62iɤʝ^VjmPG:Z&3 |rtGC2܃ F3#ypwSp;?30"D%M4* a V} _p]3yA%} \5yP$LJp8 Rօ_@Z݈ҡ7(怛5V>0 @Y}1A1E9:{]A<!h>*Ԗ3D~ʯI<Ϡ)1oJcrED^ZU;{/L1-m i60٠[\I+b'=iY˜fw|[?+5 WU੥FmI0NNFn+w).*E @MS ^ |,$x(^t4ir-mY`ؑP|⿟4 _%p N׌C׉}%gEf2OSb&T<f2O}S^&T%_y8}ɷ~`\BW6 ~_v0ߍ؋X^"7 *4 Cp,=ݭk SHJ5 [5*RB^V8se-w떎F[yRҸTh4 ]^M.+-jpʵqVNTԜM%j2fӶ-[^}V:hEVjFG}V ݞZ~$tdyQEgeb`j{#|fѳ$Jr\%i[]!}asG/}:})/җ })/ϗ|[O'⽫ar\1wD_IicWp8]Q阃NCZIGdP30QEa- (@xCGUK/Q\&FƷFX?o*ra\|3$1`Prj#T[sjBa86jvA֣M1L#vKнЅ5Vni˩I4)fJ}<$:^/ ˶\9j%CYHIJ@"vDu_R>mbtlo}6ovG֭[;oԶmBvo/dyS߻kmjQtnنG˞`m8Pv螞B ' ]VC޵{3tמǪ36¸;OꝜ?,rp=Ԝ@G(:L>7Cq!UulE3fpWwweQ{]9s=,IBv h̋/ӍYt9A 2 #COU&uZi)?yk_/ʧx)91Z^LO?:_͒23].¦VuO|J@5:1{vv?15Y} ,)k]5Ʌ+>\VD%m_]$8Do`߉ Sٝj&=ʝlXĺCp~AXo`Aue=֌9x.z}}$GBZD7$zLkO[[݃D^ aI4K 'tA Ykc?TsT0􍶸ؗZb ~kp~<.Kb+~x".幧9ٸퟏ;z\dH7n~X`nSg /hnIFb/(`k\ꄫSR? ,؏zM "Yc.b0^C)Ś"k|ƊgaZrU_[:1@|dYMN/$g#bBַ@N"kb8 tSW.w5hٰ#S`y ]pKfx{1 {JbIBXusOMi㞩Qa[?x6^Dc2fz@P ὥƯdp H_8Zho%tvQ^oIUH;ߠQ\OA(#u ?l('5}5.p_\uV8i9N8C&5RGuIoTQ_]g re7mϹ#I8G5F뢇-#{{C;iK/iu#3X8%t0lpk환}Ɋ8 <">tBl y#=r[/K잨OVqCgR zԠ>Ίcp:5`vt M5=30u΀'8d@gu6e`Bl%>0<=]t쟂c 1 Ͳ^:Bֆ4Y7.xmd?I](M b'>eK|+>ӌcwqTI4:LQ!CI 8vq/pe~f}_K(p#H2"H)L"H !T P7|fhTrzc#a>E/>g@J`O@?b=.1v`7֤I] U`ylm.>[ŧMlߘ3>BRDi!!kN\].ȕ?;A+jgx?KkΪ(ЏcVW n8B*GB]N@ѹDh`;rh1=yG5҆hvp6} Η"| ݯ iD=ՙ)Rou2Lc:";wb왘Nũ=.Ҟm{ГGdxO 6nѡR&ꖓФ~qK&l?w$:XHUuRh7]AN(aO3i/L{z@nÔIcsP%FN÷ -o9՜TvOSITJ?#xpԆe*31k#p< n8:1{|~j~3'~jPzO#h3}I YfR|QC2 dDF48 ($&1b<^޸I5b2y`˱-Xtel0Wa_n"|;G''r d!8|G2:>3}f/Z3S}l}A#]2.7">9}I -.uN_"?-/ʙV_^?f0c_d뿫sKlZc7t{%|x8(#i}Mɒ#)1.3<LV]=39Yϙo?Bٌ$hpicolisp-3.1.5.2.orig/doc/faq.html0000644000000000000000000007323512265263724015364 0ustar rootroot PicoLisp FAQ abu@software-lab.de

      Monk: "If I have nothing in my mind, what shall I do?"
      Joshu: "Throw it out."
      Monk: "But if there is nothing, how can I throw it out?"
      Joshu: "Well, then carry it out."
      (Zen koan)

      PicoLisp Frequently Asked Questions

      (c) Software Lab. Alexander Burger


      Why did you write yet another Lisp?

      Because other Lisps are not the way I'd like them to be. They concentrate on efficient compilation, and lost the one-to-one relationship of language and virtual machine of an interpreted system, gave up power and flexibility, and impose unnecessary limitations on the freedom of the programmer. Other reasons are the case-insensitivity and complexity of current Lisp systems.


      Who can use PicoLisp?

      PicoLisp is for programmers who want to control their programming environment, at all levels, from the application domain down to the bare metal. Who want use a transparent and simple - yet universal - programming model, and want to know exactly what is going on. This is an aspect influenced by Forth.

      It does not pretend to be easy to learn. There are already plenty of languages that do so. It is not for people who don't care what's under the hood, who just want to get their application running. They are better served with some standard, "safe" black-box, which may be easier to learn, and which allegedly better protects them from their own mistakes.


      What are the advantages over other Lisp systems?

      Simplicity

      PicoLisp is easy to understand and adapt. There is no compiler enforcing special rules, and the interpreter is simple and straightforward. There are only three data types: Numbers, symbols and lists ("LISP" means "List-, Integer- and Symbol Processing" after all ;-). The memory footprint is minimal, and the tarball size of the whole system is just a few hundred kilobytes.

      A Clear Model

      Most other systems define the language, and leave it up to the implementation to follow the specifications. Therefore, language designers try to be as abstract and general as possible, leaving many questions and ambiguities to the users of the language.

      PicoLisp does the opposite. Initially, only the single-cell data structure was defined, and then the structure of numbers, symbols and lists as they are composed of these cells. Everything else in the whole system follows from these axioms. This is documented in the chapter about the The PicoLisp Machine in the reference manual.

      Orthogonality

      There is only one symbolic data type, no distinction (confusion) between symbols, strings, variables, special variables and identifiers.

      Most data-manipulation functions operate on the values of symbols as well as the CARs of cons pairs:

      
      : (let (N 7  L (7 7 7)) (inc 'N) (inc (cdr L)) (cons N L))
      -> (8 7 8 7)
      

      There is only a single functional type, no "special forms". As there is no compiler, functions can be used instead of macros. No special "syntax" constructs are needed. This allows a completely orthogonal use of functions. For example, most other Lisps do not allow calls like

      
      : (mapcar if '(T NIL T NIL) '(1 2 3 4) '(5 6 7 8))
      -> (1 6 3 8)
      

      PicoLisp has no such restrictions. It favors the principle of "Least Astonishment".

      Object System

      The OOP system is very powerful, because it is fully dynamic, yet extremely simple:

      • In other systems you have to statically declare "slots". In PicoLisp, classes and objects are completely dynamic, they are created and extended at runtime. "Slots" don't even exist at creation time. They spring into existence purely dynamically. You can add any new property or any new method to any single object, at any time, regardless of its class.
      • The multiple inheritance is such that not only classes can have several superclasses, but each individual object can be of more than one class.
      • Prefix classes can surgically change the inheritance tree for any class or object. They behave like Mixins in this regard.
      • Fine-control of inheritance in methods with super and extra.

      Pragmatism

      PicoLisp has many practical features not found in other Lisp dialects. Among them are:

      • Auto-quoting of lists when the CAR is a number. Instead of '(1 2 3) you can just write (1 2 3). This is possible because a number never makes sense as a function name, and has to be checked at runtime anyway.
      • The quote function returns all unevaluated arguments, instead of just the first one. This is both faster (quote does not have to take the CAR of its argument list) and smaller (a single cell instead of two). For example, 'A expands to (quote . A) and '(A B C) expands to (quote A B C).
      • The symbol @ is automatically maintained as a local variable, and set implicitly in certain flow- and logic-functions. This makes it often unnecessary to allocate and assign local variables.
      • Functional I/O is more convenient than explicitly passing around file descriptors.
      • A well-defined ordinal relationship between arbitrary data types facilitates generalized comparing and sorting.
      • Uniform handling of var locations (i.e. values of symbols and CARs of cons pairs).
      • The universality and usefulness of symbol properties is enforced and extended with implicit and explicit bindings of the symbol This in combination with the access functions =:, : and ::.
      • A very convenient list-building machinery, using the link, yoke, chain and made functions in the make environment.
      • The syntax of often-used functions is kept non-verbose. For example, instead of (let ((A 1) (B 2) C 3) ..) you write (let (A 1 B 2 C 3) ..), or just (let A 1 ..) if there is only a single variable.
      • The use of the hash (#) as a comment character is more adequate today, and allows a clean hash-bang (#!) syntax for stand-alone scripts.
      • The interpreter is invoked with a simple and flexible syntax, where command line arguments are either files to be interpreted or functions to be directly executed. With that, many tasks can be performed without writing a separate script.
      • A sophisticated system of interprocess communication, file locking and synchronization allows multi-user access to database applications.
      • A Prolog interpreter is tightly integrated into the language. Prolog clauses can call Lisp expressions and vice versa, and a self-adjusting depth-first search predicate select can be used in database queries.

      Persistent Symbols

      Database objects ("external" symbols) are a primary data type in PicoLisp. They look like normal symbols to the programmer, but are managed in the database (fetched from, and stored to) automatically by the system. Symbol manipulation functions like set, put or get, the garbage collector, and other parts of the interpreter know about them.

      Application Server

      It is a stand-alone system (it does not depend on external programs like Apache or MySQL) and it provides a "live" user interface on the client side, with an application server session for each connected client. The GUI layout and behavior are described with S-expressions, generated dynamically at runtime, and interact directly with the database structures.

      Localization

      Internal exclusive and full use of UTF-8 encoding, and self-translating transient symbols (strings), make it easy to write country- and language-independent applications.


      How is the performance compared to other Lisp systems?

      Despite the fact that PicoLisp is an interpreted-only system, the performance is quite good. Typical Lisp programs operating on list data structures are executed in (interpreted) PicoLisp at about the same speed as in (compiled) CMUCL, and about two or three times faster than in CLisp or Scheme48. Programs with lots of numeric calculations, however, may be slower on a 32-bit system, due to PicoLisp's somewhat inefficient implementation of numbers. The 64-bit version improved on that.

      But in practice, speed was never a problem, even with the first versions of PicoLisp in 1988 on a Mac II with a 12 MHz CPU. And certain things are cleaner and easier to do in plain C or asm anyway. It is very easy to write C functions in PicoLisp, either in the kernel, as shared object libraries, or even inline in the Lisp code.

      PicoLisp is very space-effective. Other Lisp systems reserve heap space twice as much as needed, or use rather large internal structures to store cells and symbols. Each cell or minimal symbol in PicoLisp consists of only two pointers. No additional tags are stored, because they are implied in the pointer encodings. No gaps remain in the heap during allocation, as there are only objects of a single size. As a result, consing and garbage collection are very fast, and overall performance benefits from a better cache efficiency. Heap and stack grow automatically, and are limited only by hardware and operating system constraints.


      What means "interpreted"?

      It means to directly execute Lisp data as program code. No transformation to another representation of the code (e.g. compilation), and no structural modifications of these data, takes place.

      Lisp data are the "real" things, like numbers, symbols and lists, which can be directly handled by the system. They are not the textual representation of these structures (which is outside the Lisp realm and taken care of the reading and printing interfaces).

      The following example builds a function and immediately calls it with two arguments:

      
      : ((list (list 'X 'Y) (list '* 'X 'Y)) 3 4)
      -> 12
      

      Note that no time is wasted to build up a lexical environment. Variable bindings take place dynamically during interpretation.

      A PicoLisp function is able to inspect or modify itself while it is running (though this is rarely done in application programming). The following function modifies itself by incrementing the '0' in its body:

      
      (de incMe ()
         (do 8
            (printsp 0)
            (inc (cdadr (cdadr incMe))) ) )
      
      : (incMe)
      0 1 2 3 4 5 6 7 -> 8
      : (incMe)
      8 9 10 11 12 13 14 15 -> 16
      

      Only an interpreted Lisp can fully support such "Equivalence of Code and Data". If executable pieces of data are used frequently, like in PicoLisp's dynamically generated GUI, a fast interpreter is preferable over any compiler.


      Is there (or will be in the future) a compiler available?

      No. That would contradict the idea of PicoLisp's simple virtual machine structure. A compiler transforms it to another (physical) machine, with the result that many assumptions about the machine's behavior won't hold any more. Besides that, PicoLisp primitive functions evaluate their arguments independently and are not suited for being called from compiled code. Finally, the gain in execution speed would probably not be worth the effort. Typical PicoLisp applications often use single-pass code which is loaded, executed and thrown away; a process that would be considerably slowed down by compilation.


      Is it portable?

      Yes and No. Though we wrote and tested PicoLisp originally only on Linux, it now also runs on FreeBSD, Mac OS X (Darwin), Cygwin/Win32, and probably other POSIX systems. The first versions were even fully portable between DOS, SCO-Unix and Macintosh systems. But today we have Linux. Linux itself is very portable, and you can get access to a Linux system almost everywhere. So why bother?

      The GUI is completely platform independent (Browser), and in the times of Internet an application server does not really need to be portable.


      Is PicoLisp a web server?

      Not really, but it evolved a great deal into that direction.

      Historically it was the other way round: We had a plain X11 GUI for our applications, and needed something platform independent. The solution was obvious: Browsers are installed virtually everywhere. So we developed a protocol which persuades a browser to function as a GUI front-end to our applications. This is much simpler than to develop a full-blown web server.


      I cannot find the LAMBDA keyword in PicoLisp

      Because it isn't there. The reason is that it is redundant; it is equivalent to the quote function in any aspect, because there's no distinction between code and data in PicoLisp, and quote returns the whole (unevaluated) argument list. If you insist on it, you can define your own lambda:

      
      : (def 'lambda quote)
      -> lambda
      : ((lambda (X Y) (+ X Y)) 3 4)
      -> 7
      : (mapcar (lambda (X) (+ 1 X)) '(1 2 3 4 5))
      -> (2 3 4 5 6)
      


      Why do you use dynamic variable binding?

      Dynamic binding is very powerful, because there is only one single, dynamically changing environment active all the time. This makes it possible (e.g. for program snippets, interspersed with application data and/or passed over the network) to access the whole application context, freely, yet in a dynamically controlled manner. And (shallow) dynamic binding is the fastest method for a Lisp interpreter.

      Lexical binding is more limited by definition, because each environment is deliberately restricted to the visible (textual) static scope within its establishing form. Therefore, most Lisps with lexical binding introduce "special variables" to support dynamic binding as well, and constructs like labels to extend the scope of variables beyond a single function.

      In PicoLisp, function definitions are normal symbol values. They can be dynamically rebound like other variables. As a useful real-world example, take this little gem:

      
      (de recur recurse
         (run (cdr recurse)) )
      

      It implements anonymous recursion, by defining recur statically and recurse dynamically. Usually it is very cumbersome to think up a name for a function (like the following one) which is used only in a single place. But with recur and recurse you can simply write:

      
      : (mapcar
         '((N)
            (recur (N)
               (if (=0 N)
                  1
                  (* N (recurse (- N 1))) ) ) )
         (1 2 3 4 5 6 7 8) )
      -> (1 2 6 24 120 720 5040 40320)
      

      Needless to say, the call to recurse does not have to reside in the same function as the corresponding recur. Can you implement anonymous recursion so elegantly with lexical binding?


      Are there no problems caused by dynamic binding?

      You mean the funarg problem, or problems that arise when a variable might be bound to itself? For that reason we have a convention in PicoLisp to use transient symbols (instead of internal symbols)

      1. for all parameters and locals, when functional arguments or executable lists are passed through the current dynamic bindings
      2. for a parameter or local, when that symbol might possibly be (directly or indirectly) bound to itself, and the bound symbol's value is accessed in the dynamic context

      This is a form of lexical scoping - though we still have dynamic binding - of symbols, similar to the static keyword in C.

      In fact, these problems are a real threat, and may lead to mysterious bugs (other Lisps have similar problems, e.g. with symbol capture in macros). They can be avoided, however, when the above conventions are observed. As an example, consider a function which doubles the value in a variable:

      
      (de double (Var)
         (set Var (* 2 (val Var))) )
      

      This works fine, as long as we call it as (double 'X), but will break if we call it as (double 'Var). Therefore, the correct implementation of double should be:

      
      (de double ("Var")
         (set "Var" (* 2 (val "Var"))) )
      

      If double is defined that way in a separate source file, and/or isolated via the ==== function, then the symbol Var is locked into a private lexical context and cannot conflict with other symbols.

      Admittedly, there are two disadvantages with this solution:

      1. The rules for when to use transient symbols are a bit complicated. Though it is safe to use them even when not necessary, it will take more space then and be more difficult to debug.
      2. The string-like syntax of transient symbols as variables may look strange to alumni of other languages.
      Fortunately, these pitfalls do not occur so very often, and seem more likely in utilities than in production code, so that they can be easily encapsulated.


      But with dynamic binding I cannot implement closures!

      This is not true. Closures are a matter of scope, not of binding.

      For a closure it is necessary to build and maintain a separate environment. In a system with lexical bindings, this has to be done at each function call, and for compiled code it is the most efficient strategy anyway, because it is done once by the compiler, and can then be accessed as stack frames at runtime.

      For an interpreter, however, this is quite an overhead. So it should not be done automatically at each and every function invocation, but only if needed.

      You have several options in PicoLisp. For simple cases, you can take advantage of the static scope of transient symbols. For the general case, PicoLisp has built-in functions like bind or job, which dynamically manage statically scoped environments.

      Environments are first-class objects in PicoLisp, more flexible than hard-coded closures, because they can be created and manipulated independently from the code.

      As an example, consider a currying function:

      
      (de curry Args
         (list (car Args)
            (list 'list
               (lit (cadr Args))
               (list 'cons ''job
                  (list 'cons
                     (list 'lit (list 'env (lit (car Args))))
                     (lit (cddr Args)) ) ) ) ) )
      

      When called, it returns a function-building function which may be applied to some argument:

      
      : ((curry (X) (N) (* X N)) 3)
      -> ((N) (job '((X . 3)) (* X N)))
      

      or used as:

      
      : (((curry (X) (N) (* X N)) 3) 4)
      -> 12
      

      In other cases, you are free to choose a shorter and faster solution. If (as in the example above) the curried argument is known to be immutable:

      
      (de curry Args
         (list
            (cadr Args)
            (list 'fill
               (lit (cons (car Args) (cddr Args)))
               (lit (cadr Args)) ) ) )
      

      Then the function built above will just be:

      
      : ((curry (X) (N) (* X N)) 3)
      -> ((X) (* X 3))
      

      In that case, the "environment build-up" is reduced by a simple (lexical) constant substitution with zero runtime overhead.

      Note that the actual curry function is simpler and more pragmatic. It combines both strategies (to use job, or to substitute), deciding at runtime what kind of function to build.


      Do you have macros?

      Yes, there is a macro mechanism in PicoLisp, to build and immediately execute a list of expressions. But it is seldom used. Macros are a kludge. Most things where you need macros in other Lisps are directly expressible as functions in PicoLisp, which (as opposed to macros) can be applied, passed around, and debugged.

      For example, Common Lisp's DO* macro, written as a function:

      
      (de do* "Args"
         (bind (mapcar car (car "Args"))
            (for "A" (car "Args")
               (set (car "A") (eval (cadr "A"))) )
            (until (eval (caadr "Args"))
               (run (cddr "Args"))
               (for "A" (car "Args")
                  (and (cddr "A") (set (car "A") (run @))) ) )
            (run (cdadr "Args")) ) )
      


      Why are there no strings?

      Because PicoLisp has something better: Transient symbols. They look and behave like strings in any respect, but are nevertheless true symbols, with a value and a property list.

      This leads to interesting opportunities. The value, for example, can point to other data that represent the string's translation. This is used extensively for localization. When a program calls

      
         (prinl "Good morning!")
      

      then changing the value of the symbol "Good morning!" to its translation will change the program's output at runtime.

      Transient symbols are also quite memory-conservative. As they are stored in normal heap cells, no additional overhead for memory management is induced. The cell holds the symbol's value in its CDR, and the tail in its CAR. If the string is not longer than 7 bytes, it fits (on the 64-bit version) completely into the tail, and a single cell suffices. Up to 15 bytes take up two cells, 23 bytes three etc., so that long strings are not very efficient (needing twice the memory on the average), but this disadvantage is made up by simplicity and uniformity. And lots of extremely long strings are not the common case, as they are split up anyway during processing, and stored as plain byte sequences in external files and databases.

      Because transient symbols are temporarily interned (while loading the current source file), they are shared within the same source and occupy that space only once, even if they occur multiple times within the same file.


      What about arrays?

      PicoLisp has no array or vector data type. Instead, lists must be used for any type of sequentially arranged data.

      We believe that arrays are usually overrated. Textbook wisdom tells that they have a constant access time O(1) when the index is known. Many other operations like splits or insertions are rather expensive. Access with a known (numeric) index is not really typical for Lisp, and even then the advantage of an array is significant only if it is relatively long. Holding lots of data in long arrays, however, smells quite like a program design error, and we suspect that often more structured representations like trees or interconnected objects would be better.

      In practice, most arrays are rather short, or the program can be designed in such a way that long arrays (or at least an indexed access) are avoided.

      Using lists, on the other hand, has advantages. We have so many concerted functions that uniformly operate on lists. There is no separate data type that has to be handled by the interpreter, garbage collector, I/O, database and so on. Lists can be made circular. And lists don't cause memory fragmentation.


      How to do floating point arithmetics?

      PicoLisp does not support real floating point numbers. You can do all kinds of floating point calculations by calling existing library functions via native, inline-C code, and/or by loading the "@lib/math.l" library.

      But PicoLisp has something even (arguably) better: Scaled fixpoint numbers, with unlimited precision.

      The reasons for this design decision are manifold. Floating point numbers smack of imperfection, they don't give "exact" results, have limited precision and range, and require an extra data type. It is hard to understand what really goes on (How many digits of precision do we have today? Are perhaps 10-byte floats used for intermediate results? How does rounding behave?).

      For fixpoint support, the system must handle just integer arithmetics, I/O and string conversions. The rest is under programmer's control and responsibility (the essence of PicoLisp).

      Carefully scaled fixpoint calculations can do anything floating points can do.


      What happens when I locally bind a symbol which has a function definition?

      That's not a good idea. The next time that function gets executed within the dynamic context the system may crash. Therefore we have a convention to use an upper case first letter for locally bound symbols:

      
      (de findCar (Car List)
         (when (member Car (cdr List))
            (list Car (car List)) ) )
      
      ;-)


      Would it make sense to build PicoLisp in hardware?

      At least it should be interesting. It would be a machine executing list (tree) structures instead of linear instruction sequences. "Instruction prefetch" would look down the CAR- and CDR-chains, and perhaps need only a single cache for both data and instructions.

      Primitive functions like set, val, if and while, which are written in C or assembly language now, would be implemented in microcode. Plus a few I/O functions for hardware access. EVAL itself would be a microcode subroutine.

      Only a single heap and a single stack is needed. They grow towards each other, and cause garbage collection if they get too close. Heap compaction is trivial due to the single cell size.

      There would be no assembly-language. The lowest level (above the hardware and microcode levels) are s-expressions: The machine language is Lisp.


      I get a segfault if I ...

      It is easy to produce a segfault in PicoLisp. Just set a symbol to a value which is not a function, and call it:

      
      : (setq foo 1)
      -> 1
      : (foo)
      Segmentation fault
      
      There is another example in the Evaluation section of the reference manual.

      PicoLisp is a pragmatic language. It doesn't check at runtime for all possible error conditions which won't occur during normal usage. Such errors are usually detected quickly at the first test run, and checking for them after that would just produce runtime overhead.

      Catching the segmentation violation and bus fault signals is also not a good idea, because the Lisp heap is most probably be damaged afterwards, possibly creating further havoc if execution continues.

      It is recommended to inspect the code periodically with lint. It will detect many potential errors. And, most of these errors are avoided by following the PicoLisp naming conventions.


      Where can I ask questions?

      The best place is the PicoLisp Mailing List (see also The Mail Archive and Gmane.org), or the IRC #picolisp channel on FreeNode.net. picolisp-3.1.5.2.orig/doc/fun.l0000644000000000000000000000021012265263724014653 0ustar rootroot# 25jun07abu # (c) Software Lab. Alexander Burger (de fact (N) (if (=0 N) 1 (* N (fact (dec N))) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/doc/hello.l0000644000000000000000000000014312265263724015173 0ustar rootroot(load "@lib/xhtml.l") (html 0 "Hello" NIL NIL (

      NIL "Hello world") "This is PicoLisp" ) picolisp-3.1.5.2.orig/doc/index.html0000644000000000000000000000563712265263724015725 0ustar rootroot PicoLisp Docs picolisp-3.1.5.2.orig/doc/native.html0000644000000000000000000006603612265263724016104 0ustar rootroot Native C Calls abu@software-lab.de

      Native C Calls

      (c) Software Lab. Alexander Burger

      This document describes how to call C functions in shared object files (libraries) from PicoLisp, using the built-in native function - possibly with the help of the struct and lisp functions. It applies only to the 64-bit version of PicoLisp.


      Overview

      native calls a C function in a shared library. It tries to

      1. find a library by name
      2. find a function by name in the library
      3. convert the function's argument(s) from Lisp to C structures
      4. call the function's C code
      5. convert the function's return value(s) from C to Lisp structures

      The direct return value of native is the Lisp representation of the C function's return value. Further values, returned by reference from the C function, are available in Lisp variables (symbol values).

      struct is a helper function, which can be used to manipulate C data structures in memory. It may take a scalar (a numeric representation of a C value) to convert it to a Lisp item, or (more typically) a pointer to a memory area to build and extract data structures. lisp allows you to install callback functions, callable from C code, written in Lisp.

      In combination, these three functions can interface PicoLisp to almost any C function.

      The above steps are fully dynamic; native doesn't have (and doesn't require) a priory knowledge about the library, the function or the involved data. No need to write any glue code, interfaces or include files. All functions can even be called interactively from the REPL.


      Syntax

      The arguments to native are

      1. a library
      2. a function
      3. a return value specification
      4. optional arguments

      The simplest form is a call to a function without return value and without arguments. If we assume a library "lib.so", containing a function with the prototype

      
      void fun(void);
      

      then we can call it as

      
      (native "lib.so" "fun")
      


      Libraries

      The first argument to native specifies the library. It is either the name of a library (a symbol), or the handle of a previously found library (a number).

      As a special case, a transient symbol "@" can be passed for the library name. It then refers to the current main program (instead of an external library), and can be used for standard functions like "malloc" or "printf".

      native uses dlopen(3) internally to find and open the library, and to obtain the handle. If the name contains a slash ('/'), then it is interpreted as a (relative or absolute) pathname. Otherwise, the dynamic linker searches for the library according to the system's environment and directories. See the man page of dlopen(3) for further details.

      If called with a symbolic argument, native automatically caches the handle of the found library in the value of that symbol. The most natural way is to pass the library name as a transient symbol ("lib.so" above): The initial value of a transient symbol is that symbol itself, so that native receives the library name upon the first call. After successfully finding and opening the library, native stores the handle of that library in the value of the passed symbol ("lib.so"). As native evaluates its arguments in the normal way, subsequent calls within the same transient scope will receive the numeric value (the handle), and don't need to open and search the library again.


      Functions

      The same rules applies to the second argument, the function. When called with a symbol, native stores the function pointer in its value, so that subsequent calls evaluate to that pointer, and native can directly jump to the function.

      native uses dlsym(3) internally to obtain the function pointer. See the man page of dlsym(3) for further details.

      In most cases a program will call more than one function from a given library. If we keep the code within the same transient scope (i.e. in the same source file, and not separated by the ==== function), each library will be opened - and each function searched - only once.

      
      (native "lib.so" "fun1")
      (native "lib.so" "fun2")
      (native "lib.so" "fun3")
      

      After "fun1" was called, "lib.so" will be open, and won't be re-opened for "fun2" and "fun3". Consider the definition of helper functions:

      
      (de fun1 ()
         (native "lib.so" "fun1") )
      
      (de fun2 ()
         (native "lib.so" "fun2") )
      
      (de fun3 ()
         (native "lib.so" "fun3") )
      

      After any one of fun1, fun2 or fun3 was called, the symbol "lib.so" will hold the library handle. And each function function "fun1", "fun2" and "fun3" will be searched only when called the first time.

      Warning: It should be avoided to put more than one library into a single transient scope if there is a chance that two different functions with the same name will be called in two different libraries. Because of the function pointer caching, the second call would otherwise (wrongly) go to the first function.


      Return Value

      The (optional) third argument to native specifies the return value. A C function can return many types of values, like integer or floating point numbers, string pointers, or pointers to structures which in turn consist of those types, and even other structures or pointers to structures. native tries to cover most of them.

      As described in the result specification, the third argument should consist of a pattern which tells native how to extract the proper value.

      Primitive Types

      In the simplest case, the result specification is NIL like in the examples so far. This means that either the C function returns void, or that we are not interested in the value. The return value of native will be NIL in that case.

      If the result specification is one of the symbols B, I or N, an integer number is returned, by interpreting the result as a char (8 bit unsigned byte), int (32 bit signed integer), or long number (64 bit signed integer), respectively. Other (signed or unsigned numbers, and of different sizes) can be produced from these types with logical and arithmetic operations if necessary.

      If the result specification is the symbol C, the result is interpreted as a 16 bit number, and a single-char transient symbol (string) is returned.

      A specification of S tells native to interpret the result as a pointer to a C string (null terminated), and to return a transient symbol (string).

      If the result specification is a number, it will be used as a scale to convert a returned double (if the number is positive) or float (if the number is negative) to a scaled fixpoint number.

      Examples for function calls, with their corresponding C prototypes:

      
      (native "lib.so" "fun" 'I)             # int fun(void);
      (native "lib.so" "fun" 'N)             # long fun(void);
      (native "lib.so" "fun" 'N)             # void *fun(void);
      (native "lib.so" "fun" 'S)             # char *fun(void);
      (native "lib.so" "fun" 1.0)            # double fun(void);
      

      Arrays and Structures

      If the result specification is a list, it means that the C function returned a pointer to an array, or an arbitrary memory structure. The specification list should then consist of either the above primitive specifications (symbols or numbers), or of cons pairs of a primitive specification and a repeat count, to denote arrays of the given type.

      Examples for function calls, with their corresponding pseudo C prototypes:

      
      (native "lib.so" "fun" '(I . 8))       # int *fun(void);  // 8 integers
      (native "lib.so" "fun" '(B . 16))      # unsigned char *fun(void);  // 16 bytes
      
      (native "lib.so" "fun" '(I I))         # struct {int i; int j;} *fun(void);
      (native "lib.so" "fun" '(I . 4))       # struct {int i[4];} *fun(void);
      
      (native "lib.so" "fun" '(I (B . 4)))   # struct {
                                             #    int i;
                                             #    unsigned char c[4];
                                             # } *fun(void);
      
      (native "lib.so" "fun"                 # struct {
         '(((B . 4) I) (S . 12) (N . 8)) )   #    struct {unsigned char c[4]; int i;}
                                             #    char *names[12];
                                             #    long num[8];
                                             # } *fun(void);
      

      If a returned structure has an element which is a pointer to some other structure (i.e. not an embedded structure like in the last example above), this pointer must be first obtained with a N pattern, which can then be passed to struct for further extraction.


      Arguments

      The (optional) fourth and following arguments to native specify the arguments to the C function.

      Primitive Types

      Integer arguments (up to 64 bits, signed or unsigned char, short, int or long) can be passed as they are: As numbers.

      
      (native "lib.so" "fun" NIL 123)        # void fun(int);
      (native "lib.so" "fun" NIL 1 2 3)      # void fun(int, long, short);
      

      String arguments can be specified as symbols. native allocates memory for each string (with strdup(3)), passes the pointer to the C function, and releases the memory (with free(3)) when done.

      
      (native "lib.so" "fun" NIL "abc")      # void fun(char*);
      (native "lib.so" "fun" NIL 3 "def")    # void fun(int, char*);
      

      Note that the allocated string memory is released after the return value is extracted. This allows a C function to return the argument string pointer, perhaps after modifying the data in-place, and receive the new string as the return value (with the S specification).

      
      (native "lib.so" "fun" 'S "abc")       # char *fun(char*);
      

      Also note that specifying NIL as an argument passes an empty string ("", which also reads as NIL in PicoLisp) to the C function. Physically, this is a pointer to a NULL-byte, and is not a NULL-pointer. Be sure to pass 0 (the number zero) if a NULL-pointer is desired.

      Floating point arguments are specified as cons pairs, where the value is in the CAR, and the CDR holds the fixpoint scale. If the scale is positive, the number is passed as a double, otherwise as a float.

      
      (native "lib.so" "fun" NIL             # void fun(double, float);
         (12.3 . 1.0) (4.56 . -1.0) )
      

      Arrays and Structures

      Composite arguments are specified as nested list structures. native allocates memory for each array or structure (with malloc(3)), passes the pointer to the C function, and releases the memory (with free(3)) when done.

      This implies that such an argument can be both an input and an output value to a C function (pass by reference).

      The CAR of the argument specification can be NIL (then it is an input-only argument). Otherwise, it should be a variable which receives the returned structure data.

      The CADR of the argument specification must be a cons pair with the total size of the structure in its CAR. The CDR is ignored for input-only arguments, and should contain a result specification for the output value to be stored in the variable.

      For example, a minimal case is a function that takes an integer reference, and stores the number '123' in that location:

      
      void fun(int *i) {
         *i = 123;
      }
      

      We call native with a variable X in the CAR of the argument specification, a size of 4 (i.e. sizeof(int)), and I for the result specification. The stored value is then available in the variable X:

      
      : (native "lib.so" "fun" NIL '(X (4 . I)))
      -> NIL
      : X
      -> 123
      

      The rest (CDDR) of the argument specification may contain initialization data, if the C function expects input values in the structure. It should be a list of initialization items, optionally with a fill-byte value in the CDR of the last cell.

      If there are no initialization items and just the final fill-bye, then the whole buffer is filled with that byte. For example, to pass a buffer of 20 bytes, initialized to zero:

      
      : (native "lib.so" "fun" NIL '(NIL (20) . 0))
      

      A buffer of 20 bytes, with the first 4 bytes initialized to 1, 2, 3, and 4, and the rest filled with zero:

      
      : (native "lib.so" "fun" NIL '(NIL (20) 1 2 3 4 . 0))
      

      and the same, where the buffer contents are returned as a list of bytes in the variable X:

      
      : (native "lib.so" "fun" NIL '(X (20 B . 20) 1 2 3 4 . 0))
      

      For a more extensive example, let's use the following definitions:

      
      typedef struct value {
         int x, y;
         double a, b, c;
         int z;
         char nm[4];
      } value;
      
      void fun(value *val) {
         printf("%d %d\n", val->x, val->y);
         val->x = 3;
         val->y = 4;
         strcpy(val->nm, "OK");
      }
      

      We call this function with a structure of 40 bytes, requesting the returned data in V, with two integers (I . 2), three doubles (100 . 3) with a scale of 2 (1.0 = 100), another integer I and four characters (C . 2). If the structure gets initialized with two integers 7 and 6, three doubles 0.11, 0.22 and 0.33, and another integer 5 while the rest of the 40 bytes is cleared to zero

      
      : (native "lib.so" "fun" NIL
         '(V (40 (I . 2) (100 . 3) I (C . 4)) -7 -6 (100 11 22 33) -5 . 0) )
      

      then it will print the integers 7 and 6, and V will contain the returned list

      
      ((3 4) (11 22 33) 5 ("O" "K" NIL NIL))
      

      i.e. the original integer values 7 and 6 replaced with 3 and 4.

      Note that the allocated structure memory is released after the return value is extracted. This allows a C function to return the argument structure pointer, perhaps after modifying the data in-place, and receive the new structure as the return value - instead of (or even in addition to) to the direct return via the argument reference.


      Memory Management

      The preceding Arguments section mentions that native implicitly allocates and releases memory for strings, arrays and structures.

      Technically, this mimics automatic variables in C.

      For a simple example, let's assume that we want to call read(2) directly, to fetch a 4-byte integer from a given file descriptor. This could be done with the following C function:

      
      int read4bytes(int fd) {
         char buf[4];
      
         read(fd, buf, 4);
         return *(int*)buf;
      }
      

      buf is an automatic variable, allocated on the stack, which disappears when the function returns. A corresponding native call would be:

      
      (native "@" "read" 'N Fd '(Buf (4 . I)) 4)
      

      The structure argument (Buf (4 . I)) says that a space of 4 bytes should be allocated and passed to read, then an integer I returned in the variable Buf (the return value of native itself is the number returned by read). The memory space is released after that.

      (Note that we use "@" for the library here, as read resides in the main program.)

      Instead of a single integer, we might want a list of four bytes to be returned from native:

      
      (native "@" "read" 'N Fd '(Buf (4 B . 4)) 4)
      

      The difference is that we wrote (B . 4) (a list of 4 bytes) instead of I (a single integer) for the result specification (see the Arrays and Structures section).

      Let's see what happens if we extend this example. We'll write the four bytes to another file descriptor, after reading them from the first one:

      
      void copy4bytes(int fd1, int fd2) {
         char buf[4];
      
         read(fd1, buf, 4);
         write(fd2, buf, 4);
      }
      

      Again, buf is an automatic variable. It is passed to both read and write. A direct translation would be:

      
      (native "@" "read" 'N Fd '(Buf (4 B . 4)) 4)
      (native "@" "write" 'N Fd (cons NIL (4) Buf) 4)
      

      This work as expected. read returns a list of four bytes in Buf. The call to cons builds the structure

      
      (NIL (4) 1 2 3 4)
      

      i.e. no return variable, a four-byte memory area, filled with the four bytes (assuming that read returned 1, 2, 3 and 4). Then this structure is passed to write.

      But: This solution induces quite some overhead. The four-byte buffer is allocated before the call to read and released after that, then allocated and released again for write. Also, the bytes are converted to a list to be stored in Buf, then that list is extended for the structure argument to write, and converted again back to the raw byte array. The data in the list itself are never used.

      If the above operation is to be used more than once, it is better to allocate the buffer manually, use it for both reading and writing, and then release it. This also avoids all intermediate list conversions.

      
      (let Buf (native "@" "malloc" 'N 4) # Allocate memory
         (native "@" "read" 'N Fd Buf 4)  # (Possibly repeat this several times)
         (native "@" "write" 'N Fd Buf 4)
         (native "@" "free" NIL Buf) )    # Release memory
      

      Fast Fourier Transform

      For a more typical example, we might call the Fast Fourier Transform using the library from the FFTW package. With the example code for calculating Complex One-Dimensional DFTs:

      
      #include <fftw3.h>
      ...
      {
         fftw_complex *in, *out;
         fftw_plan p;
         ...
         in = (fftw_complex*) fftw_malloc(sizeof(fftw_complex) * N);
         out = (fftw_complex*) fftw_malloc(sizeof(fftw_complex) * N);
         p = fftw_plan_dft_1d(N, in, out, FFTW_FORWARD, FFTW_ESTIMATE);
         ...
         fftw_execute(p); /* repeat as needed */
         ...
         fftw_destroy_plan(p);
         fftw_free(in); fftw_free(out);
      }
      

      we can build the following equivalent:

      
      (load "@lib/math.l")
      
      (de FFTW_FORWARD . -1)
      (de FFTW_ESTIMATE . 64)
      
      (de fft (Lst)
         (let
            (Len (length Lst)
               In (native "libfftw3.so" "fftw_malloc" 'N (* Len 16))
               Out (native "libfftw3.so" "fftw_malloc" 'N (* Len 16))
               P (native "libfftw3.so" "fftw_plan_dft_1d" 'N
                  Len In Out FFTW_FORWARD FFTW_ESTIMATE ) )
            (struct In NIL (cons 1.0 (apply append Lst)))
            (native "libfftw3.so" "fftw_execute" NIL P)
            (prog1 (struct Out (make (do Len (link (1.0 . 2)))))
               (native "libfftw3.so" "fftw_destroy_plan" NIL P)
               (native "libfftw3.so" "fftw_free" NIL Out)
               (native "libfftw3.so" "fftw_free" NIL In) ) ) )
      

      This assumes that the argument list Lst is passed as a list of complex numbers, each as a list of two numbers for the real and imaginary part, like

      
      (fft '((1.0 0) (1.0 0) (1.0 0) (1.0 0) (0 0) (0 0) (0 0) (0 0)))
      

      The above translation to Lisp is quite straightforward. After the two buffers are allocated, and a plan is created, struct is called to store the argument list in the In structure as a list of double numbers (according to the 1.0 initialization item). Then fftw_execute is called, and struct is called again to retrieve the result from Out and return it from fft via the prog1. Finally, all memory is released.

      Constant Data

      If such allocated data (strings, arrays or structures passed to native) are constant during the lifetime of a program, it makes sense to allocate them only once, before their first use. A typical candidate is the format string of a printf call. Consider a function which prints a floating point number in scientific notation:

      
      (load "@lib/math.l")
      
      : (de prf (Flt)
         (native "@" "printf" NIL "%e^J" (cons Flt 1.0)) )
      -> prf
      
      : (prf (exp 12.3))
      2.196960e+05
      

      As we know that the format string "%e^J" will be converted from a Lisp symbol to a C string with strdup - and then thrown away - on each call to prf, we might as well perform a little optimization and delegate this conversion to the program load time:

      
      : (de prf (Flt)
         (native "@" "printf" NIL `(native "@" "strdup" 'N "%e^J") (cons Flt 1.0)) )
      -> prf
      
      : (prf (exp 12.3))
      2.196960e+05
      

      If we look at the prf function, we see that it now contains the pointer to the allocated string memory:

      
      : (pp 'prf)
      (de prf (Flt)
         (native "@" "printf" NIL 24662032 (cons Flt 1000000)) )
      -> prf
      

      This pointer will be used by printf directly, without any further conversion or memory management.


      Callbacks

      Sometimes it is necessary to do the reverse: Call Lisp code from C code. This can be done in two ways - with certain limitations.

      Call by Name

      The first way is actually not a callback in the strict sense. It just allows to call a Lisp function with a given name.

      The limitation is that this function can accept only maximally five numeric arguments, and returns a number.

      The prerequisite is, of course, that you have access to the C source code. To use it from C, insert the following prototype somewhere before the first call:

      
      long lisp(char*,long,long,long,long,long);
      

      Then you can call lisp from C:

      
      long n = lisp("myLispFun", a, b, 0, 0, 0);
      

      The first argument should be the name of a Lisp function (built-in, or defined in Lisp). It is searched for at runtime, so it doesn't need to exist at the time the C library is compiled or loaded.

      Be sure to pass dummy arguments (e.g. zero) if your function expects less than five arguments, to keep the C compiler happy.

      This mechanism can generally be used for any type of argument and return value (not only long). On the C side, appropriate casts or a adapted prototype should be used. It is then up to the called Lisp function to prepare and/or extract the proper data with struct and memory management operations.

      Function Pointer

      This is a true callback mechanism. It uses the Lisp-level function lisp (not to confuse with the C-level function with the same name in the previous section). No C source code access is required.

      lisp returns a function pointer, which can be passed to C functions via native. When this function pointer is dereferenced and called from the C code, the corresponding Lisp function is invoked. Here, too, only five numeric arguments and a numeric return value can be used, and other data types must be handled by the Lisp function with struct and memory management operations.

      Callbacks are often used in user interface libraries, to handle key-, mouse- and other events. Examples can be found in "@lib/openGl.l". The following function mouseFunc takes a Lisp function, installs it under the tag mouseFunc (any other tag would be all right too) as a callback, and passes the resulting function pointer to the OpenGL glutMouseFunc() function, to set it as a callback for the current window:

      
      (de mouseFunc (Fun)
         (native `*GlutLib "glutMouseFunc" NIL (lisp 'mouseFunc Fun)) )
      

      (The global *GlutLib holds the library "/usr/lib/libglut.so". The backquote (`) is important here, so that the transient symbol with the library name (and not the global *GlutLib) is evaluated by native, resulting in the proper library handle at runtime).

      A program using OpenGL may then use mouseFunc to install a function

      
      (mouseFunc
         '((Btn State X Y)
            (do-something-with Btn State X Y) ) )
      

      so that future clicks into the window will pass the button, state and coordinates to that function. picolisp-3.1.5.2.orig/doc/quine0000644000000000000000000000071012265263724014757 0ustar rootrootWith lambda (= 'quote'): : ('((X) (list (lit X) (lit X))) '((X) (list (lit X) (lit X)))) -> ('((X) (list (lit X) (lit X))) '((X) (list (lit X) (lit X)))) With 'let': : (let X '(list 'let 'X (lit X) X) (list 'let 'X (lit X) X)) -> (let X '(list 'let 'X (lit X) X) (list 'let 'X (lit X) X)) Cheating: : (de quine NIL (pp 'quine) ) -> quine : (quine) (de quine NIL (pp 'quine) ) -> quine Succinct: : T -> T picolisp-3.1.5.2.orig/doc/ref.html0000644000000000000000000027366612265263724015403 0ustar rootroot PicoLisp Reference abu@software-lab.de

      Perfection is attained
      not when there is nothing left to add
      but when there is nothing left to take away
      (Antoine de Saint-Exupéry)

      The PicoLisp Reference

      (c) Software Lab. Alexander Burger

      This document describes the concepts, data types, and kernel functions of the PicoLisp system.

      This is not a Lisp tutorial. For an introduction to Lisp, a traditional Lisp book like "Lisp" by Winston/Horn (Addison-Wesley 1981) is recommended. Note, however, that there are significant differences between PicoLisp and Maclisp (and even greater differences to Common Lisp).

      Please take a look at the PicoLisp Tutorial for an explanation of some aspects of PicoLisp, and scan through the list of Frequently Asked Questions (FAQ).


      Introduction

      PicoLisp is the result of a language design study, trying to answer the question "What is a minimal but useful architecture for a virtual machine?". Because opinions differ about what is meant by "minimal" and "useful", there are many answers to that question, and people might consider other solutions more "minimal" or more "useful". But from a practical point of view, PicoLisp has proven to be a valuable answer to that question.

      First of all, PicoLisp is a virtual machine architecture, and then a programming language. It was designed in a "bottom up" way, and "bottom up" is also the most natural way to understand and to use it: Form Follows Function.

      PicoLisp has been used in several commercial and research programming projects since 1988. Its internal structures are simple enough, allowing an experienced programmer always to fully understand what's going on under the hood, and its language features, efficiency and extensibility make it suitable for almost any practical programming task.

      In a nutshell, emphasis was put on four design objectives. The PicoLisp system should be

      Simple
      The internal data structure should be as simple as possible. Only one single data structure is used to build all higher level constructs.
      Unlimited
      There are no limits imposed upon the language due to limitations of the virtual machine architecture. That is, there is no upper bound in symbol name length, number digit counts, stack depth, or data structure and buffer sizes, except for the total memory size of the host machine.
      Dynamic
      Behavior should be as dynamic as possible ("run"-time vs. "compile"-time). All decisions are delayed until runtime where possible. This involves matters like memory management, dynamic symbol binding, and late method binding.
      Practical
      PicoLisp is not just a toy of theoretical value. It is in use since 1988 in actual application development, research and production.


      The PicoLisp Machine

      An important point in the PicoLisp philosophy is the knowledge about the architecture and data structures of the internal machinery. The high-level constructs of the programming language directly map to that machinery, making the whole system both understandable and predictable.

      This is similar to assembly language programming, where the programmer has complete control over the machine.


      The Cell

      The PicoLisp virtual machine is both simpler and more powerful than most current (hardware) processors. At the lowest level, it is constructed from a single data structure called "cell":

      
               +-----+-----+
               | CAR | CDR |
               +-----+-----+
      

      A cell is a pair of machine words, which traditionally are called CAR and CDR in the Lisp terminology. These words can represent either a numeric value (scalar) or the address of another cell (pointer). All higher level data structures are built out of cells.

      The type information of higher level data is contained in the pointers to these data. Assuming the implementation on a byte-addressed physical machine, and a pointer size of typically 4 bytes, each cell has a size of 8 bytes. Therefore, the pointer to a cell must point to an 8-byte boundary, and its bit-representation will look like:

      
            xxxxxxxxxxxxxxxxxxxxxxxxxxxxx000
      

      (the 'x' means "don't care"). For the individual data types, the pointer is adjusted to point to other parts of a cell, in effect setting some of the lower three bits to non-zero values. These bits are then used by the interpreter to determine the data type.

      In any case, bit(0) - the least significant of these bits - is reserved as a mark bit for garbage collection.

      Initially, all cells in the memory are unused (free), and linked together to form a "free list". To create higher level data types at runtime, cells are taken from that free list, and returned by the garbage collector when they are no longer needed. All memory management is done via that free list; there are no additional buffers, string spaces or special memory areas, with two exceptions:

      • A certain fixed area of memory is set aside to contain the executable code and global variables of the interpreter itself, and
      • a standard push down stack for return addresses and temporary storage. Both are not directly accessible by the programmer).


      Data Types

      On the virtual machine level, PicoLisp supports

      • three base data types: Numbers, Symbols and Cons Pairs (Lists),
      • the three scope variations of symbols: Internal, Transient and External, and
      • the special symbol NIL.

      They are all built from the single cell data structure, and all runtime data cannot consist of any other types than these three.

      The following diagram shows the complete data type hierarchy, consisting of the three base types and the symbol variations:

      
                          cell
                           |
                  +--------+--------+
                  |        |        |
               Number    Symbol    Pair
                           |
                           |
         +--------+--------+--------+
         |        |        |        |
        NIL   Internal Transient External
      


      Numbers

      A number can represent a signed integral value of arbitrary size. The CARs of one or more cells hold the number's "digits" (each in the machine's word size), to store the number's binary representation.

      
               Number
               |
               V
            +-----+-----+
            | DIG |  |  |
            +-----+--+--+
                     |
                     V
                  +-----+-----+
                  | DIG |  |  |
                  +-----+--+--+
                           |
                           V
                          ...
      

      The first cell holds the least significant digit. The least significant bit of that digit represents the sign.

      The pointer to a number points into the middle of the CAR, with an offset of 2 from the cell's start address. Therefore, the bit pattern of a number will be:

      
            xxxxxxxxxxxxxxxxxxxxxxxxxxxxx010
      

      Thus, a number is recognized by the interpreter when bit(1) is non-zero.


      Symbols

      A symbol is more complex than a number. Each symbol has a value, and optionally a name and an arbitrary number of properties. The CDR of a symbol cell is also called VAL, and the CAR points to the symbol's tail. As a minimum, a symbol consists of a single cell, and has no name or properties:

      
                  Symbol
                  |
                  V
            +-----+-----+
            |  /  | VAL |
            +-----+-----+
      

      That is, the symbol's tail is empty (points to NIL, as indicated by the '/' character).

      The pointer to a symbol points to the CDR of the cell, with an offset of 4 from the cell's start address. Therefore, the bit pattern of a symbol will be:

      
            xxxxxxxxxxxxxxxxxxxxxxxxxxxxx100
      

      Thus, a symbol is recognized by the interpreter when bit(2) is non-zero.

      A property is a key-value pair, represented by a cons pair in the symbol's tail. This is called a "property list". The property list may be terminated by a number representing the symbol's name. In the following example, a symbol with the name "abc" has three properties: A KEY/VAL pair, a cell with only a KEY, and another KEY/VAL pair.

      
                  Symbol
                  |
                  V
            +-----+-----+
            |  |  | VAL |
            +--+--+-----+
               | tail
               |
               V                                                      name
               +-----+-----+     +-----+-----+     +-----+-----+     +-----+-----+
               |  |  |  ---+---> | KEY |  ---+---> |  |  |  ---+---> |'cba'|  /  |
               +--+--+-----+     +-----+-----+     +--+--+-----+     +-----+-----+
                  |                                   |
                  V                                   V
                  +-----+-----+                       +-----+-----+
                  | VAL | KEY |                       | VAL | KEY |
                  +-----+-----+                       +-----+-----+
      

      Each property in a symbol's tail is either a symbol (like the single KEY above, then it represents the boolean value T), or a cons pair with the property key in its CDR and the property value in its CAR. In both cases, the key should be a symbol, because searches in the property list are performed using pointer comparisons.

      The name of a symbol is stored as a number at the end of the tail. It contains the characters of the name in UTF-8 encoding, using between one and three 8-bit-bytes per character. The first byte of the first character is stored in the lowest 8 bits of the number.

      All symbols have the above structure, but depending on scope and accessibility there are actually four types of symbols: NIL, internal, transient and external symbols.


      NIL

      NIL is a special symbol which exists exactly once in the whole system. It is used

      • as an end-of-list marker
      • to represent the empty list
      • to represent the boolean value "false"
      • to represent the absolute minimum
      • to represent a string of length zero
      • to represent the value "Not a Number"
      • as the root of all class hierarchies

      For that, NIL has a special structure:

      
            NIL:  /
                  |
                  V
            +-----+-----+-----+-----+
            |  /  |  /  |  /  |  /  |
            +-----+--+--+-----+-----+
      

      The reason for that structure is NIL's dual nature both as a symbol and as a list:

      • As a symbol, it should give NIL for its VAL, and be without properties
      • For the empty list, NIL should give NIL both for its CAR and for its CDR

      These requirements are fulfilled by the above structure.


      Internal Symbols

      Internal Symbols are all those "normal" symbols, as they are used for function definitions and variable names. They are "interned" into an index structure, so that it is possible to find an internal symbol by searching for its name.

      There cannot be two different internal symbols with the same name.

      Initially, a new internal symbol's VAL is NIL.


      Transient Symbols

      Transient symbols are only interned into a index structure for a certain time (e.g. while reading the current source file), and are released after that. That means, a transient symbol cannot be accessed then by its name, and there may be several transient symbols in the system having the same name.

      Transient symbols are used

      • as text strings
      • as identifiers with a limited access scope (like, for example, static identifiers in the C language family)
      • as anonymous, dynamically created objects (without a name)

      Initially, a new transient symbol's VAL is that symbol itself.

      A transient symbol without a name can be created with the box or new functions.


      External Symbols

      External symbols reside in a database file (or a similar resources, see *Ext), and are loaded into memory - and written back to the file - dynamically as needed, and transparently to the programmer. They are kept in memory ("cached") as long as they are accessible ("referred to") from other parts of the program, or when they were modified but not yet written to the database file (by commit).

      The interpreter recognizes external symbols internally by an additional tag bit in the tail structure.

      There cannot be two different external symbols with the same name. External symbols are maintained in index structures while they are loaded into memory, and have their external location (disk file and block offset) directly coded into their names (more details here).

      Initially, a new external symbol's VAL is NIL, unless otherwise specified at creation time.


      Lists

      A list is a sequence of one or more cells (cons pairs), holding numbers, symbols, or cons pairs.

      
            |
            V
            +-----+-----+
            | any |  |  |
            +-----+--+--+
                     |
                     V
                     +-----+-----+
                     | any |  |  |
                     +-----+--+--+
                              |
                              V
                              ...
      

      Lists are used in PicoLisp to emulate composite data structures like arrays, trees, stacks or queues.

      In contrast to lists, numbers and symbols are collectively called "Atoms".

      Typically, the CDR of each cell in a list points to the following cell, except for the last cell which points to NIL. If, however, the CDR of the last cell points to an atom, that cell is called a "dotted pair" (because of its I/O syntax with a dot '.' between the two values).


      Memory Management

      The PicoLisp interpreter has complete knowledge of all data in the system, due to the type information associated with every pointer. Therefore, an efficient garbage collector mechanism can easily be implemented. PicoLisp employs a simple but fast mark-and-sweep garbage collector.

      As the collection process is very fast (in the order of milliseconds per megabyte), it was not necessary to develop more complicated, time-consuming and error-prone garbage collection algorithms (e.g. incremental collection). A compacting garbage collector is also not necessary, because the single cell data type cannot cause heap fragmentation.


      Programming Environment

      Lisp was chosen as the programming language, because of its clear and simple structure.

      In some previous versions, a Forth-like syntax was also implemented on top of a similar virtual machine (Lifo). Though that language was more flexible and expressive, the traditional Lisp syntax proved easier to handle, and the virtual machine can be kept considerably simpler. PicoLisp inherits the major advantages of classical Lisp systems like

      • Dynamic data types and structures
      • Formal equivalence of code and data
      • Functional programming style
      • An interactive environment

      In the following, some concepts and peculiarities of the PicoLisp language and environment are described.


      Installation

      PicoLisp supports two installation strategies: Local and Global.

      Normally, if you didn't build PicoLisp yourself but installed it with your operating system's package manager, you will have a global installation. This allows system-wide access to the executable and library/documentation files.

      To get a local installation, you can directly download the PicoLisp tarball, and follow the instructions in the INSTALL file.

      A local installation will not interfere in any way with the world outside its directory. There is no need to touch any system locations, and you don't have to be root to install it. Many different versions - or local modifications - of PicoLisp can co-exist on a single machine.

      Note that you are still free to have local installations along with a global installation, and invoke them explicitly as desired.

      Most examples in the following apply to a global installation.


      Invocation

      When PicoLisp is invoked from the command line, an arbitrary number of arguments may follow the command name.

      By default, each argument is the name of a file to be executed by the interpreter. If, however, the argument's first character is a hyphen '-', then the rest of that argument is taken as a Lisp function call (without the surrounding parentheses), and a hyphen by itself as an argument stops evaluation of the rest of the command line (it may be processed later using the argv and opt functions). This whole mechanism corresponds to calling (load T).

      A special case is if the last argument is a single '+'. This will switch on debug mode (the *Dbg global variable) and discard the '+'.

      As a convention, PicoLisp source files have the extension ".l".

      Note that the PicoLisp executable itself does not expect or accept any command line flags or options (except the '+', see above). They are reserved for application programs.

      The simplest and shortest invocation of PicoLisp does nothing, and exits immediately by calling bye:

      
      $ picolisp -bye
      $
      

      In interactive mode, the PicoLisp interpreter (see load) will also exit when Ctrl-D is entered:

      
      $ picolisp
      : $                     # Typed Ctrl-D
      

      To start up the standard PicoLisp environment, several files should be loaded. The most commonly used things are in "lib.l" and in a bunch of other files, which are in turn loaded by "ext.l". Thus, a typical call would be:

      
      $ picolisp lib.l ext.l
      

      The recommended way, however, is to call the "pil" shell script, which includes "lib.l" and "ext.l". Given that your current project is loaded by some file "myProject.l" and your startup function is main, your invocation would look like:

      
      $ pil myProject.l -main
      

      For interactive development it is recommended to enable debugging mode, to get the vi-style line editor, single-stepping, tracing and other debugging utilities.

      
      $ pil myProject.l -main +
      

      This is - in a local installation - equivalent to

      
      $ ./pil myProject.l -main +
      

      In any case, the directory part of the first file name supplied (normally, the path to "lib.l" as called by 'pil') is remembered internally as the PicoLisp Home Directory. This path is later automatically substituted for any leading "@" character in file name arguments to I/O functions (see path).

      Instead of the default vi-style line editor, an emacs-style editor can be used. It can be switched on permanently by calling the function (em) (i.e. without arguments), or by passing -em on the command line:

      
      $ pil -em +
      :
      

      A single call is enough, because the style will be remembered in a file "~/.pil/editor", and used in all subsequent PicoLisp sessions.

      To switch back to 'vi' style, call (vi), use the -vi command line option, or simply remove "~/.pil/editor".


      Input/Output

      In Lisp, each internal data structure has a well-defined external representation in human-readable format. All kinds of data can be written to a file, and restored later to their original form by reading that file.

      In normal operation, the PicoLisp interpreter continuously executes an infinite "read-eval-print loop". It reads one expression at a time, evaluates it, and prints the result to the console. Any input into the system, like data structures and function definitions, is done in a consistent way no matter whether it is entered at the console or read from a file.

      Comments can be embedded in the input stream with the hash # character. Everything up to the end of that line will be ignored by the reader.

      
      : (* 1 2 3)  # This is a comment
      -> 6
      

      A comment spanning several lines may be enclosed between #{ and }#.

      Here is the I/O syntax for the individual PicoLisp data types (numbers, symbols and lists) and for read-macros:


      Numbers

      A number consists of an arbitrary number of digits ('0' through '9'), optionally preceded by a sign character ('+' or '-'). Legal number input is:

      
      : 7
      -> 7
      : -12345678901245678901234567890
      -> -12345678901245678901234567890
      

      Fixpoint numbers can be input by embedding a decimal point '.', and setting the global variable *Scl appropriately:

      
      : *Scl
      -> 0
      
      : 123.45
      -> 123
      : 456.78
      -> 457
      
      : (setq *Scl 3)
      -> 3
      : 123.45
      -> 123450
      : 456.78
      -> 456780
      

      Thus, fixpoint input simply scales the number to an integer value corresponding to the number of digits in *Scl.

      Formatted output of scaled fixpoint values can be done with the format and round functions:

      
      : (format 1234567890 2)
      -> "12345678.90"
      : (format 1234567890 2 "." ",")
      -> "12,345,678.90"
      


      Symbols

      The reader is able to recognize the individual symbol types from their syntactic form. A symbol name should - of course - not look like a legal number (see above).

      In general, symbol names are case-sensitive. car is not the same as CAR.


      NIL

      Besides for standard normal form, NIL is also recognized as (), [] or "".

      
      : NIL
      -> NIL
      : ()
      -> NIL
      : ""
      -> NIL
      

      Output will always appear as NIL.


      Internal Symbols

      Internal symbol names can consist of any printable (non-whitespace) character, except for the following meta characters:

      
         "  '  (  )  ,  [  ]  `  ~ { }
      

      It is possible, though, to include these special characters into symbol names by escaping them with a backslash '\'.

      The dot '.' has a dual nature. It is a meta character when standing alone, denoting a dotted pair, but can otherwise be used in symbol names.

      As a rule, anything not recognized by the reader as another data type will be returned as an internal symbol.


      Transient Symbols

      A transient symbol is anything surrounded by double quotes '"'. With that, it looks - and can be used - like a string constant in other languages. However, it is a real symbol, and may be assigned a value or a function definition, and properties.

      Initially, a transient symbol's value is that symbol itself, so that it does not need to be quoted for evaluation:

      
      : "This is a string"
      -> "This is a string"
      

      However, care must be taken when assigning a value to a transient symbol. This may cause unexpected behavior:

      
      : (setq "This is a string" 12345)
      -> 12345
      : "This is a string"
      -> 12345
      

      The name of a transient symbol can contain any character except the null-byte. A double quote character can be escaped with a backslash '\', and a backslash itself has to be escaped with another backslash. Control characters can be written with a preceding hat '^' character.

      
      : "We^Ird\\Str\"ing"
      -> "We^Ird\\Str\"ing"
      : (chop @)
      -> ("W" "e" "^I" "r" "d" "\\" "S" "t" "r" "\"" "i" "n" "g")
      

      A backslash '\' in a transient symbol name at the end of a line discards the newline, and continues the name in the next line. In that case, all leading spaces and tabs in that line are discarded, to allow proper source code indentation.

      
      : "abc\
         def"
      -> "abcdef"
      

      The index for transient symbols is cleared automatically before and after loading a source file, or it can be reset explicitly with the ==== function. With that mechanism, it is possible to create symbols with a local access scope, not accessible from other parts of the program.

      A special case of transient symbols are anonymous symbols. These are symbols without name (see box, box? or new). They print as a dollar sign ($) followed by a decimal digit string (actually their machine address).


      External Symbols

      External symbol names are surrounded by braces ('{' and '}'). The characters of the symbol's name itself identify the physical location of the external object. This is

      • in the 32-bit version: The number of the database file, and - separated by a hyphen - the starting block in the database file. Both numbers are encoded in base-64 notation (characters '0' through '9', ':', ';', 'A' through 'Z' and 'a' through 'z').
      • in the 64-bit version: The number of the database file minus 1 in "hax" notation (i.e. hexadecimal/alpha notation, where '@' is zero, 'A' is 1 and 'O' is 15 (from "alpha" to "omega")), immediately followed (without a hyphen) the starting block in octal ('0' through '7').

      In both cases, the database file (and possibly the hypen) are omitted for the first (default) file.


      Lists

      Lists are surrounded by parentheses ('(' and ')').

      (A) is a list consisting of a single cell, with the symbol A in its CAR, and NIL in its CDR.

      (A B C) is a list consisting of three cells, with the symbols A, B and C respectively in their CAR, and NIL in the last cell's CDR.

      (A . B) is a "dotted pair", a list consisting of a single cell, with the symbol A in its CAR, and B in its CDR.

      PicoLisp has built-in support for reading and printing simple circular lists. If the dot in a dotted-pair notation is immediately followed by a closing parenthesis, it indicates that the CDR of the last cell points back to the beginning of that list.

      
      : (let L '(a b c) (conc L L))
      -> (a b c .)
      : (cdr '(a b c .))
      -> (b c a .)
      : (cddddr '(a b c .))
      -> (b c a .)
      

      A similar result can be achieved with the function circ. Such lists must be used with care, because many functions won't terminate or will crash when given such a list.


      Read-Macros

      Read-macros in PicoLisp are special forms that are recognized by the reader, and modify its behavior. Note that they take effect immediately while reading an expression, and are not seen by the eval in the main loop.

      The most prominent read-macro in Lisp is the single quote character "'", which expands to a call of the quote function. Note that the single quote character is also printed instead of the full function name.

      
      : '(a b c)
      -> (a b c)
      : '(quote . a)
      -> 'a
      : (cons 'quote 'a)   # (quote . a)
      -> 'a
      : (list 'quote 'a)   # (quote a)
      -> '(a)
      

      A comma (,) will cause the reader to collect the following data item into an idx tree in the global variable *Uni, and to return a previously inserted equal item if present. This makes it possible to create a unique list of references to data which do normally not follow the rules of pointer equality. If the value of *Uni is T, the comma read macro mechanism is disabled.

      A single backquote character "`" will cause the reader to evaluate the following expression, and return the result.

      
      : '(a `(+ 1 2 3) z)
      -> (a 6 z)
      

      A tilde character ~ inside a list will cause the reader to evaluate the following expression, and (destructively) splice the result into the list.

      
      : '(a b c ~(list 'd 'e 'f) g h i)
      -> (a b c d e f g h i)
      

      When a tilde character is used to separate two symbol names (without surrounding whitespace), the first is taken as a namespace to look up the second (64-bit version only).

      
      : 'libA~foo  # Look up 'foo' in namespace 'libA'
      -> "foo"     # "foo" is not interned in the current namespace
      

      Reading libA~foo is equivalent to switching the current namespace to libA (with symbols), reading the symbol foo, and then switching back to the original namespace.

      Brackets ('[' and ']') can be used as super parentheses. A closing bracket will match the innermost opening bracket, or all currently open parentheses.

      
      : '(a (b (c (d]
      -> (a (b (c (d))))
      : '(a (b [c (d]))
      -> (a (b (c (d))))
      

      Finally, reading the sequence '{}' will result in a new anonymous symbol with value NIL, equivalent to a call to box without arguments.

      
      : '({} {} {})
      -> ($134599965 $134599967 $134599969)
      : (mapcar val @)
      -> (NIL NIL NIL)
      


      Evaluation

      PicoLisp tries to evaluate any expression encountered in the read-eval-print loop. Basically, it does so by applying the following three rules:

      • A number evaluates to itself.
      • A symbol evaluates to its value (VAL).
      • A list is evaluated as a function call, with the CAR as the function and the CDR the arguments to that function. These arguments are in turn evaluated according to these three rules.
      
      : 1234
      -> 1234        # Number evaluates to itself
      : *Pid
      -> 22972       # Symbol evaluates to its VAL
      : (+ 1 2 3)
      -> 6           # List is evaluated as a function call
      

      For the third rule, however, things get a bit more involved. First - as a special case - if the CAR of the list is a number, the whole list is returned as it is:

      
      : (1 2 3 4 5 6)
      -> (1 2 3 4 5 6)
      

      This is not really a function call but just a convenience to avoid having to quote simple data lists.

      Otherwise, if the CAR is a symbol or a list, PicoLisp tries to obtain an executable function from that, by either using the symbol's value, or by evaluating the list.

      What is an executable function? Or, said in another way, what can be applied to a list of arguments, to result in a function call? A legal function in PicoLisp is

      either
      a number. When a number is used as a function, it is simply taken as a pointer to executable code that will be called with the list of (unevaluated) arguments as its single parameter. It is up to that code to evaluate the arguments, or not. Some functions do not evaluate their arguments (e.g. quote) or evaluate only some of their arguments (e.g. setq).
      or
      a lambda expression. A lambda expression is a list, whose CAR is either a symbol or a list of symbols, and whose CDR is a list of expressions. Note: In contrast to other Lisp implementations, the symbol LAMBDA itself does not exist in PicoLisp but is implied from context.

      A few examples should help to understand the practical consequences of these rules. In the most common case, the CAR will be a symbol defined as a function, like the * in:

      
      : (* 1 2 3)    # Call the function '*'
      -> 6
      

      Inspecting the VAL of * gives

      
      : *            # Get the VAL of the symbol '*'
      -> 67318096
      

      The VAL of * is a number. In fact, it is the numeric representation of a C-function pointer, i.e. a pointer to executable code. This is the case for all built-in functions of PicoLisp.

      Other functions in turn are written as Lisp expressions:

      
      : (de foo (X Y)            # Define the function 'foo'
         (* (+ X Y) (+ X Y)) )
      -> foo
      : (foo 2 3)                # Call the function 'foo'
      -> 25
      : foo                      # Get the VAL of the symbol 'foo'
      -> ((X Y) (* (+ X Y) (+ X Y)))
      

      The VAL of foo is a list. It is the list that was assigned to foo with the de function. It would be perfectly legal to use setq instead of de:

      
      : (setq foo '((X Y) (* (+ X Y) (+ X Y))))
      -> ((X Y) (* (+ X Y) (+ X Y)))
      : (foo 2 3)
      -> 25
      

      If the VAL of foo were another symbol, that symbol's VAL would be used instead to search for an executable function.

      As we said above, if the CAR of the evaluated expression is not a symbol but a list, that list is evaluated to obtain an executable function.

      
      : ((intern (pack "c" "a" "r")) (1 2 3))
      -> 1
      

      Here, the intern function returns the symbol car whose VAL is used then. It is also legal, though quite dangerous, to use the code-pointer directly:

      
      : *
      -> 67318096
      : ((* 2 33659048) 1 2 3)
      -> 6
      : ((quote . 67318096) 1 2 3)
      -> 6
      : ((quote . 1234) (1 2 3))
      Segmentation fault
      

      When an executable function is defined in Lisp itself, we call it a lambda expression. A lambda expression always has a list of executable expressions as its CDR. The CAR, however, must be a either a list of symbols, or a single symbol, and it controls the evaluation of the arguments to the executable function according to the following rules:

      When the CAR is a list of symbols
      For each of these symbols an argument is evaluated, then the symbols are bound simultaneously to the results. The body of the lambda expression is executed, then the VAL's of the symbols are restored to their original values. This is the most common case, a fixed number of arguments is passed to the function.
      Otherwise, when the CAR is the symbol @
      All arguments are evaluated and the results kept internally in a list. The body of the lambda expression is executed, and the evaluated arguments can be accessed sequentially with the args, next, arg and rest functions. This allows to define functions with a variable number of evaluated arguments.
      Otherwise, when the CAR is a single symbol
      The symbol is bound to the whole unevaluated argument list. The body of the lambda expression is executed, then the symbol is restored to its original value. This allows to define functions with unevaluated arguments. Any kind of interpretation and evaluation of the argument list can be done inside the expression body.

      In all cases, the return value is the result of the last expression in the body.

      
      : (de foo (X Y Z)                   # CAR is a list of symbols
         (list X Y Z) )                   # Return a list of all arguments
      -> foo
      : (foo (+ 1 2) (+ 3 4) (+ 5 6))
      -> (3 7 11)                         # all arguments are evaluated
      
      
      : (de foo X                         # CAR is a single symbol
         X )                              # Return the argument
      -> foo
      : (foo (+ 1 2) (+ 3 4) (+ 5 6))
      -> ((+ 1 2) (+ 3 4) (+ 5 6))        # the whole unevaluated list is returned
      
      
      : (de foo @                         # CAR is the symbol '@'
         (list (next) (next) (next)) )    # Return the first three arguments
      -> foo
      : (foo (+ 1 2) (+ 3 4) (+ 5 6))
      -> (3 7 11)                         # all arguments are evaluated
      

      Note that these forms can also be combined. For example, to evaluate only the first two arguments, bind the results to X and Y, and bind all other arguments (unevaluated) to Z:

      
      : (de foo (X Y . Z)                 # CAR is a list with a dotted-pair tail
         (list X Y Z) )                   # Return a list of all arguments
      -> foo
      : (foo (+ 1 2) (+ 3 4) (+ 5 6))
      -> (3 7 ((+ 5 6)))                  # Only the first two arguments are evaluated
      

      Or, a single argument followed by a variable number of arguments:

      
      : (de foo (X . @)                   # CAR is a dotted-pair with '@'
         (println X)                      # print the first evaluated argument
         (while (args)                    # while there are more arguments
            (println (next)) ) )          # print the next one
      -> foo
      : (foo (+ 1 2) (+ 3 4) (+ 5 6))
      3                                   # X
      7                                   # next argument
      11                                  # and the last argument
      -> 11
      

      In general, if more than the expected number of arguments is supplied to a function, these extra arguments will be ignored. Missing arguments default to NIL.


      Coroutines

      Coroutines are independent execution contexts. They may have multiple entry and exit points, and preserve their environment between invocations.

      They are available only in the 64-bit version.

      A coroutine is identified by a tag. This tag can be passed to other functions, and (re)invoked as needed. In this regard coroutines are similar to "continuations" in other languages.

      When the tag goes out of scope while it is not actively running, the coroutine will be garabage collected. In cases where this is desired, using a transient symbol for the tag is recommended.

      A coroutine is created by calling co. Its prg body will be executed, and unless yield is called at some point, the coroutine will "fall off" at the end and disappear.

      When yield is called, control is either transferred back to the caller, or to some other - explicitly specified, and already running - coroutine.

      A coroutine is stopped and disposed when

      • execution falls off the end
      • some other (co)routine calls co with that tag but without a prg body
      • a throw into another (co)routine environment is executed
      • an error occurred, and error handling was entered

      Reentrant coroutines are not supported: A coroutine cannot resume itself directly or indirectly.

      Before using coroutines, make sure you have sufficient stack space, e.g. by calling

      
      $ ulimit -s unlimited
      

      Without that, the stack limit in Linux is typically 8 MB. This gives only room - with a default coroutine stack segment size of 1 MB - for the main segment (4 MB) plus four coroutines.


      Interrupt

      During the evaluation of an expression, the PicoLisp interpreter can be interrupted at any time by hitting Ctrl-C. It will then enter the breakpoint routine, as if ! were called.

      Hitting ENTER at that point will continue evaluation, while (quit) will abort evaluation and return the interpreter to the top level. See also debug, e, ^ and *Dbg

      Other interrupts may be handled by alarm, sigio, *Hup and *Sig[12].


      Error Handling

      When a runtime error occurs, execution is stopped and an error handler is entered.

      The error handler resets the I/O channels to the console, and displays the location (if possible) and the reason of the error, followed by an error message. That message is also stored in the global *Msg, and the location of the error in ^. If the VAL of the global *Err is non-NIL it is executed as a prg body. If the standard input is from a terminal, a read-eval-print loop (with a question mark "?" as prompt) is entered (the loop is exited when an empty line is input). Then all pending finally expressions are executed, all variable bindings restored, and all files closed. If the standard input is not from a terminal, the interpreter terminates. Otherwise it is reset to its top-level state.

      
      : (de foo (A B) (badFoo A B))       # 'foo' calls an undefined symbol
      -> foo
      : (foo 3 4)                         # Call 'foo'
      !? (badFoo A B)                     # Error handler entered
      badFoo -- Undefined
      ? A                                 # Inspect 'A'
      -> 3
      ? B                                 # Inspect 'B'
      -> 4
      ?                                   # Empty line: Exit
      :
      

      Errors can be caught with catch, if a list of substrings of possible error messages is supplied for the first argument. In such a case, the matching substring (or the whole error message if the substring is NIL) is returned.

      An arbitrary error can be thrown explicitly with quit.


      @ Result

      In certain situations, the result of the last evaluation is stored in the VAL of the symbol @. This can be very convenient, because it often makes the assignment to temporary variables unnecessary.

      This happens in two - only superficially similar - situations:

      load
      In read-eval loops, the last three results which were printed at the console are available in @@@, @@ and @, in that order (i.e the latest result is in @).
      
      : (+ 1 2 3)
      -> 6
      : (/ 128 4)
      -> 32
      : (- @ @@)        # Subtract the last two results
      -> 26
      

      Flow functions
      Flow- and logic-functions store the result of their controlling expression - respectively non-NIL results of their conditional expression - in @.
      
      : (while (read) (println 'got: @))
      abc            # User input
      got: abc       # print result
      123            # User input
      got: 123       # print result
      NIL
      -> 123
      
      : (setq L (1 2 3 4 5 1 2 3 4 5))
      -> (1 2 3 4 5 1 2 3 4 5)
      : (and (member 3 L) (member 3 (cdr @)) (set @ 999))
      -> 999
      : L
      -> (1 2 3 4 5 1 2 999 4 5)
      

      Functions with controlling expressions are case, casq, prog1, prog2, and the bodies of *Run tasks.

      Functions with conditional expressions are and, cond, do, for, if, if2, ifn, loop, nand, nond, nor, not, or, state, unless, until, when and while.

      @ is generally local to functions and methods, its value is automatically saved upon function entry and restored at exit.


      Comparing

      In PicoLisp, it is legal to compare data items of arbitrary type. Any two items are either

      Identical
      They are the same memory object (pointer equality). For example, two internal symbols with the same name are identical. In the 64-bit version, also short numbers (up to 60 bits plus sign) are pointer-equal.
      Equal
      They are equal in every respect (structure equality), but need not to be identical. Examples are numbers with the same value, transient symbols with the same name or lists with equal elements.
      Or they have a well-defined ordinal relationship
      Numbers are comparable by their numeric value, strings by their name, and lists recursively by their elements (if the CAR's are equal, their CDR's are compared). For differing types, the following rule applies: Numbers are less than symbols, and symbols are less than lists. As special cases, NIL is always less than anything else, and T is always greater than anything else.

      To demonstrate this, sort a list of mixed data types:

      
      : (sort '("abc" T (d e f) NIL 123 DEF))
      -> (NIL 123 DEF "abc" (d e f) T)
      

      See also max, min, rank, <, =, > etc.


      OO Concepts

      PicoLisp comes with built-in object oriented extensions. There seems to be a common agreement upon three criteria for object orientation:

      Encapsulation
      Code and data are encapsulated into objects, giving them both a behavior and a state. Objects communicate by sending and receiving messages.
      Inheritance
      Objects are organized into classes. The behavior of an object is inherited from its class(es) and superclass(es).
      Polymorphism
      Objects of different classes may behave differently in response to the same message. For that, classes may define different methods for each message.

      PicoLisp implements both objects and classes with symbols. Object-local data are stored in the symbol's property list, while the code (methods) and links to the superclasses are stored in the symbol's VAL (encapsulation).

      In fact, there is no formal difference between objects and classes (except that objects usually are anonymous symbols containing mostly local data, while classes are named internal symbols with an emphasis on method definitions). At any time, a class may be assigned its own local data (class variables), and any object can receive individual method definitions in addition to (or overriding) those inherited from its (super)classes.

      PicoLisp supports multiple inheritance. The VAL of each object is a (possibly empty) association list of message symbols and method bodies, concatenated with a list of classes. When a message is sent to an object, it is searched in the object's own method list, and then (with a left-to-right depth-first search) in the tree of its classes and superclasses. The first method found is executed and the search stops. The search may be explicitly continued with the extra and super functions.

      Thus, which method is actually executed when a message is sent to an object depends on the classes that the object is currently linked to (polymorphism). As the method search is fully dynamic (late binding), an object's type (i.e. its classes and method definitions) can be changed even at runtime!

      While a method body is being executed, the global variable This is set to the current object, allowing the use of the short-cut property functions =:, : and ::.


      Database

      On the lowest level, a PicoLisp database is just a collection of external symbols. They reside in a database file, and are dynamically swapped in and out of memory. Only one database can be open at a time (pool).

      In addition, further external symbols can be specified to originate from arbitrary sources via the *Ext mechanism.

      Whenever an external symbol's value or property list is accessed, it will be automatically fetched into memory, and can then be used like any other symbol. Modifications will be written to disk only when commit is called. Alternatively, all modifications since the last call to commit can be discarded by calling rollback.


      Transactions

      In the typical case there will be multiple processes operating on the same database. These processes should be all children of the same parent process, which takes care of synchronizing read/write operations and heap contents. Then a database transaction is normally initiated by calling (dbSync), and closed by calling (commit 'upd). Short transactions, involving only a single DB operation, are available in functions like new! and methods like put!> (by convention with an exclamation mark), which implicitly call (dbSync) and (commit 'upd) themselves.

      A transaction proceeds through five phases:

      1. dbSync waits to get a lock on the root object *DB. Other processes continue reading and writing meanwhile.
      2. dbSync calls sync to synchronize with changes from other processes. We hold the shared lock, but other processes may continue reading.
      3. We make modifications to the internal state of external symbols with put>, set>, lose> etc. We - and also other processes - can still read the DB.
      4. We call (commit 'upd). commit obtains an exclusive lock (no more read operations by other processes), writes an optional transaction log, and then all modified symbols. As upd is passed to 'commit', other processes synchronize with these changes.
      5. Finally, all locks are released by 'commit'


      Entities / Relations

      The symbols in a database can be used to store arbitrary information structures. In typical use, some symbols represent nodes of search trees, by holding keys, values, and links to subtrees in their VAL's. Such a search tree in the database is called index.

      For the most part, other symbols in the database are objects derived from the +Entity class.

      Entities depend on objects of the +relation class hierarchy. Relation-objects manage the property values of entities, they define the application database model and are responsible for the integrity of mutual object references and index trees.

      Relations are stored as properties in the entity classes, their methods are invoked as daemons whenever property values in an entity are changed. When defining an +Entity class, relations are defined - in addition to the method definitions of a normal class - with the rel function. Predefined relation classes include

      • Primitive types like
        +Symbol
        Symbolic data
        +String
        Strings (just a general case of symbols)
        +Number
        Integers and fixpoint 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
      • Object-to-object relations
        +Link
        A reference to some other entity
        +Hook
        A reference to an entity holding object-local index trees
        +Joint
        A bidirectional reference to some other entity
      • 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
      • 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 a modified Soundex-Algorithm
      • Booleans
        +Bool
        T or NIL
      • And a catch-all class
        +Any
        Not specified, may be any of the above relations


      Pilog (PicoLisp Prolog)

      A declarative language is built on top of PicoLisp, that has the semantics of Prolog, but uses the syntax of Lisp.

      For an explanation of Prolog's declarative programming style, an introduction like "Programming in Prolog" by Clocksin/Mellish (Springer-Verlag 1981) is recommended.

      Facts and rules can be declared with the be function. For example, a Prolog fact 'likes(john,mary).' is written in Pilog as:

      
      (be likes (John Mary))
      

      and a rule 'likes(john,X) :- likes(X,wine), likes(X,food).' is in Pilog:

      
      (be likes (John @X) (likes @X wine) (likes @X food))
      

      As in Prolog, the difference between facts and rules is that the latter ones have conditions, and usually contain variables.

      A variable in Pilog is any symbol starting with an at-mark character ("@"). The symbol @ itself can be used as an anonymous variable: It will match during unification, but will not be bound to the matched values.

      The cut operator of Prolog (usually written as an exclamation mark (!)) is the symbol T in Pilog.

      An interactive query can be done with the ? function:

      
      (? (likes John @X))
      

      This will print all solutions, waiting for user input after each line. If a non-empty line (not just a ENTER key, but for example a dot (.) followed by ENTER) is typed, it will terminate.

      Pilog can be called from Lisp and vice versa:

      • The interface from Lisp is via the functions goal (prepare a query from Lisp data) and prove (return an association list of successful bindings), and the application level functions pilog and solve.
      • When the CAR of a Pilog clause is a Pilog variable, the CDR is executed as a Lisp expression and the result unified with that variable.
      • Within such a Lisp expression in a Pilog clause, the current bindings of Pilog variables can be accessed with the -> function.


      Naming Conventions

      It was necessary to introduce - and adhere to - a set of conventions for PicoLisp symbol names. Because all (internal) symbols have a global scope (there are no packages or name spaces), and each symbol can only have either a value or function definition, it would otherwise be very easy to introduce name conflicts. Besides this, source code readability is increased when the scope of a symbol is indicated by its name.

      These conventions are not hard-coded into the language, but should be so into the head of the programmer. Here are the most commonly used ones:

      • Global variables start with an asterisk "*"
      • Functions and other global symbols start with a lower case letter
      • Locally bound symbols start with an upper case letter
      • Local functions start with an underscore "_"
      • Classes start with a plus-sign "+", where the first letter
        • is in lower case for abstract classes
        • and in upper case for normal classes
      • Methods end with a right arrow ">"
      • Class variables may be indicated by an upper case letter

      For historical reasons, the global constant symbols T and NIL do not obey these rules, and are written in upper case.

      For example, a local variable could easily overshadow a function definition:

      
      : (de max-speed (car)
         (.. (get car 'speeds) ..) )
      -> max-speed
      

      Inside the body of max-speed (and all other functions called during that execution) the kernel function car is redefined to some other value, and will surely crash if something like (car Lst) is executed. Instead, it is safe to write:

      
      : (de max-speed (Car)            # 'Car' with upper case first letter
         (.. (get Car 'speeds) ..) )
      -> max-speed
      

      Note that there are also some strict naming rules (as opposed to the voluntary conventions) that are required by the corresponding kernel functionalities, like:

      • Transient symbols are enclosed in double quotes (see Transient Symbols)
      • External symbols are enclosed in braces (see External Symbols)
      • Pattern-Wildcards start with an at-mark "@" (see match and fill)
      • Symbols referring to a shared library contain a colon "lib:sym"

      With that, the last of the above conventions (local functions start with an underscore) is not really necessary, because true local scope can be enforced with transient symbols.


      Breaking Traditions

      PicoLisp does not try very hard to be compatible with traditional Lisp systems. If you are used to some other Lisp dialects, you may notice the following differences:

      Case Sensitivity
      PicoLisp distinguishes between upper case and lower case characters in symbol names. Thus, CAR and car are different symbols, which was not the case in traditional Lisp systems.
      QUOTE
      In traditional Lisp, the QUOTE function returns its first unevaluated argument. In PicoLisp, on the other hand, quote returns all (unevaluated) argument(s).
      LAMBDA
      The LAMBDA function, in some way at the heart of traditional Lisp, is completely missing (and quote is used instead).
      PROG
      The PROG function of traditional Lisp, with its GOTO and ENTER functionality, is also missing. PicoLisp's prog function is just a simple sequencer (as PROGN in some Lisps).
      Function/Value
      In PicoLisp, a symbol cannot have a value and a function definition at the same time. Though this is a disadvantage at first sight, it allows a completely uniform handling of functional data.


      Bugs

      The names of the symbols T and NIL violate the naming conventions. They are global symbols, and should therefore start with an asterisk "*". It is too easy to bind them to some other value by mistake:

      
      (de foo (R S T)
         ...
      

      However, lint will issue a warning in such a case.


      Function Reference

      This section provides a reference manual for the kernel functions, and some extensions. See the thematically grouped list of indexes below.

      Though PicoLisp is a dynamically typed language (resolved at runtime, as opposed to statically (compile-time) typed languages), many functions can only accept and/or return a certain set of data types. For each function, the expected argument types and return values are described with the following abbreviations:

      The primary data types:

      • num - Number
      • sym - Symbol
      • lst - List

      Other (derived) data types

      • any - Anything: Any primary data type
      • flg - Flag: Boolean value (NIL or non-NIL)
      • cnt - A count or a small number
      • dat - Date: Days, starting first of March of the year 0 A.D.
      • tim - Time: Seconds since midnight
      • obj - Object/Class: A symbol with methods and/or classes
      • var - Variable: Either a symbol or a cons pair
      • exe - Executable: A list as executable expression (eval)
      • prg - Prog-Body: A list of executable expressions (run)
      • fun - Function: Either a number (code-pointer), a symbol (message) or a list (lambda)
      • msg - Message: A symbol sent to an object (to invoke a method)
      • cls - Class: A symbol defined as an object's class
      • typ - Type: A list of cls symbols
      • pat - Pattern: A symbol whose name starts with an at-mark "@"
      • pid - Process ID: A number, the ID of a Unix process
      • tree - Database index tree specification
      • hook - Database hook object

      Arguments evaluated by the function (depending on the context) are quoted (prefixed with the single quote character "'").

      A B C D E F G H I J K L M N O P Q R S T U V W X Y Z Other

      Symbol Functions
      new sym str char name sp? pat? fun? all symbols local import 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
      Property Access
      put get prop ; =: : :: putl getl wipe meta
      Predicates
      atom pair circ? lst? num? sym? flg? sp? pat? fun? box? str? ext? bool not == n== = <> =0 =T n0 nT < <= > >= match
      Arithmetics
      + - * / % */ ** 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
      List Processing
      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 bytes val set xchg push push1 pop cut queue fifo idx balance get fill apply
      Control Flow
      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 casq state while until loop do at for catch throw finally co yield ! e $ call tick ipid opid kill quit task fork pipe later timeout abort bye
      Mapping
      apply pass maps map mapc maplist mapcar mapcon mapcan filter extract seek find pick cnt sum maxi mini fish by
      Input/Output
      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
      Object Orientation
      *Class class dm rel var var: new type isa method meth send try object extend super extra with This can dep
      Database
      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 +Hook2 +index +Key +Ref +Ref2 +Idx +Sn +Fold +IdxFold +Aux +UB +Dep +List +Need +Mis +Alt +Swap +Entity blob dbSync new! set! put! inc! blob! upd rel request obj fmt64 root fetch store count leaf minKey maxKey init step scan iter ubIter 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
      Pilog
      prove -> unify be clause 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
      Debugging
      pretty pp show loc *Dbg doc more depth what who can dep debug d unbug u vi em ld trace untrace traceAll proc hd bench edit lint lintAll select update
      System Functions
      cmd argv opt version gc raw alarm protect heap stack adr env trail up sys 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
      Globals
      NIL pico *CPU *OS *DB T *Solo *PPid *Pid @ @@ @@@ This *Prompt *Dbg *Zap *Scl *Class *Dbs *Run *Hup *Sig1 *Sig2 ^ *Err *Msg *Uni *Led *Tsm *Adr *Allow *Fork *Bye


      Download

      The PicoLisp system can be downloaded from the PicoLisp Download page. picolisp-3.1.5.2.orig/doc/refA.html0000644000000000000000000005057712265263724015476 0ustar rootroot A

      A

      *Adr
      A global variable holding the IP address of last recently accepted client. See also listen and accept.
      
      : *Adr
      -> "127.0.0.1"
      
      (adr 'var) -> num
      (adr 'num) -> var
      Converts, in the first form, a variable var (a symbol or a cons pair) into num (actually an encoded pointer). A symbol will result in a negative number, and a cons pair in a positive number. The second form converts a pointer back into the original var.
      
      : (setq X (box 7))
      -> $53063416137450
      : (adr X)
      -> -2961853431592
      : (adr @)
      -> $53063416137450
      : (val @)
      -> 7
      
      *Allow
      A global variable holding allowed access patterns. If its value is non-NIL, it should contain a list where the CAR is an idx tree of allowed items, and the CDR a list of prefix strings. See also allow, allowed and pre?.
      
      : (allowed ("app/")  # Initialize
         "!start" "!stop" "lib.css" "!psh" )
      -> NIL
      : (allow "!myFoo")  # additional item
      -> "!myFoo"
      : (allow "myDir/" T)  # additional prefix
      -> "myDir/"
      
      : *Allow
      -> (("!start" ("!psh" ("!myFoo")) "!stop" NIL "lib.css") "app/" "myDir/")
      
      : (idx *Allow)  # items
      -> ("!myFoo" "!psh" "!start" "!stop" "lib.css")
      : (cdr *Allow)  # prefixes
      -> ("app/" "myDir/")
      
      +Alt
      Prefix class specifying an alternative class for a +relation. This allows indexes or other side effects to be maintained in a class different from the current one. See also Database.
      
      (class +EuOrd +Ord)                    # EU-specific order subclass
      (rel nr (+Alt +Key +Number) +XyOrd)    # Maintain the key in the +XyOrd index
      
      +Any
      Class for unspecified relations, a subclass of +relation. Objects of that class accept and maintain any type of Lisp data. Used often when there is no other suitable relation class available. See also Database.

      In the following example +Any is used simply for the reason that there is no direct way to specify dotted pairs:

      
      (rel loc (+Any))  # Locale, e.g. ("DE" . "de")
      
      +Aux
      Prefix class maintaining auxiliary keys for +relations, in addition to +Ref or +Idx indexes. Expects a list of auxiliary attributes of the same object, and combines all keys in that order into a single index key. See also +UB, aux and Database.
      
      (rel nr (+Ref +Number))                # Normal, non-unique index
      (rel nm (+Aux +Ref +String) (nr txt))  # Combined name/number/text index
      (rel txt (+Aux +Sn +Idx +String) (nr)) # Text/number plus tolerant text index
      
      (abort 'cnt . prg) -> any
      Aborts the execution of prg if it takes longer than cnt seconds, and returns NIL. Otherwise, the result of prg is returned. alarm is used internally, so care must be taken not to interfer with other calls to alarm.
      
      : (abort 20 (in Sock (rd)))  # Wait maximally 20 seconds for socket data
      
      (abs 'num) -> num
      Returns the absolute value of the num argument.
      
      : (abs -7)
      -> 7
      : (abs 7)
      -> 7
      
      (accept 'cnt) -> cnt | NIL
      Accepts a connection on descriptor cnt (as received by port), and returns the new socket descriptor cnt. The global variable *Adr is set to the IP address of the client. See also listen, connect and *Adr.
      
      : (setq *Socket
         (accept (port 6789)) )  # Accept connection at port 6789
      -> 4
      
      (accu 'var 'any 'num)
      Accumulates num into a sum, using the key any in an association list stored in var. See also assoc.
      
      : (off Sum)
      -> NIL
      : (accu 'Sum 'a 1)
      -> (a . 1)
      : (accu 'Sum 'a 5)
      -> 6
      : (accu 'Sum 22 100)
      -> (22 . 100)
      : Sum
      -> ((22 . 100) (a . 6))
      
      (acquire 'sym) -> flg
      Tries to acquire the mutex represented by the file sym, by obtaining an exclusive lock on that file with ctl, and then trying to write the PID of the current process into that file. It fails if the file already holds the PID of some other existing process. See also release, *Pid and rc.
      
      : (acquire "sema1")
      -> 28255
      
      (alarm 'cnt . prg) -> cnt
      Sets an alarm timer scheduling prg to be executed after cnt seconds, and returns the number of seconds remaining until any previously scheduled alarm was due to be delivered. Calling (alarm 0) will cancel an alarm. See also abort, sigio, *Hup and *Sig[12].
      
      : (prinl (tim$ (time) T)) (alarm 10 (prinl (tim$ (time) T)))
      16:36:14
      -> 0
      : 16:36:24
      
      : (alarm 10 (bye 0))
      -> 0
      $
      
      (align 'cnt 'any) -> sym
      (align 'lst 'any ..) -> sym
      Returns a transient symbol with all any arguments packed in an aligned format. In the first form, any will be left-aligned if cnt ist negative, otherwise right-aligned. In the second form, all any arguments are packed according to the numbers in lst. See also tab, center and wrap.
      
      : (align 4 "a")
      -> "   a"
      : (align -4 12)
      -> "12  "
      : (align (4 4 4) "a" 12 "b")
      -> "   a  12   b"
      
      (all ['T | '0]) -> lst
      Returns a new list of all internal symbols in the system (if called without arguments, or with NIL). Otherwise (if the argument is T), all current transient symbols are returned. Else all current external symbols are returned.
      
      : (all)  # All internal symbols
      -> (inc> leaf nil inc! accept ...
      
      # Find all symbols starting with an underscore character
      : (filter '((X) (= "_" (car (chop X)))) (all))
      -> (_put _nacs _oct _lintq _lst _map _iter _dbg2 _getLine _led ...
      
      (allow 'sym ['flg]) -> sym
      Maintains an index structure of allowed access patterns in the global variable *Allow. If the value of *Allow is non-NIL, sym is added to the idx tree in the CAR of *Allow (if flg is NIL), or to the list of prefix strings (if flg is non-NIL). See also allowed.
      
      : *Allow
      -> (("!start" ("!psh") "!stop" NIL "lib.css") "app/")
      : (allow "!myFoo")  # additionally allowed item
      -> "!myFoo"
      : (allow "myDir/" T)  # additionally allowed prefix
      -> "myDir/"
      
      (allowed lst [sym ..])
      Creates an index structure of allowed access patterns in the global variable *Allow. lst should consist of prefix strings (to be checked at runtime with pre?), and the sym arguments should specify the initially allowed items. See also allow.
      
      : (allowed ("app/")  # allowed prefixes
         "!start" "!stop" "lib.css" "!psh" )  # allowed items
      -> NIL
      
      (and 'any ..) -> any
      Logical AND. The expressions any are evaluated from left to right. If NIL is encountered, NIL is returned immediately. Else the result of the last expression is returned.
      
      : (and (= 3 3) (read))
      abc  # User input
      -> abc
      : (and (= 3 4) (read))
      -> NIL
      
      (any 'sym) -> any
      Parses any from the name of sym. This is the reverse operation of sym. See also str.
      
      : (any "(a b # Comment^Jc d)")
      -> (a b c d)
      : (any "\"A String\"")
      -> "A String"
      
      (append 'lst ..) -> lst
      Appends all argument lists. See also conc, insert, delete and remove.
      
      : (append '(a b c) (1 2 3))
      -> (a b c 1 2 3)
      : (append (1) (2) (3) 4)
      -> (1 2 3 . 4)
      
      append/3
      Pilog predicate that succeeds if appending the first two list arguments is equal to the third argument. See also append and member/2.
      
      : (? (append @X @Y (a b c)))
       @X=NIL @Y=(a b c)
       @X=(a) @Y=(b c)
       @X=(a b) @Y=(c)
       @X=(a b c) @Y=NIL
      -> NIL
      
      (apply 'fun 'lst ['any ..]) -> any
      Applies fun to lst. If additional any arguments are given, they are applied as leading elements of lst. (apply 'fun 'lst 'any1 'any2) is equivalent to (apply 'fun (cons 'any1 'any2 'lst)).
      
      : (apply + (1 2 3))
      -> 6
      : (apply * (5 6) 3 4)
      -> 360
      : (apply '((X Y Z) (* X (+ Y Z))) (3 4 5))
      -> 27
      : (apply println (3 4) 1 2)
      1 2 3 4
      -> 4
      
      (arg ['cnt]) -> any
      Can only be used inside functions with a variable number of arguments (with @). If cnt is not given, the value that was returned from the last call to next) is returned. Otherwise, the cnt'th remaining argument is returned. See also args, next, rest and pass.
      
      : (de foo @ (println (next) (arg)))    # Print argument twice
      -> foo
      : (foo 123)
      123 123
      -> 123
      : (de foo @
         (println (arg 1) (arg 2))
         (println (next))
         (println (arg 1) (arg 2)) )
      -> foo
      : (foo 'a 'b 'c)
      a b
      a
      b c
      -> c
      
      (args) -> flg
      Can only be used inside functions with a variable number of arguments (with @). Returns T when there are more arguments to be fetched from the internal list. See also next, arg, rest and pass.
      
      : (de foo @ (println (args)))       # Test for arguments
      -> foo
      : (foo)                             # No arguments
      NIL
      -> NIL
      : (foo NIL)                         # One argument
      T
      -> T
      : (foo 123)                         # One argument
      T
      -> T
      
      (argv [var ..] [. sym]) -> lst|sym
      If called without arguments, argv returns a list of strings containing all remaining command line arguments. Otherwise, the var/sym arguments are subsequently bound to the command line arguments. A hyphen "-" can be used to inhibit the automatic loading further arguments. See also cmd, Invocation and opt.
      
      $ pil -"println 'OK" - abc 123 +
      OK
      : (argv)
      -> ("abc" "123")
      : (argv A B)
      -> "123"
      : A
      -> "abc"
      : B
      -> "123"
      : (argv . Lst)
      -> ("abc" "123")
      : Lst
      -> ("abc" "123")
      
      (as 'any1 . any2) -> any2 | NIL
      Returns any2 unevaluated when any1 evaluates to non-NIL. Otherwise NIL is returned. (as Flg A B C) is equivalent to (and Flg '(A B C)). See also quote.
      
      : (as (= 3 3) A B C)
      -> (A B C)
      
      (asoq 'any 'lst) -> lst
      Searches an association list. Returns the first element from lst with any as its CAR, or NIL if no match is found. == is used for comparison (pointer equality). See also assoc, delq, memq, mmeq and Comparing.
      
      : (asoq 999 '((999 1 2 3) (b . 7) ("ok" "Hello")))
      -> NIL
      : (asoq 'b '((999 1 2 3) (b . 7) ("ok" "Hello")))
      -> (b . 7)
      
      (assert exe ..) -> prg | NIL
      When in debug mode (*Dbg is non-NIL), assert returns a prg list which tests all exe conditions, and issues an error via quit if one of the results evaluates to NIL. Otherwise, NIL is returned. Used typically in combination with the ~ tilde read-macro to insert the test code only when in debug mode. See also test.
      
      # Start in debug mode
      $ pil +
      : (de foo (N)
         ~(assert (>= 90 N 10))
         (bar N) )
      -> foo
      : (pp 'foo)                      # Pretty-print 'foo'
      (de foo (N)
         (unless (>= 90 N 10)          # Assertion code exists
            (quit "'assert' failed" '(>= 90 N 10)) )
         (bar N) )
      -> foo
      : (foo 7)                        # Try it
      (>= 90 N 10) -- Assertion failed
      ?
      
      # Start in non-debug mode
      $ pil
      : (de foo (N)
         ~(assert (>= 90 N 10))
         (bar N) )
      -> foo
      : (pp 'foo)                      # Pretty-print 'foo'
      (de foo (N)
         (bar N) )                     # Assertion code does not exist
      -> foo
      
      (asserta 'lst) -> lst
      Inserts a new Pilog fact or rule before all other rules. See also be, clause, assertz and retract.
      
      : (be a (2))            # Define two facts
      -> a
      : (be a (3))
      -> a
      
      : (asserta '(a (1)))    # Insert new fact in front
      -> ((1))
      
      : (? (a @N))            # Query
       @N=1
       @N=2
       @N=3
      -> NIL
      
      asserta/1
      Pilog predicate that inserts a new fact or rule before all other rules. See also asserta, assertz/1 and retract/1.
      
      : (? (asserta (a (2))))
      -> T
      : (? (asserta (a (1))))
      -> T
      : (rules 'a)
      1 (be a (1))
      2 (be a (2))
      -> a
      
      (assertz 'lst) -> lst
      Appends a new Pilog fact or rule behind all other rules. See also be, clause, asserta and retract.
      
      : (be a (1))            # Define two facts
      -> a
      : (be a (2))
      -> a
      
      : (assertz '(a (3)))    # Append new fact at the end
      -> ((3))
      
      : (? (a @N))            # Query
       @N=1
       @N=2
       @N=3
      -> NIL
      
      assertz/1
      Pilog predicate that appends a new fact or rule behind all other rules. See also assertz, asserta/1 and retract/1.
      
      : (? (assertz (a (1))))
      -> T
      : (? (assertz (a (2))))
      -> T
      : (rules 'a)
      1 (be a (1))
      2 (be a (2))
      -> a
      
      (assoc 'any 'lst) -> lst
      Searches an association list. Returns the first element from lst with its CAR equal to any, or NIL if no match is found. See also asoq.
      
      : (assoc "b" '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
      -> ("b" . 7)
      : (assoc 999 '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
      -> (999 1 2 3)
      : (assoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello")))
      -> NIL
      
      (at '(cnt1 . cnt2|NIL) . prg) -> any
      Increments cnt1 (destructively), and returns NIL when it is less than cnt2. Otherwise, cnt1 is reset to zero and prg is executed. Returns the result of prg. If cnt2 is NIL, nothing is done, and NIL is returned immediately.
      
      : (do 11 (prin ".") (at (0 . 3) (prin "!")))
      ...!...!...!..-> NIL
      
      (atom 'any) -> flg
      Returns T when the argument any is an atom (a number or a symbol). See also pair.
      
      : (atom 123)
      -> T
      : (atom 'a)
      -> T
      : (atom NIL)
      -> T
      : (atom (123))
      -> NIL
      
      (aux 'var 'cls ['hook] 'any ..) -> sym
      Returns a database object of class cls, where the value for var corresponds to any and the following arguments. var, cls and hook should specify a tree for cls or one of its superclasses, for a relation with auxiliary keys. For multi-key accesses, aux is simlar to - but faster than - db, because it can use a single tree access. See also db, collect, fetch, init, step and +Aux.
      
      (class +PS +Entity)
      (rel par (+Dep +Joint) (sup) ps (+Part))        # Part
      (rel sup (+Aux +Ref +Link) (par) NIL (+Supp))   # Supplier
      ...
         (aux 'sup '+PS                               # Access PS object
            (db 'nr '+Supp 1234)
            (db 'nr '+Part 5678) )
      
      picolisp-3.1.5.2.orig/doc/refB.html0000644000000000000000000003121312265263724015461 0ustar rootroot B

      B

      *Blob
      A global variable holding the pathname of the database blob directory. See also blob.
      
      : *Blob
      -> "blob/app/"
      
      *Bye
      A global variable holding a (possibly empty) prg body, to be executed just before the termination of the PicoLisp interpreter. See also bye and tmp.
      
      : (push1 '*Bye '(call 'rm "myfile.tmp"))  # Remove a temporary file
      -> (call 'rm "myfile.tmp")
      
      +Bag
      Class for a list of arbitrary relations, a subclass of +relation. Objects of that class maintain a list of heterogeneous relations. Typically used in combination with the +List prefix class, to maintain small two-dimensional tables within objects. See also Database.
      
      (rel pos (+List +Bag)         # Positions
         ((+Ref +Link) NIL (+Item))    # Item
         ((+Number) 2)                 # Price
         ((+Number))                   # Quantity
         ((+String))                   # Memo text
         ((+Number) 2) )               # Total amount
      
      +Blob
      Class for blob relations, a subclass of +relation. Objects of that class maintain blobs, as stubs in database objects pointing to actual files for arbitrary (often binary) data. The files themselves reside below the path specified by the *Blob variable. See also Database.
      
      (rel jpg (+Blob))  # Picture
      
      +Bool
      Class for boolean relations, a subclass of +relation. Objects of that class expect either T or NIL as value (though, as always, only non-NIL will be physically stored in objects). See also Database.
      
      (rel ok (+Ref +Bool))  # Indexed flag
      
      (balance 'var 'lst ['flg])
      Builds a balanced binary idx tree in var, from the sorted list in lst. Normally (if random or, in the worst case, ordered data) are inserted with idx, the tree will not be balanced. But if lst is properly sorted, its contents will be inserted in an optimally balanced way. If flg is non-NIL, the index tree will be augmented instead of being overwritten. See also Comparing and sort.
      
      # Normal idx insert
      : (off I)
      -> NIL
      : (for X (1 4 2 5 3 6 7 9 8) (idx 'I X T))
      -> NIL
      : (depth I)
      -> 7
      
      # Balanced insert
      : (balance 'I (sort (1 4 2 5 3 6 7 9 8)))
      -> NIL
      : (depth I)
      -> 4
      
      # Augment
      : (balance 'I (sort (10 40 20 50 30 60 70 90 80)) T)
      -> NIL
      : (idx 'I)
      -> (1 2 3 4 5 6 7 8 9 10 20 30 40 50 60 70 80 90)
      
      (basename 'any) -> sym
      Returns the filename part of a path name any. See also dirname and path.
      
      : (basename "a/b/c/d")
      -> "d"
      
      (be sym . any) -> sym
      Declares a Pilog fact or rule for the sym argument, by concatenating the any argument to the T property of sym. Groups of declarations are collected for a given sym. When sym changes, i.e. when it differs from the one in the previous declaration, the current group is considered to be complete and a new group is started. Later be declarations for a previously completed symbol will reset its rules, to allow repeated reloading of source files. See also clause, asserta, assertz, retract, rules, goal and prove.
      
      : (be likes (John Mary))
      -> likes
      : (be likes (John @X) (likes @X wine) (likes @X food))
      -> likes
      
      : (get 'likes T)
      -> (((John Mary)) ((John @X) (likes @X wine) (likes @X food)))
      
      : (rules 'likes)
      1 (be likes (John Mary))
      2 (be likes (John @X) (likes @X wine) (likes @X food))
      -> likes
      
      : (? (likes John @X))
       @X=Mary
      -> NIL
      
      (beep) -> any
      Send the bell character to the console. See also space, prin and char.
      
      : (beep)
      -> "^G"
      
      (bench . prg) -> any
      (Debug mode only) Benchmarks prg, by printing the time it took to execute, and returns the result. See also usec.
      
      : (bench (wait 2000))
      1.996 sec
      -> NIL
      
      (bin 'num ['num]) -> sym
      (bin 'sym) -> num
      Converts a number num to a binary string, or a binary string sym to a number. In the first case, if the second argument is given, the result is separated by spaces into groups of such many digits. See also oct, hex, fmt64, hax and format.
      
      : (bin 73)
      -> "1001001"
      : (bin "1001001")
      -> 73
      : (bin 1234567 4)
      -> "100 1011 0101 1010 0001 11"
      
      (bind 'sym|lst . prg) -> any
      Binds value(s) to symbol(s). The first argument must evaluate to a symbol, or a list of symbols or symbol-value pairs. The values of these symbols are saved (and the symbols bound to the values in the case of pairs), prg is executed, then the symbols are restored to their original values. During execution of prg, the values of the symbols can be temporarily modified. The return value is the result of prg. See also let, job and use.
      
      : (setq X 123)                               # X is 123
      -> 123
      : (bind 'X (setq X "Hello") (println X))  # Set X to "Hello", print it
      "Hello"
      -> "Hello"
      : (bind '((X . 3) (Y . 4)) (println X Y) (* X Y))
      3 4
      -> 12
      : X
      -> 123                                       # X is restored to 123
      
      (bit? 'num ..) -> num | NIL
      Returns the first num argument when all bits which are 1 in the first argument are also 1 in all following arguments, otherwise NIL. When one of those arguments evaluates to NIL, it is returned immediately. See also &, | and x|.
      
      : (bit? 7 15 255)
      -> 7
      : (bit? 1 3)
      -> 1
      : (bit? 1 2)
      -> NIL
      
      (blob 'obj 'sym) -> sym
      Returns the blob file name for var in obj. See also *Blob, blob! and pack.
      
      : (show (db 'nr '+Item 1))
      {3-1} (+Item)
         jpg
         pr 29900
         inv 100
         sup {2-1}
         nm "Main Part"
         nr 1
      -> {3-1}
      : (blob '{3-1} 'jpg)
      -> "blob/app/3/-/1.jpg"
      
      (blob! 'obj 'sym 'file)
      Stores the contents of file in a blob. See also put!>.
      
      (blob! *ID 'jpg "picture.jpg")
      
      (bool 'any) -> flg
      Returns T when the argument any is non-NIL. This function is only needed when T is strictly required for a "true" condition (Usually, any non-NIL value is considered to be "true"). See also flg?.
      
      : (and 3 4)
      -> 4
      : (bool (and 3 4))
      -> T
      
      bool/3
      Pilog predicate that succeeds if the first argument has the same truth value as the result of applying the get algorithm to the following arguments. Typically used as filter predicate in select/3 database queries. See also bool, isa/2, same/3, range/3, head/3, fold/3, part/3 and tolr/3.
      
      : (? @OK NIL         # Find orders where the 'ok' flag is not set
         (db nr +Ord @Ord)
         (bool @OK @Ord ok) )
       @OK=NIL @Ord={3-7}
      -> NIL
      
      (box 'any) -> sym
      Creates and returns a new anonymous symbol. The initial value is set to the any argument. See also new and box?.
      
      : (show (box '(A B C)))
      $134425627 (A B C)
      -> $134425627
      
      (box? 'any) -> sym | NIL
      Returns the argument any when it is an anonymous symbol, otherwise NIL. See also box, str? and ext?.
      
      : (box? (new))
      -> $134563468
      : (box? 123)
      -> NIL
      : (box? 'a)
      -> NIL
      : (box? NIL)
      -> NIL
      
      (by 'fun1 'fun2 'lst ..) -> lst
      Applies fun1 to each element of lst. When additional lst arguments are given, their elements are also passed to fun1. Each result of fun1 is CONSed with its corresponding argument form the original lst, and collected into a list which is passed to fun2. For the list returned from fun2, the CAR elements returned by fun1 are (destructively) removed from each element ("decorate-apply-undecorate" idiom).
      
      : (let (A 1 B 2 C 3) (by val sort '(C A B)))
      -> (A B C)
      : (by '((N) (bit? 1 N)) group (3 11 6 2 9 5 4 10 12 7 8 1))
      -> ((3 11 9 5 7 1) (6 2 4 10 12 8))
      
      (bye 'cnt|NIL)
      Executes all pending finally expressions, closes all open files, executes the VAL of the global variable *Bye (should be a prg), flushes standard output, and then exits the PicoLisp interpreter. The process return value is cnt, or 0 if the argument is missing or NIL.
      
      : (setq *Bye '((println 'OK) (println 'bye)))
      -> ((println 'OK) (println 'bye))
      : (bye)
      OK
      bye
      $
      
      (bytes 'any) -> cnt
      Returns the number of bytes any would occupy in encoded binary format (as generated by pr). See also size and length.
      
      : (bytes "abc")
      -> 4
      : (bytes "äbc")
      -> 5
      : (bytes 127)
      -> 2
      : (bytes 128)
      -> 3
      : (bytes (101 (102) 103))
      -> 10
      : (bytes (101 102 103 .))
      -> 9
      
      picolisp-3.1.5.2.orig/doc/refC.html0000644000000000000000000006223212265263724015467 0ustar rootroot C

      C

      *CPU
      (64-bit version only) A global variable holding the target CPU (architecture). Possible values include "x86-64", "ppc64" or "emu". See also *OS.
      
      : *CPU
      -> "x86-64"
      
      *Class
      A global variable holding the current class. See also OO Concepts, class, extend, dm and var and rel.
      
      : (class +Test)
      -> +Test
      : *Class
      -> +Test
      
      (cache 'var 'sym . prg) -> any
      Speeds up some calculations, by holding previously calculated results in an idx tree structure. Such an optimization is sometimes called "memoization". sym must be a transient symbol representing a unique key for the argument(s) to the calculation. See also hash.
      
      : (de fibonacci (N)
         (cache '(NIL) (pack (char (hash N)) N)
            (if (> 2 N)
               1
               (+
                  (fibonacci (dec N))
                  (fibonacci (- N 2)) ) ) ) )
      -> fibonacci
      : (fibonacci 22)
      -> 28657
      : (fibonacci 10000)
      -> 5443837311356528133873426099375038013538 ...  # (2090 digits)
      
      (call 'any ..) -> flg
      Calls an external system command. The any arguments specify the command and its arguments. Returns T if the command was executed successfully.
      
      : (when (call 'test "-r" "file.l")  # Test if file exists and is readable
         (load "file.l")  # Load it
         (call 'rm "file.l") )  # Remove it
      
      call/1
      Pilog predicate that succeeds if the argument term can be proven.
      
      : (be mapcar (@ NIL NIL))
      -> mapcar
      : (be mapcar (@P (@X . @L) (@Y . @M))
         (call @P @X @Y)                        # Call the given predicate
         (mapcar @P @L @M) )
      -> mapcar
      : (? (mapcar permute ((a b c) (d e f)) @X))
       @X=((a b c) (d e f))
       @X=((a b c) (d f e))
       @X=((a b c) (e d f))
       ...
       @X=((a c b) (d e f))
       @X=((a c b) (d f e))
       @X=((a c b) (e d f))
       ...
      
      (can 'msg) -> lst
      (Debug mode only) Returns a list of all classes that accept the message msg. See also OO Concepts, class, dep, what and who.
      
      : (can 'zap>)
      -> ((zap> . +relation) (zap> . +Blob) (zap> . +Entity))
      : (more @ pp)
      (dm (zap> . +relation) (Obj Val))
      
      (dm (zap> . +Blob) (Obj Val)
         (and
            Val
            (call 'rm "-f" (blob Obj (: var))) ) )
      
      (dm (zap> . +Entity) NIL
         (for X (getl This)
            (let V (or (atom X) (pop 'X))
               (and (meta This X) (zap> @ This V)) ) ) )
      
      -> NIL
      
      (car 'var) -> any
      List access: Returns the value of var if it is a symbol, or the first element if it is a list. See also cdr and c..r.
      
      : (car (1 2 3 4 5 6))
      -> 1
      
      (c[ad]*ar 'var) -> any
      (c[ad]*dr 'lst) -> any
      List access shortcuts. Combinations of the car and cdr functions, with up to four letters 'a' and 'd'.
      
      : (cdar '((1 . 2) . 3))
      -> 2
      
      (case 'any (any1 . prg1) (any2 . prg2) ..) -> any
      Multi-way branch: any is evaluated and compared to the CAR elements anyN of each clause. If one of them is a list, any is in turn compared to all elements of that list. T is a catch-all for any value. If a comparison succeeds, prgN is executed, and the result returned. Otherwise NIL is returned. See also casq and state .
      
      : (case (char 66) ("A" (+ 1 2 3)) (("B" "C") "Bambi") ("D" (* 1 2 3)))
      -> "Bambi"
      : (case 'b (a 1) ("b" 2) (b 3) (c 4))
      -> 2
      
      (casq 'any (any1 . prg1) (any2 . prg2) ..) -> any
      Multi-way branch: any is evaluated and compared to the CAR elements anyN of each clause. == is used for comparison (pointer equality). If one of them is a list, any is in turn compared to all elements of that list. T is a catch-all for any value. If a comparison succeeds, prgN is executed, and the result returned. Otherwise NIL is returned. See also case and state.
      
      : (casq 'b (a 1) ("b" 2) (b 3) (c 4))
      -> 3
      : (casq 'b (a 1) ("b" 2) ((a b c) 3) (c 4))
      -> 3
      
      (catch 'any . prg) -> any
      Sets up the environment for a non-local jump which may be caused by throw or by a runtime error. If any is an atom, it is used by throw as a jump label (with T being a catch-all for any label), and a throw called during the execution of prg will immediately return the thrown value. Otherwise, any should be a list of strings, to catch any error whose message contains one of these strings, and this will immediately return the matching string. If neither throw nor an error occurs, the result of prg is returned. See also finally, quit and Error Handling.
      
      : (catch 'OK (println 1) (throw 'OK 999) (println 2))
      1
      -> 999
      : (catch '("No such file") (in "doesntExist" (foo)))
      -> "No such file"
      
      (cd 'any) -> sym
      Changes the current directory to any. The old directory is returned on success, otherwise NIL. See also chdir, dir and pwd.
      
      : (when (cd "lib")
         (println (sum lines (dir)))
         (cd @) )
      10955
      
      (cdr 'lst) -> any
      List access: Returns all but the first element of lst. See also car and c..r.
      
      : (cdr (1 2 3 4 5 6))
      -> (2 3 4 5 6)
      
      (center 'cnt|lst 'any ..) -> sym
      Returns a transient symbol with all any arguments packed in a centered format. Trailing blanks are omitted. See also align, tab and wrap.
      
      : (center 4 12)
      -> " 12"
      : (center 4 "a")
      -> " a"
      : (center 7 "a")
      -> "   a"
      : (center (3 3 3) "a" "b" "c")
      -> " a  b  c"
      
      (chain 'lst ..) -> lst
      Concatenates (destructively) one or several new list elements lst to the end of the list in the current make environment. This operation is efficient also for long lists, because a pointer to the last element of the result list is maintained. chain returns the last linked argument. See also link, yoke and made.
      
      : (make (chain (list 1 2 3) NIL (cons 4)) (chain (list 5 6)))
      -> (1 2 3 4 5 6)
      
      (char) -> sym
      (char 'cnt) -> sym
      (char T) -> sym
      (char 'sym) -> cnt
      When called without arguments, the next character from the current input stream is returned as a single-character transient symbol, or NIL upon end of file. When called with a number cnt, a character with the corresponding unicode value is returned. As a special case, T is accepted to produce a byte value greater than any first byte in a UTF-8 character (used as a top value in comparisons). Otherwise, when called with a symbol sym, the numeric unicode value of the first character of the name of that symbol is returned. See also peek, skip, key, line, till and eof.
      
      : (char)                   # Read character from console
      A                          # (typed 'A' and a space/return)
      -> "A"
      : (char 100)               # Convert unicode to symbol
      -> "d"
      : (char "d")               # Convert symbol to unicode
      -> 100
      
      : (char T)                 # Special case
      -> # (not printable)
      
      : (char 0)
      -> NIL
      : (char NIL)
      -> 0
      
      (chdir 'any . prg) -> any
      Changes the current directory to any with cd during the execution of prg. Then the previous directory will be restored and the result of prg returned. See also dir and pwd.
      
      : (pwd)
      -> "/usr/abu/pico"
      : (chdir "src" (pwd))
      -> "/usr/abu/pico/src"
      : (pwd)
      -> "/usr/abu/pico"
      
      (chkTree 'sym ['fun]) -> num
      Checks a database tree node (and recursively all sub-nodes) for consistency. Returns the total number of nodes checked. Optionally, fun is called with the key and value of each node, and should return NIL for failure. See also tree and root.
      
      : (show *DB '+Item)
      {C} NIL
         sup (7 . {7-3})
         nr (7 . {7-1})    # 7 nodes in the 'nr' tree, base node is {7-1}
         pr (7 . {7-4})
         nm (77 . {7-6})
      -> {C}
      : (chkTree '{7-1})   # Check that node
      -> 7
      
      (chop 'any) -> lst
      Returns any as a list of single-character strings. If any is NIL or a symbol with no name, NIL is returned. A list argument is returned unchanged.
      
      : (chop 'car)
      -> ("c" "a" "r")
      : (chop "Hello")
      -> ("H" "e" "l" "l" "o")
      
      (circ 'any ..) -> lst
      Produces a circular list of all any arguments by consing them to a list and then connecting the CDR of the last cell to the first cell. See also circ? and list.
      
      : (circ 'a 'b 'c)
      -> (a b c .)
      
      (circ? 'any) -> any
      Returs the circular (sub)list if any is a circular list, else NIL. See also circ.
      
      : (circ? 'a)
      -> NIL
      : (circ? (1 2 3))
      -> NIL
      : (circ? (1 . (2 3 .)))
      -> (2 3 .)
      
      (class sym . typ) -> obj
      Defines sym as a class with the superclass(es) typ. As a side effect, the global variable *Class is set to obj. See also extend, dm, var, rel, type, isa and object.
      
      : (class +A +B +C +D)
      -> +A
      : +A
      -> (+B +C +D)
      : (dm foo> (X) (bar X))
      -> foo>
      : +A
      -> ((foo> (X) (bar X)) +B +C +D)
      
      (clause '(sym . any)) -> sym
      Declares a Pilog fact or rule for the sym argument, by concatenating the any argument to the T property of sym. See also be.
      
      : (clause '(likes (John Mary)))
      -> likes
      : (clause '(likes (John @X) (likes @X wine) (likes @X food)))
      -> likes
      : (? (likes @X @Y))
       @X=John @Y=Mary
      -> NIL
      
      clause/2
      Pilog predicate that succeeds if the first argument is a predicate which has the second argument defined as a clause.
      
      : (? (clause append ((NIL @X @X))))
      -> T
      
      : (? (clause append @C))
       @C=((NIL @X @X))
       @C=(((@A . @X) @Y (@A . @Z)) (append @X @Y @Z))
      -> NIL
      
      (clip 'lst) -> lst
      Returns a copy of lst with all whitespace characters or NIL elements removed from both sides. See also trim.
      
      : (clip '(NIL 1 NIL 2 NIL))
      -> (1 NIL 2)
      : (clip '(" " a " " b " "))
      -> (a " " b)
      
      (close 'cnt) -> cnt | NIL
      Closes a file descriptor cnt, and returns it when successful. Should not be called inside an out body for that descriptor. See also open, poll, listen and connect.
      
      : (close 2)                            # Close standard error
      -> 2
      
      (cmd ['any]) -> sym
      When called without an argument, the name of the command that invoked the picolisp interpreter is returned. Otherwise, the command name is set to any. Setting the name may not work on some operating systems. Note that the new name must not be longer than the original one. See also argv, file and Invocation.
      
      $ pil +
      : (cmd)
      -> "/usr/bin/picolisp"
      : (cmd "!/bin/picolust")
      -> "!/bin/picolust"
      : (cmd)
      -> "!/bin/picolust"
      
      (cnt 'fun 'lst ..) -> cnt
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns the count of non-NIL values returned from fun.
      
      : (cnt cdr '((1 . T) (2) (3 4) (5)))
      -> 2
      
      (collect 'var 'cls ['hook] ['any|beg ['end [var ..]]])
      Returns a list of all database objects of class cls, where the values for the var arguments correspond to the any arguments, or where the values for the var arguments are in the range beg .. end. var, cls and hook should specify a tree for cls or one of its superclasses. If additional var arguments are given, the final values for the result list are obtained by applying the get algorithm. See also db, aux, fetch, init and step.
      
      : (collect 'nr '+Item)
      -> ({3-1} {3-2} {3-3} {3-4} {3-5} {3-6} {3-8})
      : (collect 'nr '+Item 3 6 'nr)
      -> (3 4 5 6)
      : (collect 'nr '+Item 3 6 'nm)
      -> ("Auxiliary Construction" "Enhancement Additive" "Metal Fittings" "Gadget Appliance")
      : (collect 'nm '+Item "Main Part")
      -> ({3-1})
      
      (commit ['any] [exe1] [exe2]) -> T
      Closes a transaction, by writing all new or modified external symbols to, and removing all deleted external symbols from the database. When any is given, it is implicitly sent (with all modified objects) via the tell mechanism to all family members. If exe1 or exe2 are given, they are executed as pre- or post-expressions while the database is locked and protected. See also rollback.
      
      : (pool "db")
      -> T
      : (put '{1} 'str "Hello")
      -> "Hello"
      : (commit)
      -> T
      
      (con 'lst 'any) -> any
      Connects any to the first cell of lst, by (destructively) storing any in the CDR of lst. See also conc.
      
      : (setq C (1 . a))
      -> (1 . a)
      : (con C '(b c d))
      -> (b c d)
      : C
      -> (1 b c d)
      
      (conc 'lst ..) -> lst
      Concatenates all argument lists (destructively). See also append and con.
      
      : (setq  A (1 2 3)  B '(a b c))
      -> (a b c)
      : (conc A B)                        # Concatenate lists in 'A' and 'B'
      -> (1 2 3 a b c)
      : A
      -> (1 2 3 a b c)                    # Side effect: List in 'A' is modified!
      
      (cond ('any1 . prg1) ('any2 . prg2) ..) -> any
      Multi-way conditional: If any of the anyN conditions evaluates to non-NIL, prgN is executed and the result returned. Otherwise (all conditions evaluate to NIL), NIL is returned. See also nond, if, if2 and when.
      
      : (cond
         ((= 3 4) (println 1))
         ((= 3 3) (println 2))
         (T (println 3)) )
      2
      -> 2
      
      (connect 'any1 'any2) -> cnt | NIL
      Tries to establish a TCP/IP connection to a server listening at host any1, port any2. any1 may be either a hostname or a standard internet address in numbers-and-dots/colons notation (IPv4/IPv6). any2 may be either a port number or a service name. Returns a socket descriptor cnt, or NIL if the connection cannot be established. See also listen and udp.
      
      : (connect "localhost" 4444)
      -> 3
      : (connect "some.host.org" "http")
      -> 4
      
      (cons 'any ['any ..]) -> lst
      Constructs a new list cell with the first argument in the CAR and the second argument in the CDR. If more than two arguments are given, a corresponding chain of cells is built. (cons 'a 'b 'c 'd) is equivalent to (cons 'a (cons 'b (cons 'c 'd))). See also list.
      
      : (cons 1 2)
      -> (1 . 2)
      : (cons 'a '(b c d))
      -> (a b c d)
      : (cons '(a b) '(c d))
      -> ((a b) c d)
      : (cons 'a 'b 'c 'd)
      -> (a b c . d)
      
      (copy 'any) -> any
      Copies the argument any. For lists, the top level cells are copied, while atoms are returned unchanged.
      
      : (=T (copy T))               # Atoms are not copied
      -> T
      : (setq L (1 2 3))
      -> (1 2 3)
      : (== L L)
      -> T
      : (== L (copy L))             # The copy is not identical to the original
      -> NIL
      : (= L (copy L))              # But the copy is equal to the original
      -> T
      
      (co 'sym [. prg]) -> any
      (64-bit version only) Starts, resumes or stops a coroutine with the tag given by sym. If prg is not given, a coroutine with that tag will be stopped. Otherwise, if a coroutine running with that tag is found (pointer equality is used for comparison), its execution is resumed. Else a new coroutine with that tag is initialized and started. prg will be executed until it either terminates normally, or until yield is called. In the latter case co returns, or transfers control to some other, already running, coroutine. A coroutine cannot resume itself directly or indirectly. See also stack, catch and throw.
      
      : (de pythag (N)   # A generator function
         (if (=T N)
            (co 'rt)  # Stop
            (co 'rt
               (for X N
                  (for Y (range X N)
                     (for Z (range Y N)
                        (when (= (+ (* X X) (* Y Y)) (* Z Z))
                           (yield (list X Y Z)) ) ) ) ) ) ) )
      
      : (pythag 20)
      -> (3 4 5)
      : (pythag 20)
      -> (5 12 13)
      : (pythag 20)
      -> (6 8 10)
      
      
      (count 'tree) -> num
      Returns the number of nodes in a database tree. See also tree and root.
      
      : (count (tree 'nr '+Item))
      -> 7
      
      (ctl 'sym . prg) -> any
      Waits until a write (exclusive) lock (or a read (shared) lock if the first character of sym is "+") can be set on the file sym, then executes prg and releases the lock. If the files does not exist, it will be created. When sym is NIL, a shared lock is tried on the current innermost I/O channel, and when it is T, an exclusive lock is tried instead. See also in, out, err and pipe.
      
      $ echo 9 >count                           # Write '9' to file "count"
      $ pil +
      : (ctl ".ctl"                             # Exclusive control, using ".ctl"
         (in "count"
            (let Cnt (read)                     # Read '9'
               (out "count"
                  (println (dec Cnt)) ) ) ) )   # Write '8'
      -> 8
      :
      $ cat count                               # Check "count"
      8
      
      (ctty 'sym|pid) -> flg
      When called with a symbolic argument, ctty changes the current TTY device to sym. Otherwise, the local console is prepared for serving the PicoLisp process with the process ID pid. See also raw.
      
      : (ctty "/dev/tty")
      -> T
      
      (curry lst . fun) -> fun
      Builds a new function from the list of symbols or symbol-value pairs lst and the functional expression fun. Each member in lst that is a pat? symbol is substituted inside fun by its value. All other symbols in lst are collected into a job environment.
      
      : (de multiplier (@X)
         (curry (@X) (N) (* @X N)) )
      -> multiplier
      : (multiplier 7)
      -> ((N) (* 7 N))
      : ((multiplier 7) 3))
      -> 21
      
      : (def 'fiboCounter
         (curry ((N1 . 0) (N2 . 1)) (Cnt)
            (do Cnt
               (println
                  (prog1
                     (+ N1 N2)
                     (setq N1 N2  N2 @) ) ) ) ) )
      -> fiboCounter
      : (pp 'fiboCounter)
      (de fiboCounter (Cnt)
         (job '((N2 . 1) (N1 . 0))
            (do Cnt
               (println
                  (prog1 (+ N1 N2) (setq N1 N2 N2 @)) ) ) ) )
      -> fiboCounter
      : (fiboCounter 5)
      1
      2
      3
      5
      8
      -> 8
      : (fiboCounter 5)
      13
      21
      34
      55
      89
      -> 89
      
      (cut 'cnt 'var) -> lst
      Pops the first cnt elements (CAR) from the stack in var. See also pop and del.
      
      : (setq S '(1 2 3 4 5 6 7 8))
      -> (1 2 3 4 5 6 7 8)
      : (cut 3 'S)
      -> (1 2 3)
      : S
      -> (4 5 6 7 8)
      
      picolisp-3.1.5.2.orig/doc/refD.html0000644000000000000000000006743212265263724015477 0ustar rootroot D

      D

      *DB
      A global constant holding the external symbol {1}, the database root. All transient symbols in a database can be reached from that root. Except during debugging, any explicit literal access to symbols in the database should be avoided, because otherwise a memory leak might occur (The garbage collector temporarily sets *DB to NIL and restores its value after collection, thus disposing of all external symbols not currently used in the program).
      
      : (show *DB)
      {1} NIL
         +City {P}
         +Person {3}
      -> {1}
      : (show '{P})
      {P} NIL
         nm (566 . {AhDx})
      -> {P}
      : (show '{3})
      {3} NIL
         tel (681376 . {Agyl})
         nm (1461322 . {2gu7})
      -> {3}
      
      *Dbg
      A boolean variable indicating "debug mode". It can be conveniently switched on with a trailing + command line argument (see Invocation). When non-NIL, the $ (tracing) and ! (breakpoint) functions are enabled, and the current line number and file name will be stored in symbol properties by de, def and dm. See also debug, trace and lint.
      
      : (de foo (A B) (* A B))
      -> foo
      : (trace 'foo)
      -> foo
      : (foo 3 4)
       foo : 3 4
       foo = 12
      -> 12
      : (let *Dbg NIL (foo 3 4))
      -> 12
      
      *Dbs
      A global variable holding a list of numbers (block size scale factors, as needed by pool). It is typically set by dbs and dbs+.
      
      : *Dbs
      -> (1 2 1 0 2 3 3 3)
      
      +Date
      Class for calender dates (as calculated by date), a subclass of +Number. See also Database.
      
      (rel dat (+Ref +Date))  # Indexed date
      
      +Dep
      Prefix class for maintaining depenencies between +relations. Expects a list of (symbolic) attributes that depend on this relation. Whenever this relations is cleared (receives a value of NIL), the dependent relations will also be cleared, triggering all required side-effects. See also Database.

      In the following example, the index entry for the item pointing to the position (and, therefore, to the order) is cleared in case the order is deleted, or this position is deleted from the order:

      
      (class +Pos +Entity)                # Position class
      (rel ord (+Dep +Joint)              # Order of that position
         (itm)                               # 'itm' specifies the dependency
         pos (+Ord) )                        # Arguments to '+Joint'
      (rel itm (+Ref +Link) NIL (+Item))  # Item depends on the order
      
      (d) -> T
      (Debug mode only) Inserts ! breakpoints into all subexpressions of the current breakpoint. Typically used when single-stepping a function or method with debug. See also u and unbug.
      
      ! (d)                            # Debug subexpression(s) at breakpoint
      -> T
      
      (daemon 'sym . prg) -> fun
      (daemon '(sym . cls) . prg) -> fun
      (daemon '(sym sym2 [. cls]) . prg) -> fun
      Inserts prg in the beginning of the function (first form), the method body of sym in cls (second form) or in the class obtained by geting sym2 from *Class (or cls if given) (third form). Built-in functions (C-function pointer) are automatically converted to Lisp expressions. See also trace, expr, patch and redef.
      
      : (de hello () (prinl "Hello world!"))
      -> hello
      
      : (daemon 'hello (prinl "# This is the hello world program"))
      -> (NIL (prinl "# This is the hello world program") (prinl "Hello world!"))
      : (hello)
      # This is the hello world program
      Hello world!
      -> "Hello world!"
      
      : (daemon '* (msg 'Multiplying))
      -> (@ (msg 'Multiplying) (pass $134532148))
      : *
      -> (@ (msg 'Multiplying) (pass $134532148))
      : (* 1 2 3)
      Multiplying
      -> 6
      
      (dat$ 'dat ['sym]) -> sym
      Formats a date dat in ISO format, with an optional delimiter character sym. See also $dat, tim$, datStr and datSym.
      
      : (dat$ (date))
      -> "20070601"
      : (dat$ (date) "-")
      -> "2007-06-01"
      
      (datStr 'dat ['flg]) -> sym
      Formats a date according to the current locale. If flg is non-NIL, the year will be formatted modulo 100. See also dat$, datSym, strDat, expDat, expTel and day.
      
      : (datStr (date))
      -> "2007-06-01"
      : (locale "DE" "de")
      -> NIL
      : (datStr (date))
      -> "01.06.2007"
      : (datStr (date) T)
      -> "01.06.07"
      
      (datSym 'dat) -> sym
      Formats a date dat in in symbolic format (DDmmmYY). See also dat$ and datStr.
      
      : (datSym (date))
      -> "01jun07"
      
      (date ['T]) -> dat
      (date 'dat) -> (y m d)
      (date 'y 'm 'd) -> dat | NIL
      (date '(y m d)) -> dat | NIL
      Calculates a (gregorian) calendar date. It is represented as a day number, starting first of March of the year 0 AD. When called without arguments, the current date is returned. When called with a T argument, the current Coordinated Universal Time (UTC) is returned. When called with a single number dat, it is taken as a date and a list with the corresponding year, month and day is returned. When called with three numbers (or a list of three numbers) for the year, month and day, the corresponding date is returned (or NIL if they do not represent a legal date). See also time, stamp, $dat, dat$, datSym, datStr, strDat, expDat, day, week and ultimo.
      
      : (date)                         # Today
      -> 730589
      : (date 2000 6 12)               # 12-06-2000
      -> 730589
      : (date 2000 22 5)               # Illegal date
      -> NIL
      : (date (date))                  # Today's year, month and day
      -> (2000 6 12)
      : (- (date) (date 2000 1 1))     # Number of days since first of January
      -> 163
      
      (day 'dat ['lst]) -> sym
      Returns the name of the day for a given date dat, in the language of the current locale. If lst is given, it should be a list of alternative weekday names. See also week, datStr and strDat.
      
      : (day (date))
      -> "Friday"
      : (locale "DE" "de")
      -> NIL
      : (day (date))
      -> "Freitag"
      : (day (date) '("Mo" "Tu" "We" "Th" "Fr" "Sa" "Su"))
      -> "Fr"
      
      (db 'var 'cls ['hook] 'any ['var 'any ..]) -> sym | NIL
      Returns a database object of class cls, where the values for the var arguments correspond to the any arguments. If a matching object cannot be found, NIL is returned. var, cls and hook should specify a tree for cls or one of its superclasses. See also aux, collect, request, fetch, init and step.
      
      : (db 'nr '+Item 1)
      -> {3-1}
      : (db 'nm '+Item "Main Part")
      -> {3-1}
      
      db/3
      db/4
      db/5
      Pilog database predicate that returns objects matching the given key/value (and optional hook) relation. The relation should be of type +index. For the key pattern applies:

      • a symbol (string) returns all entries which start with that string
      • other atoms (numbers, external symbols) match as they are
      • cons pairs constitute a range, returning objects
        • in increasing order if the CDR is greater than the CAR
        • in decreasing order otherwise
      • other lists are matched for +Aux key combinations

      The optional hook can be supplied as the third argument. See also select/3 and remote/2.

      
      : (? (db nr +Item @Item))              # No value given
       @Item={3-1}
       @Item={3-2}
       @Item={3-3}
       @Item={3-4}
       @Item={3-5}
       @Item={3-6}
      -> NIL
      
      : (? (db nr +Item 2 @Item))            # Get item no. 2
       @Item={3-2}
      -> NIL
      
      : (? (db nm +Item Spare @Item) (show @Item))  # Search for "Spare.."
      {3-2} (+Item)
         pr 1250
         inv 100
         sup {2-2}
         nm "Spare Part"
         nr 2
       @Item={3-2}
      -> NIL
      
      (db: cls ..) -> num
      Returns the database file number for objects of the type given by the cls argument(s). Needed, for example, for the creation of new objects. See also dbs.
      
      : (db: +Item)
      -> 3
      
      (dbSync) -> flg
      Starts a database transaction, by trying to obtain a lock on the database root object *DB, and then calling sync to synchronize with possible changes from other processes. When all desired modifications to external symbols are done, (commit 'upd) should be called. See also Database.
      
      (let? Obj (rd)             # Get object?
         (dbSync)                # Yes: Start transaction
         (put> Obj 'nm (rd))     # Update
         (put> Obj 'nr (rd))
         (put> Obj 'val (rd))
         (commit 'upd) )         # Close transaction
      
      (dbck ['cnt] 'flg) -> any
      Performs a low-level integrity check of the current (or cnt'th) database file, and returns NIL (or the number of blocks and symbols if flg is non-NIL) if everything seems correct. Otherwise, a string indicating an error is returned. As a side effect, possibly unused blocks (as there might be when a rollback is done before commiting newly allocated (new) external symbols) are appended to the free list.
      
      : (pool "db")
      -> T
      : (dbck)
      -> NIL
      
      (dbs . lst)
      Initializes the global variable *Dbs. Each element in lst has a number in its CAR (the block size scale factor of a database file, to be stored in *Dbs). The CDR elements are either classes (so that objects of that class are later stored in the corresponding file), or lists with a class in the CARs and a list of relations in the CDRs (so that index trees for these relations go into that file). See also dbs+ and pool.
      
      (dbs
         (3 +Role +User +Sal)                         # 512 Prevalent objects
         (0 +Pos)                                     # A:64 Tiny objects
         (1 +Item +Ord)                               # B:128 Small objects
         (2 +CuSu)                                    # C:256 Normal objects
         (2 (+Role nm) (+User nm) (+Sal nm))          # D:256 Small indexes
         (4 (+CuSu nr plz tel mob))                   # E:1024 Normal indexes
         (4 (+CuSu nm))                               # F:1024
         (4 (+CuSu ort))                              # G:1024
         (4 (+Item nr sup pr))                        # H:1024
         (4 (+Item nm))                               # I:1024
         (4 (+Ord nr dat cus))                        # J:1024
         (4 (+Pos itm)) )                             # K:1024
      
      : *Dbs
      -> (1 2 1 0 2 4 4 4 4 4 4 4)
      : (get '+Item 'Dbf)
      -> (3 . 128)
      : (get '+Item 'nr 'dbf)
      -> (9 . 1024)
      
      (dbs+ 'num . lst)
      Extends the list of database sizes stored in *Dbs. num is the initial offset into the list. See also dbs.
      
      (dbs+ 9
         (1 +NewCls)                                  # (9 . 128)
         (3 (+NewCls nr nm)) )                        # (10 . 512)
      
      (de sym . any) -> sym
      Assigns a definition to the sym argument, by setting its VAL to the any argument. If the symbol has already another value, a "redefined" message is issued. When the value of the global variable *Dbg is non-NIL, the current line number and file name (if any) are stored in the *Dbg property of sym. de is the standard way to define a function. See also def, dm and undef.
      
      : (de foo (X Y) (* X (+ X Y)))  # Define a function
      -> foo
      : (foo 3 4)
      -> 21
      
      : (de *Var . 123)  # Define a variable value
      : *Var
      -> 123
      
      (debug 'sym) -> T
      (debug 'sym 'cls) -> T
      (debug '(sym . cls)) -> T
      (Debug mode only) Inserts a ! breakpoint function call at the beginning and all top-level expressions of the function or method body of sym, to allow a stepwise execution. Typing (d) at a breakpoint will also debug the current subexpression, and (e) will evaluate the current subexpression. The current subexpression is stored in the global variable ^. See also unbug, *Dbg, trace and lint.
      
      : (de tst (N)                    # Define tst
         (println (+ 3 N)) )
      -> tst
      : (debug 'tst)                   # Set breakpoints
      -> T
      : (pp 'tst)
      (de tst (N)
         (! println (+ 3 N)) )         # Breakpoint '!'
      -> tst
      : (tst 7)                        # Execute
      (println (+ 3 N))                # Stopped at beginning of 'tst'
      ! (d)                            # Debug subexpression
      -> T
      !                                # Continue
      (+ 3 N)                          # Stopped in subexpression
      ! N                              # Inspect variable 'N'
      -> 7
      !                                # Continue
      10                               # Output of print statement
      -> 10                            # Done
      : (unbug 'tst)
      -> T
      : (pp 'tst)                      # Restore to original
      (de tst (N)
         (println (+ 3 N)) )
      -> tst
      
      (dec 'num) -> num
      (dec 'var ['num]) -> num
      The first form returns the value of num decremented by 1. The second form decrements the VAL of var by 1, or by num. If the first argument is NIL, it is returned immediately. (dec Num) is equivalent to (- Num 1) and (dec 'Var) is equivalent to (set 'Var (- Var 1)). See also inc and -.
      
      : (dec -1)
      -> -2
      : (dec 7)
      -> 6
      : (setq N 7)
      -> 7
      : (dec 'N)
      -> 6
      : (dec 'N 3)
      -> 3
      
      (def 'sym 'any) -> sym
      (def 'sym1 'sym2 'any) -> sym1
      The first form assigns a definition to the first sym argument, by setting its VAL's to any. The second form defines a property value any for the first argument's sym2 key. If any of these values existed and was changed in the process, a "redefined" message is issued. When the value of the global variable *Dbg is non-NIL, the current line number and file name (if any) are stored in the *Dbg property of sym. See also de and dm.
      
      : (def 'b '((X Y) (* X (+ X Y))))
      -> b
      : (def 'b 999)
      # b redefined
      -> b
      
      (default var 'any ..) -> any
      Stores new values any in the var arguments only if their current values are NIL. Otherwise, their values are left unchanged. In any case, the last var's value is returned. default is used typically in functions to initialize optional arguments.
      
      : (de foo (A B)               # Function with two optional arguments
         (default  A 1  B 2)        # The default values are 1 and 2
         (list A B) )
      -> foo
      : (foo 333 444)               # Called with two arguments
      -> (333 444)
      : (foo 333)                   # Called with one arguments
      -> (333 2)
      : (foo)                       # Called without arguments
      -> (1 2)
      
      (del 'any 'var) -> lst
      Deletes any from the list in the value of var, and returns the remaining list. (del 'any 'var) is equivalent to (set 'var (delete 'any var)). See also delete, cut and pop.
      
      : (setq S '((a b c) (d e f)))
      -> ((a b c) (d e f))
      : (del '(d e f) 'S)
      -> ((a b c))
      : (del 'b S)
      -> (a c)
      
      (delete 'any 'lst) -> lst
      Deletes any from lst. If any is contained more than once in lst, only the first occurrence is deleted. See also delq, remove and insert.
      
      : (delete 2 (1 2 3))
      -> (1 3)
      : (delete (3 4) '((1 2) (3 4) (5 6) (3 4)))
      -> ((1 2) (5 6) (3 4))
      
      delete/3
      Pilog predicate that succeeds if deleting the first argument from the list in the second argument is equal to the third argument. See also delete and member/2.
      
      : (? (delete b (a b c) @X))
       @X=(a c)
      -> NIL
      
      (delq 'any 'lst) -> lst
      Deletes any from lst. If any is contained more than once in lst, only the first occurrence is deleted. == is used for comparison (pointer equality). See also delete, asoq, memq, mmeq and Comparing.
      
      : (delq 'b '(a b c))
      -> (a c)
      : (delq (2) (1 (2) 3))
      -> (1 (2) 3)
      
      (dep 'cls) -> cls
      (Debug mode only) Displays the "dependencies" of cls, i.e. the tree of superclasses and the tree of subclasses. See also OO Concepts, methods, class and can.
      
      : (dep '+Number)           # Dependencies of '+Number'
         +relation               # Single superclass is '+relation'
      +Number
         +Date                   # Subclasses are '+Date' and '+Time'
         +Time
      -> +Number
      
      (depth 'lst) -> (cnt1 . cnt2)
      Returns the maximal (cnt1) and the average (cnt2) "depth" of a tree structure as maintained by idx. See also length and size.
      
      : (off X)                                    # Clear variable
      -> NIL
      : (for N (1 2 3 4 5 6 7) (idx 'X N T))       # Build a degenerated tree
      -> NIL
      : X
      -> (1 NIL 2 NIL 3 NIL 4 NIL 5 NIL 6 NIL 7)   # Only right branches
      : (depth X)
      -> (7 . 4)                                   # Depth is 7, average 4
      
      (diff 'lst 'lst) -> lst
      Returns the difference of the lst arguments. See also sect.
      
      : (diff (1 2 3 4 5) (2 4))
      -> (1 3 5)
      : (diff (1 2 3) (1 2 3))
      -> NIL
      
      different/2
      Pilog predicate that succeeds if the two arguments are different. See also equal/2.
      
      : (? (different 3 4))
      -> T
      
      (dir ['any] ['flg]) -> lst
      Returns a list of all filenames in the directory any. Names starting with a dot '.' are ignored, unless flg is non-NIL. See also cd and info.
      
      : (filter '((F) (tail '(. c) (chop F))) (dir "src/"))
      -> ("main.c" "subr.c" "gc.c" "io.c" "big.c" "sym.c" "tab.c" "flow.c" ..
      
      (dirname 'any) -> sym
      Returns the directory part of a path name any. See also basename and path.
      
      : (dirname "a/b/c/d")
      -> "a/b/c/"
      
      (dm sym . fun|cls2) -> sym
      (dm (sym . cls) . fun|cls2) -> sym
      (dm (sym sym2 [. cls]) . fun|cls2) -> sym
      Defines a method for the message sym in the current class, implicitly given by the value of the global variable *Class, or - in the second form - for the explicitly given class cls. In the third form, the class object is obtained by geting sym2 from *Class (or cls if given). If the method for that class existed and was changed in the process, a "redefined" message is issued. If - instead of a method fun - a symbol specifying another class cls2 is given, the method from that class is used (explicit inheritance). When the value of the global variable *Dbg is non-NIL, the current line number and file name (if any) are stored in the *Dbg property of sym. See also OO Concepts, de, undef, class, rel, var, method, send and try.
      
      : (dm start> ()
         (super)
         (mapc 'start> (: fields))
         (mapc 'start> (: arrays)) )
      
      : (dm foo> . +OtherClass)  # Explicitly inherit 'foo>' from '+OtherClass'
      
      (do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
      Counted loop with multiple conditional exits: The body is executed at most num times (or never (if the first argument is NIL), or an infinite number of times (if the first argument is T)). If a clause has NIL or T as its CAR, the clause's second element is evaluated as a condition and - if the result is NIL or non-NIL, respectively - the prg is executed and the result returned. Otherwise (if count drops to zero), the result of the last expression is returned. See also loop and for.
      
      : (do 4 (printsp 'OK))
      OK OK OK OK -> OK
      : (do 4 (printsp 'OK) (T (= 3 3) (printsp 'done)))
      OK done -> done
      
      (doc ['sym1] ['sym2])
      (Debug mode only) Opens a browser, and tries to display the reference documentation for sym1. sym2 may be the name of a browser. If not given, the value of the environment variable BROWSER, or the w3m browser is tried. If sym1 is NIL, the PicoLisp Reference manual is opened. See also Function Reference and vi.
      
      : (doc '+)  # Function reference
      -> T
      : (doc '+relation)  # Class reference
      -> T
      : (doc)  # Reference manual
      -> T
      :  (doc 'vi "firefox")  # Use alternative browser
      -> T
      
      picolisp-3.1.5.2.orig/doc/refE.html0000644000000000000000000004542012265263724015471 0ustar rootroot E

      E

      *Err
      A global variable holding a (possibly empty) prg body, which will be executed during error processing. See also Error Handling, *Msg and ^.
      
      : (de *Err (prinl "Fatal error!"))
      -> ((prinl "Fatal error!"))
      : (/ 3 0)
      !? (/ 3 0)
      Div/0
      Fatal error!
      $
      
      *Ext
      A global variable holding a sorted list of cons pairs. The CAR of each pair specifies an external symbol offset (suitable for ext), and the CDR should be a function taking a single external symbol as an argument. This function should return a list, with the value for that symbol in its CAR, and the property list (in the format used by getl and putl) in its CDR. The symbol will be set to this value and property list upon access. Typically this function will access the corresponding symbol in a remote database process. See also qsym and external symbols.
      
      ### On the local machine ###
      : (setq *Ext  # Define extension functions
         (mapcar
            '((@Host @Ext)
               (cons @Ext
                  (curry (@Host @Ext (Sock)) (Obj)
                     (when (or Sock (setq Sock (connect @Host 4040)))
                        (ext @Ext
                           (out Sock (pr (cons 'qsym Obj)))
                           (prog1 (in Sock (rd))
                              (unless @
                                 (close Sock)
                                 (off Sock) ) ) ) ) ) ) )
            '("10.10.12.1" "10.10.12.2" "10.10.12.3" "10.10.12.4")
            (20 40 60 80) ) )
      
      ### On the remote machines ###
      (de go ()
         ...
         (task (port 4040)                      # Set up background query server
            (let? Sock (accept @)               # Accept a connection
               (unless (fork)                   # In child process
                  (in Sock
                     (while (rd)                # Handle requests
                        (sync)
                        (out Sock
                           (pr (eval @)) ) ) )
                  (bye) )                       # Exit child process
               (close Sock) ) )
         (forked)                               # Close task in children
         ...
      
      
      +Entity
      Base class of all database objects. See also +relation and Database.

      Messages to entity objects include

      
      zap> ()              # Clean up relational structures, for removal from the DB
      url> (Tab)           # Call the GUI on that object (in optional Tab)
      upd> (X Old)         # Callback method when object is created/modified/deleted
      has> (Var Val)       # Check if value is present
      put> (Var Val)       # Put a new value
      put!> (Var Val)      # Put a new value, single transaction
      del> (Var Val)       # Delete value (also partial)
      del!> (Var Val)      # Delete value (also partial), single transaction
      inc> (Var Val)       # Increment numeric value
      inc!> (Var Val)      # Increment numeric value, single transaction
      dec> (Var Val)       # Decrement numeric value
      dec!> (Var Val)      # Decrement numeric value, single transaction
      mis> (Var Val)       # Return error message if value or type mismatch
      lose1> (Var)         # Delete relational structures for a single attribute
      lose> (Lst)          # Delete relational structures (excluding 'Lst')
      lose!> ()            # Delete relational structures, single transaction
      keep1> (Var)         # Restore relational structures for single attribute
      keep> (Lst)          # Restore relational structures (excluding 'Lst')
      keep?> (Lst)         # Test for restauration (excluding 'Lst')
      keep!> ()            # Restore relational structures, single transaction
      set> (Val)           # Set the value (type, i.e. class list)
      set!> (Val)          # Set the value, single transaction
      clone> ()            # Object copy
      clone!> ()           # Object copy, single transaction
      
      (e . prg) -> any
      Used in a breakpoint. Evaluates prg in the execution environment, or the currently executed expression if prg is not given. See also debug, !, ^ and *Dbg.
      
      : (! + 3 4)
      (+ 3 4)
      ! (e)
      -> 7
      
      (echo ['cnt ['cnt]] | ['sym ..]) -> sym
      Reads the current input channel, and writes to the current output channel. If cnt is given, only that many bytes are actually echoed. In case of two cnt arguments, the first one specifies the number of bytes to skip in the input stream. Otherwise, if one or more sym arguments are given, the echo process stops as soon as one of the symbol's names is encountered in the input stream. In this case the name will be read and returned, but not written. Returns non-NIL if the operation was successfully completed. See also from.
      
      : (in "x.l" (echo))  # Display file on console
       ..
      
      : (out "x2.l" (in "x.l" (echo)))  # Copy file "x.l" to "x2.l"
      
      (edit 'sym ..) -> NIL
      (Debug mode only) Edits the value and property list of the argument symbol(s) by calling the vim editor on a temporary file with these data. When closing the editor, the modified data are read and stored into the symbol(s). During the edit session, individual symbols are separated by the pattern (********). These separators should not be modified. When moving the cursor to the beginning of a symbol (no matter if internal, transient or external), and hitting 'K', that symbol is added to the currently edited symbols. Hitting 'Q' will go back one step and return to the previously edited list of symbols.

      edit is especially useful for browsing through the database (with 'K' and 'Q'), inspecting external symbols, but care must be taken when modifying any data as then the entity/relation mechanisms are circumvented, and commit has to be called manually if the changes should be persistent.

      Another typical use case is inserting or removing ! breakpoints at arbitrary code locations, or doing other temporary changes to the code for debugging purposes.

      See also update, show, vi and em.

      
      : (edit (db 'nr '+Item 1))  # Edit a database symbol
      ### 'vim' shows this ###
      {3-1} (+Item)
         nr 1
         inv 100
         pr 29900
         sup {2-1}  # (+CuSu)
         nm "Main Part"
      
      (********)
      ### Hitting 'K' on the '{' of '{2-1} ###
      {2-1} (+CuSu)
         nr 1
         plz "3425"
         mob "37 176 86303"
         tel "37 4967 6846-0"
         fax "37 4967 68462"
         nm "Active Parts Inc."
         nm2 "East Division"
         ort "Freetown"
         str "Wildcat Lane"
         em "info@api.tld"
      
      (********)
      
      {3-1} (+Item)
         nr 1
         inv 100
         pr 29900
         sup {2-1}  # (+CuSu)
         nm "Main Part"
      
      (********)
      ### Entering ':q' in vim ###
      -> NIL
      
      (em 'sym) -> sym
      (em 'sym 'cls) -> sym
      (em '(sym . cls)) -> sym
      (em) -> NIL
      (Debug mode only) Opens the "emacs" editor on the function or method definition of sym. A call to ld thereafter will load the modified file. A call without arguments permanently switches the REPL line editor and the edit function to "emacs" mode. See also doc, edit, vi, *Dbg, debug and pp.
      
      : (em 'url> '+CuSu)  # Edit the method's source code, then exit from 'emacs'
      -> T
      
      (env ['lst] | ['sym 'val] ..) -> lst
      Return a list of symbol-value pairs of all dynamically bound symbols if called without arguments, or of the symbols or symbol-value pairs in lst, or the explicitly given sym-val arguments. See also bind, job, trail and up.
      
      : (env)
      -> NIL
      : (let (A 1 B 2) (env))
      -> ((A . 1) (B . 2))
      : (let (A 1 B 2) (env '(A B)))
      -> ((B . 2) (A . 1))
      : (let (A 1 B 2) (env 'X 7 '(A B (C . 3)) 'Y 8))
      -> ((Y . 8) (C . 3) (B . 2) (A . 1) (X . 7))
      
      (eof ['flg]) -> flg
      Returns the end-of-file status of the current input channel. If flg is non-NIL, the channel's status is forced to end-of-file, so that the next call to eof will return T, and calls to char, peek, line, from, till, read or skip will return NIL. Note that eof cannot be used with the binary rd function. See also eol.
      
      : (in "file" (until (eof) (println (line T))))
      ...
      
      (eol) -> flg
      Returns the end-of-line status of the current input channel. See also eof.
      
      : (make (until (prog (link (read)) (eol))))  # Read line into a list
      a b c (d e f) 123
      -> (a b c (d e f) 123)
      
      equal/2
      Pilog predicate that succeeds if the two arguments are equal. See also =, different/2 and member/2.
      
      : (? (equal 3 4))
      -> NIL
      : (? (equal @N 7))
       @N=7
      -> NIL
      
      (err 'sym . prg) -> any
      Redirects the standard error stream to sym during the execution of prg. The current standard error stream will be saved and restored appropriately. If the argument is NIL, the current output stream will be used. Otherwise, sym is taken as a file name (opened in "append" mode if the first character is "+"), where standard error is to be written to. See also in, out and ctl.
      
      : (err "/dev/null"             # Suppress error messages
         (call 'ls 'noSuchFile) )
      -> NIL
      
      (errno) -> cnt
      (64-bit version only) Returns the value of the standard I/O 'errno' variable. See also native.
      
      : (in "foo")                           # Produce an error
      !? (in "foo")
      "foo" -- Open error: No such file or directory
      ? (errno)
      -> 2                                   # Returned 'ENOENT'
      
      (eval 'any ['cnt ['lst]]) -> any
      Evaluates any. Note that because of the standard argument evaluation, any is actually evaluated twice. If a binding environment offset cnt is given, the second evaluation takes place in the corresponding environment, and an optional lst of excluded symbols can be supplied. See also run and up.
      
      : (eval (list '+ 1 2 3))
      -> 6
      : (setq X 'Y  Y 7)
      -> 7
      : X
      -> Y
      : Y
      -> 7
      : (eval X)
      -> 7
      
      (expDat 'sym) -> dat
      Expands a date string according to the current locale (delimiter, and order of year, month and day). Accepts abbreviated input, without delimiter and with only the day, or the day and month, or the day, month and year of current century. See also datStr, day, expTel.
      
      : (date)
      -> 733133
      : (date (date))
      -> (2007 5 31)
      : (expDat "31")
      -> 733133
      : (expDat "315")
      -> 733133
      : (expDat "3105")
      -> 733133
      : (expDat "31057")
      -> 733133
      : (expDat "310507")
      -> 733133
      : (expDat "2007-05-31")
      -> 733133
      : (expDat "7-5-31")
      -> 733133
      
      : (locale "DE" "de")
      -> NIL
      : (expDat "31.5")
      -> 733133
      : (expDat "31.5.7")
      -> 733133
      
      (expTel 'sym) -> sym
      Expands a telephone number string. Multiple spaces or hyphens are coalesced. A leading + or 00 is removed, a leading 0 is replaced with the current country code. Otherwise, NIL is returned. See also telStr, expDat and locale.
      
      : (expTel "+49 1234 5678-0")
      -> "49 1234 5678-0"
      : (expTel "0049 1234 5678-0")
      -> "49 1234 5678-0"
      : (expTel "01234 5678-0")
      -> NIL
      : (locale "DE" "de")
      -> NIL
      : (expTel "01234 5678-0")
      -> "49 1234 5678-0"
      
      (expr 'sym) -> fun
      Converts a C-function ("subr") to a Lisp-function. Useful only for normal functions (i.e. functions that evaluate all arguments). See also subr.
      
      : car
      -> 67313448
      : (expr 'car)
      -> (@ (pass $385260187))
      : (car (1 2 3))
      -> 1
      
      (ext 'cnt . prg) -> any
      During the execution of prg, all external symbols processed by rd, pr or udp are modified by an offset cnt suitable for mapping via the *Ext mechanism. All external symbol's file numbers are decremented by cnt during output, and incremented by cnt during input.
      
      : (out 'a (ext 5 (pr '({6-2} ({8-9} . a) ({7-7} . b)))))
      -> ({6-2} ({8-9} . a) ({7-7} . b))
      
      : (in 'a (rd))
      -> ({2} ({3-9} . a) ({2-7} . b))
      
      : (in 'a (ext 5 (rd)))
      -> ({6-2} ({8-9} . a) ({7-7} . b))
      
      (ext? 'any) -> sym | NIL
      Returns the argument any when it is an existing external symbol, otherwise NIL. See also sym?, box?, str?, extern and lieu.
      
      : (ext? *DB)
      -> {1}
      : (ext? 'abc)
      -> NIL
      : (ext? "abc")
      -> NIL
      : (ext? 123)
      -> NIL
      
      (extend cls) -> cls
      Extends the class cls, by storing it in the global variable *Class. As a consequence, all following method, relation and class variable definitions are applied to that class. See also OO Concepts, class, dm, var, rel, type and isa.
      
      
      (extern 'sym) -> sym | NIL
      Creates or finds an external symbol. If a symbol with the name sym is already extern, it is returned. Otherwise, a new external symbol is returned. NIL is returned if sym does not exist in the database. See also intern and ext?.
      
      : (extern "A1b")
      -> {A1b}
      : (extern "{A1b}")
      -> {A1b}
      
      (extra ['any ..]) -> any
      Can only be used inside methods. Sends the current message to the current object This, this time starting the search for a method at the remaining branches of the inheritance tree of the class where the current method was found. See also OO Concepts, super, method, meth, send and try.
      
      (dm key> (C)            # 'key>' method of the '+Uppc' class
         (uppc (extra C)) )   # Convert 'key>' of extra classes to upper case
      
      (extract 'fun 'lst ..) -> lst
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns a list of all non-NIL values returned by fun. (extract 'fun 'lst) is equivalent to (mapcar 'fun (filter 'fun 'lst)) or, for non-NIL results, to (mapcan '((X) (and (fun X) (cons @))) 'lst). See also filter, find, pick and mapcan.
      
      : (setq A NIL  B 1  C NIL  D 2  E NIL  F 3)
      -> 3
      : (filter val '(A B C D E F))
      -> (B D F)
      : (extract val '(A B C D E F))
      -> (1 2 3)
      
      picolisp-3.1.5.2.orig/doc/refF.html0000644000000000000000000004533012265263724015472 0ustar rootroot F

      F

      *Fork
      A global variable holding a (possibly empty) prg body, to be executed after a call to fork in the child process.
      
      : (push '*Fork '(off *Tmp))   # Clear '*Tmp' in child process
      -> (off *Tmp)
      
      +Fold
      Prefix class for maintaining folded indexes to +String relations. Typically used in combination with the +Ref or +Idx prefix classes. See also +IdxFold and Database.
      
      (rel nm (+Fold +Idx +String))   # Item Description
      ...
      (rel tel (+Fold +Ref +String))  # Phone number
      
      (fail) -> lst
      Constructs an empty Pilog query, i.e. a query that will aways fail. See also goal.
      
      (dm clr> ()                # Clear query chart in search dialogs
         (query> This (fail)) )
      
      fail/0
      Pilog predicate that always fails. See also true/0.
      
      : (? (fail))
      -> NIL
      
      (fetch 'tree 'any) -> any
      Fetches a value for the key any from a database tree. See also tree and store.
      
      : (fetch (tree 'nr '+Item) 2)
      -> {3-2}
      
      (fifo 'var ['any ..]) -> any
      Implements a first-in-first-out structure using a circular list. When called with any arguments, they will be concatenated to end of the structure. Otherwise, the first element is removed from the structure and returned. See also queue, push, pop, rot and circ.
      
      : (fifo 'X 1)
      -> 1
      : (fifo 'X 2 3)
      -> 3
      : X
      -> (3 1 2 .)
      : (fifo 'X)
      -> 1
      : (fifo 'X)
      -> 2
      : X
      -> (3 .)
      
      (file) -> (sym1 sym2 . num) | NIL
      Returns for the current input channel the path name sym1, the file name sym2, and the current line number num. If the current input channel is not a file, NIL is returned. See also info, in and load.
      
      : (load (pack (car (file)) "localFile.l"))  # Load a file in same directory
      
      (fill 'any ['sym|lst]) -> any
      Non-destructively fills a pattern any, by substituting sym, or all symbols in lst, or - if no second argument is given - each pattern symbol in any (see pat?), with its current value. @ itself is not considered a pattern symbol here. Unmodified subexpressions are shared. In any case, expressions following the symbol ^ should evaluate to lists which are then (destructively) spliced into the result. See also match.
      
      : (setq  @X 1234  @Y (1 2 3 4))
      -> (1 2 3 4)
      : (fill '@X)
      -> 1234
      : (fill '(a b (c @X) ((@Y . d) e)))
      -> (a b (c 1234) (((1 2 3 4) . d) e))
      : (let X 2 (fill (1 X 3) 'X))
      -> (1 2 3)
      
      : (fill (1 ^ (list 'a 'b 'c) 9))
      -> (1 a b c 9)
      
      : (match '(This is @X) '(This is a pen))
      -> T
      : (fill '(Got ^ @X))
      -> (Got a pen)
      
      (filter 'fun 'lst ..) -> lst
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns a list of all elements of lst where fun returned non-NIL. See also fish, find, pick and extract.
      
      : (filter num? (1 A 2 (B) 3 CDE))
      -> (1 2 3)
      
      (fin 'any) -> num|sym
      Returns any if it is an atom, otherwise the CDR of its last cell. See also last and tail.
      
      : (fin 'a)
      -> a
      : (fin '(a . b))
      -> b
      : (fin '(a b . c))
      -> c
      : (fin '(a b c))
      -> NIL
      
      (finally exe . prg) -> any
      prg is executed, then exe is evaluated, and the result of prg is returned. exe will also be evaluated if prg does not terminate normally due to a runtime error or a call to throw. See also bye, catch, quit and Error Handling.
      
      : (finally (prinl "Done!")
         (println 123)
         (quit)
         (println 456) )
      123
      Done!
      : (catch 'A
         (finally (prinl "Done!")
            (println 1)
            (throw 'A 123)
            (println 2) ) )
      1
      Done!
      -> 123
      
      (find 'fun 'lst ..) -> any
      Applies fun to successive elements of lst until non-NIL is returned. Returns that element, or NIL if fun did not return non-NIL for any element of lst. When additional lst arguments are given, their elements are also passed to fun. See also seek, pick and filter.
      
      : (find pair (1 A 2 (B) 3 CDE))
      -> (B)
      : (find '((A B) (> A B)) (1 2 3 4 5 6) (6 5 4 3 2 1))
      -> 4
      : (find > (1 2 3 4 5 6) (6 5 4 3 2 1))  # shorter
      -> 4
      
      (fish 'fun 'any) -> lst
      Applies fun to each element - and recursively to all sublists - of any. Returns a list of all items where fun returned non-NIL. See also filter.
      
      : (fish gt0 '(a -2 (1 b (-3 c 2)) 3 d -1))
      -> (1 2 3)
      : (fish sym? '(a -2 (1 b (-3 c 2)) 3 d -1))
      -> (a b c d)
      
      (flg? 'any) -> flg
      Returns T when the argument any is either NIL or T. See also bool. (flg? X) is equivalent to (or (not X) (=T X)).
      
      : (flg? (= 3 3))
      -> T
      : (flg? (= 3 4))
      -> T
      : (flg? (+ 3 4))
      -> NIL
      
      (flip 'lst ['cnt]) -> lst
      Returns lst (destructively) reversed. Without the optional cnt argument, the whole list is flipped, otherwise only the first cnt elements. See also reverse and rot.
      
      : (flip (1 2 3 4))         # Flip all  four elements
      -> (4 3 2 1)
      : (flip (1 2 3 4 5 6) 3)   # Flip only the first three elements
      -> (3 2 1 4 5 6)
      
      (flush) -> flg
      Flushes the current output stream by writing all buffered data. A call to flush for standard output is done automatically before a call to key. Returns T when successful. See also rewind.
      
      : (flush)
      -> T
      
      (fmt64 'num) -> sym
      (fmt64 'sym) -> num
      Converts a number num to a string in base-64 notation, or a base-64 formatted string to a number. The digits are represented with the characters 0 - 9, :, ;, A - Z and a - z. This format is used internally for the names of external symbols in the 32-bit version. See also hax, hex, bin and oct.
      
      : (fmt64 9)
      -> "9"
      : (fmt64 10)
      -> ":"
      : (fmt64 11)
      -> ";"
      : (fmt64 12)
      -> "A"
      : (fmt64 "100")
      -> 4096
      
      (fold 'any ['cnt]) -> sym
      Folding to a canonical form: If any is not a symbol, it is returned as it is. Otherwise, a new transient symbol with all digits and all letters of any, converted to lower case, is returned. If the cnt argument is given and non-zero, the result is truncated to that length. See also lowc.
      
      : (fold " 1A 2-b/3")
      -> "1a2b3"
      : (fold " 1A 2-B/3" 3)
      -> "1a2"
      
      fold/3
      Pilog predicate that succeeds if the first argument, after folding it to a canonical form, is a prefix of the folded string representation of the result of applying the get algorithm to the following arguments. Typically used as filter predicate in select/3 database queries. See also pre?, isa/2, same/3, bool/3, range/3, head/3, part/3 and tolr/3.
      
      : (?
         @Nr (1 . 5)
         @Nm "main"
         (select (@Item)
            ((nr +Item @Nr) (nm +Item @Nm))
            (range @Nr @Item nr)
            (fold @Nm @Item nm) ) )
       @Nr=(1 . 5) @Nm="main" @Item={3-1}
      -> NIL
      
      (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
      (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
      (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
      Conditional loop with local variable(s) and multiple conditional exits:
      In the first form, the value of sym is saved, sym is bound to 1, and the body is executed with increasing values up to (and including) num.
      In the second form, the value of sym is saved, sym is subsequently bound to the elements of lst, and the body is executed each time.
      In the third form, the value of sym is saved, and sym is bound to any1. If sym2 is given, it is treated as a counter variable, first bound to 1 and then incremented for each execution of the body. While the condition any2 evaluates to non-NIL, the body is repeatedly executed and, if prg is given, sym is re-bound to the result of its evaluation.
      If a clause has NIL or T as its CAR, the clause's second element is evaluated as a condition and - if the result is NIL or non-NIL, respectively - the prg is executed and the result returned. If the body is never executed, NIL is returned.
      See also do and loop.
      
      # First form:
      : (for N 5 (printsp N))
      1 2 3 4 5 -> 5
      : (for N 5 (printsp N) (NIL (< N 3) (printsp 'enough)))
      1 2 3 enough -> enough
      : (for N 5 (T (> N 3) (printsp 'enough)) (printsp N))
      1 2 3 enough -> enough
      
      # Second form:
      : (for X (1 a 2 b) (printsp X))
      1 a 2 b -> b
      : (for (I . X) '(a b c) (println I X))
      1 a
      2 b
      3 c
      -> c
      
      # Third form:
      : (for (L (1 2 3 4 5) L) (printsp (pop 'L)))
      1 2 3 4 5 -> 5
      : (for (N 1 (>= 5 N) (inc N)) (printsp N))
      1 2 3 4 5 -> 5
      : (for ((I . L) '(a b c d e f) L (cddr L)) (println I L))
      1 (a b c d e f)
      2 (c d e f)
      3 (e f)
      -> (e f)
      
      for/2
      for/3
      for/4
      Pilog predicate that generates a sequence of numbers. See also for and range.
      
      : (? (for @I 3))
       @I=1
       @I=2
       @I=3
      -> NIL
      
      : (? (for @I 3 7))
       @I=3
       @I=4
       @I=5
       @I=6
       @I=7
      -> NIL
      
      : (? (for @I 7 3 2))
       @I=7
       @I=5
       @I=3
      -> NIL
      
      (fork) -> pid | NIL
      Forks a child process. Returns NIL in the child, and the child's process ID pid in the parent. In the child, the VAL of the global variable *Fork (should be a prg) is executed. See also pipe and tell.
      
      : (unless (fork) (do 5 (println 'OK) (wait 1000)) (bye))
      -> NIL
      OK                                              # Child's output
      : OK
      OK
      OK
      OK
      
      (forked)
      Installs maintenance code in *Fork to close server sockets and clean up *Run code in child processes. Should only be called immediately after task.
      
      : (task -60000 60000 (msg 'OK))     # Install timer task
      -> (-60000 60000 (msg 'OK))
      : (forked)                          # No timer in child processes
      -> (task -60000)
      : *Run
      -> ((-60000 56432 (msg 'OK)))
      : *Fork
      -> ((task -60000) (del '(saveHistory) '*Bye))
      
      (format 'num ['cnt ['sym1 ['sym2]]]) -> sym
      (format 'sym|lst ['cnt ['sym1 ['sym2]]]) -> num
      Converts a number num to a string, or a string sym|lst to a number. In both cases, optionally a precision cnt, a decimal-separator sym1 and a thousands-separator sym2 can be supplied. Returns NIL if the conversion is unsuccessful. See also Numbers and round.
      
      : (format 123456789)                   # Integer conversion
      -> "123456789"
      : (format 123456789 2)                 # Fixed point
      -> "1234567.89"
      : (format 123456789 2 ",")             # Comma as decimal-separator
      -> "1234567,89"
      : (format 123456789 2 "," ".")         # and period as thousands-separator
      -> "1.234.567,89"
      
      : (format "123456789")                 # String to number
      -> 123456789
      : (format (1 "23" (4 5 6)))
      -> 123456
      : (format "1234567.89" 4)              # scaled to four digits
      -> 12345678900
      : (format "1.234.567,89")              # separators not recognized
      -> NIL
      : (format "1234567,89" 4 ",")
      -> 12345678900
      : (format "1.234.567,89" 4 ",")        # thousands-separator not recognized
      -> NIL
      : (format "1.234.567,89" 4 "," ".")
      -> 12345678900
      
      (free 'cnt) -> (sym . lst)
      Returns, for the cnt'th database file, the next available symbol sym (i.e. the first symbol greater than any symbol in the database), and the list lst of free symbols. See also seq, zap and dbck.
      
      : (pool "x")      # A new database
      -> T
      : (new T)         # Create a new symbol
      -> {2}
      : (new T)         # Create another symbol
      -> {3}
      : (commit)        # Commit changes
      -> T
      : (zap '{2})      # Delete the first symbol
      -> {2}
      : (free 1)        # Show free list
      -> ({4})          # {3} was the last symbol allocated
      : (commit)        # Commit the deletion of {2}
      -> T
      : (free 1)        # Now {2} is in the free list
      -> ({4} {2})
      
      (from 'any ..) -> sym
      Skips the current input channel until one of the strings any is found, and starts subsequent reading from that point. The found any argument, or NIL (if none is found) is returned. See also till and echo.
      
      : (and (from "val='") (till "'" T))
      test val='abc'
      -> "abc"
      
      (full 'any) -> bool
      Returns NIL if any is a non-empty list with at least one NIL element, otherwise T. (full X) is equivalent to (not (memq NIL X)).
      
      : (full (1 2 3))
      -> T
      : (full (1 NIL 3))
      -> NIL
      : (full 123)
      -> T
      
      (fun? 'any) -> any
      Returns NIL when the argument any is neither a number suitable for a code-pointer, nor a list suitable for a lambda expression (function). Otherwise a number is returned for a code-pointer, T for a function without arguments, and a single formal parameter or a list of formal parameters for a function. See also getd.
      
      : (fun? 1000000000)              # Might be a code pointer
      -> 1000000000
      : (fun? 100000000000000)         # Too big for a code pointer
      -> NIL
      : (fun? 1000000001)              # Cannot be a code pointer (odd)
      -> NIL
      : (fun? '((A B) (* A B)))        # Lambda expression
      -> (A B)
      : (fun? '((A B) (* A B) . C))    # Not a lambda expression
      -> NIL
      : (fun? '(1 2 3 4))              # Not a lambda expression
      -> NIL
      : (fun? '((A 2 B) (* A B)))      # Not a lambda expression
      -> NIL
      
      picolisp-3.1.5.2.orig/doc/refG.html0000644000000000000000000001457012265263724015475 0ustar rootroot G

      G

      (gc ['cnt [cnt2]]) -> cnt | NIL
      Forces a garbage collection. When cnt is given, so many megabytes of free cells are reserved, increasing the heap size if necessary. If cnt is zero, all currently unused heap blocks are purged, decreasing the heap size if possible. If cnt2 (64-bit version only) is given, the reserve size (defaults to 1 megabyte) is set to that value. See also heap.
      
      : (gc)
      -> NIL
      : (heap)
      -> 2
      : (gc 4)
      -> 4
      : (heap)
      -> 5
      
      (ge0 'any) -> num | NIL
      Returns num when the argument is a number and greater or equal zero, otherwise NIL. See also lt0, le0, gt0, =0 and n0.
      
      : (ge0 -2)
      -> NIL
      : (ge0 3)
      -> 3
      : (ge0 0)
      -> 0
      
      (genKey 'var 'cls ['hook ['num1 ['num2]]]) -> num
      Generates a key for a database tree. If a minimal key num1 and/or a maximal key num2 is given, the next free number in that range is returned. Otherwise, the current maximal key plus one is returned. See also useKey, genStrKey and maxKey.
      
      : (maxKey (tree 'nr '+Item))
      -> 8
      : (genKey 'nr '+Item)
      -> 9
      
      (genStrKey 'sym 'var 'cls ['hook]) -> sym
      Generates a unique string for a database tree, by prepending as many "# " sequences as necessary. See also genKey.
      
      : (genStrKey "ben" 'nm '+User)
      -> "# ben"
      
      (get 'sym1|lst ['sym2|cnt ..]) -> any
      Fetches a value any from the properties of a symbol, or from a list. From the first argument sym1|lst, values are retrieved in successive steps by either extracting the value (if the next argument is zero) or a property from a symbol, the asoqed element (if the next argument is a symbol), the n'th element (if the next argument is a positive number) or the n'th CDR (if the next argument is a negative number) from a list. See also put, ; and :.
      
      : (put 'X 'a 1)
      -> 1
      : (get 'X 'a)
      -> 1
      : (put 'Y 'link 'X)
      -> X
      : (get 'Y 'link)
      -> X
      : (get 'Y 'link 'a)
      -> 1
      : (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'a 'b)
      -> 1
      : (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'd 'f)
      -> 4
      : (get '(X Y Z) 2)
      -> Y
      : (get '(X Y Z) 2 'link 'a)
      -> 1
      
      (getd 'any) -> fun | NIL
      Returns fun if any is a symbol that has a function definition, otherwise NIL. See also fun?.
      
      : (getd '+)
      -> 67327232
      : (getd 'script)
      -> ((File . @) (load File))
      : (getd 1)
      -> NIL
      
      (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst
      Fetches the complete property list lst from a symbol. That symbol is sym1 (if no other arguments are given), or a symbol found by applying the get algorithm to sym1|lst1 and the following arguments. See also putl and maps.
      
      : (put 'X 'a 1)
      -> 1
      : (put 'X 'b 2)
      -> 2
      : (put 'X 'flg T)
      -> T
      : (getl 'X)
      -> (flg (2 . b) (1 . a))
      
      (glue 'any 'lst) -> sym
      Builds a new transient symbol (string) by packing the any argument between the individual elements of lst. See also text.
      
      : (glue "," '(a b c d))
      -> "a,b,c,d"
      
      (goal '([pat 'any ..] . lst) ['sym 'any ..]) -> lst
      Constructs a Pilog query list from the list of clauses lst. The head of the argument list may consist of a sequence of pattern symbols (Pilog variables) and expressions, which are used together with the optional sym and any arguments to form an initial environment. See also prove and fail.
      
      : (goal '((likes John @X)))
      -> (((1 (0) NIL ((likes John @X)) NIL T)))
      : (goal '(@X 'John (likes @X @Y)))
      -> (((1 (0) NIL ((likes @X @Y)) NIL ((0 . @X) 1 . John) T)))
      
      (group 'lst) -> lst
      Builds a list of lists, by grouping all elements of lst with the same CAR into a common sublist. See also Comparing, by, sort and uniq.
      
      : (group '((1 . a) (1 . b) (1 . c) (2 . d) (2 . e) (2 . f)))
      -> ((1 a b c) (2 d e f))
      : (by name group '("x" "x" "y" "z" "x" "z")))
      -> (("x" "x" "x") ("y") ("z" "z"))
      : (by length group '(123 (1 2) "abcd" "xyz" (1 2 3 4) "XY"))
      -> ((123 "xyz") ((1 2) "XY") ("abcd" (1 2 3 4))
      
      (gt0 'any) -> num | NIL
      Returns num when the argument is a number and greater than zero, otherwise NIL. See also lt0, le0, ge0, =0 and n0.
      
      : (gt0 -2)
      -> NIL
      : (gt0 3)
      -> 3
      
      picolisp-3.1.5.2.orig/doc/refH.html0000644000000000000000000002020212265263724015463 0ustar rootroot H

      H

      *Hup
      Global variable holding a (possibly empty) prg body, which will be executed when a SIGHUP signal is sent to the current process. See also alarm, sigio and *Sig[12].
      
      : (de *Hup (msg 'SIGHUP))
      -> *Hup
      
      +Hook
      Prefix class for +relations, typically +Link or +Joint. In essence, this maintains an local database in the referred object. See also Database.
      
      (rel sup (+Hook +Link) (+Sup))   # Supplier
      (rel nr (+Key +Number) sup)      # Item number, unique per supplier
      (rel dsc (+Ref +String) sup)     # Item description, indexed per supplier
      
      +Hook2
      Prefix class for +index relations. It maintains both a normal (global) index, and an object-local index in the corresponding +Hook object. See also Database.
      
      (rel nm (+Hook2 +IdxFold +String) 3 shop)       # Global and shop-local index
      
      (hash 'any) -> cnt
      Generates a 16-bit number (1-65536) from any, suitable as a hash value for various purposes, like randomly balanced idx structures. See also cache and seed.
      
      : (hash 0)
      -> 1
      : (hash 1)
      -> 55682
      : (hash "abc")
      -> 45454
      
      (hax 'num) -> sym
      (hax 'sym) -> num
      Converts a number num to a string in hexadecimal/alpha notation, or a hexadecimal/alpha formatted string to a number. The digits are represented with '@' (zero) and the letters 'A' - 'O' (from "alpha" to "omega"). This format is used internally for the names of external symbols in the 64-bit version. See also fmt64, hex, bin and oct.
      
      : (hax 7)
      -> "G"
      : (hax 16)
      -> "A@"
      : (hax 255)
      -> "OO"
      : (hax "A")
      -> 1
      
      (hd 'sym ['cnt]) -> NIL
      (Debug mode only) Displays a hexadecimal dump of the file given by sym, limited to cnt lines. See also proc.
      
      :  (hd "lib.l" 4)
      00000000  23 20 32 33 64 65 63 30 39 61 62 75 0A 23 20 28  # 23dec09abu.# (
      00000010  63 29 20 53 6F 66 74 77 61 72 65 20 4C 61 62 2E  c) Software Lab.
      00000020  20 41 6C 65 78 61 6E 64 65 72 20 42 75 72 67 65   Alexander Burge
      00000030  72 0A 0A 28 64 65 20 74 61 73 6B 20 28 4B 65 79  r..(de task (Key
      -> NIL
      
      (head 'cnt|lst 'lst) -> lst
      Returns a new list made of the first cnt elements of lst. If cnt is negative, it is added to the length of lst. If the first argument is a lst, head is a predicate function returning that argument list if it is equal to the head of the second argument, and NIL otherwise. See also tail.
      
      : (head 3 '(a b c d e f))
      -> (a b c)
      : (head 0 '(a b c d e f))
      -> NIL
      : (head 10 '(a b c d e f))
      -> (a b c d e f)
      : (head -2 '(a b c d e f))
      -> (a b c d)
      : (head '(a b c) '(a b c d e f))
      -> (a b c)
      
      head/3
      Pilog predicate that succeeds if the first (string) argument is a prefix of the string representation of the result of applying the get algorithm to the following arguments. Typically used as filter predicate in select/3 database queries. See also pre?, isa/2, same/3, bool/3, range/3, fold/3, part/3 and tolr/3.
      
      : (?
         @Nm "Muller"
         @Tel "37"
         (select (@CuSu)
            ((nm +CuSu @Nm) (tel +CuSu @Tel))
            (tolr @Nm @CuSu nm)
            (head @Tel @CuSu tel) )
         (val @Name @CuSu nm)
         (val @Phone @CuSu tel) )
       @Nm="Muller" @Tel="37" @CuSu={2-3} @Name="Miller" @Phone="37 4773 82534"
      -> NIL
      
      (heap 'flg) -> cnt
      Returns the total size of the cell heap space in megabytes. If flg is non-NIL, the size of the currently free space is returned. See also stack and gc.
      
      : (gc 4)
      -> 4
      : (heap)
      -> 5
      : (heap T)
      -> 4
      
      (hear 'cnt) -> cnt
      Uses the file descriptor cnt as an asynchronous command input channel. Any executable list received via this channel will be executed in the background. As this mechanism is also used for inter-family communication (see tell), hear is usually only called explicitly by a top level parent process.
      
      : (call 'mkfifo "fifo/cmd")
      -> T
      : (hear (open "fifo/cmd"))
      -> 3
      
      (here ['sym]) -> sym
      Echoes the current input stream until sym is encountered, or until end of file. See also echo.
      
      $ cat hello.l
      (html 0 "Hello" "lib.css" NIL
         (<h2> NIL "Hello")
         (here) )
      <p>Hello!</p>
      <p>This is a test.</p>
      
      $ pil @lib/http.l @lib/xhtml.l hello.l
      HTTP/1.0 200 OK
      Server: PicoLisp
      Date: Sun, 03 Jun 2007 11:41:27 GMT
      Cache-Control: max-age=0
      Cache-Control: no-cache
      Content-Type: text/html; charset=utf-8
      
      <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
      <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
      <head>
      <title>Hello</title>
      <link rel="stylesheet" href="http://:/lib.css" type="text/css"/>
      </head>
      <body><h2>Hello</h2>
      <p>Hello!</p>
      <p>This is a test.</p>
      </body>
      </html>
      
      (hex 'num ['num]) -> sym
      (hex 'sym) -> num
      Converts a number num to a hexadecimal string, or a hexadecimal string sym to a number. In the first case, if the second argument is given, the result is separated by spaces into groups of such many digits. See also bin, oct, fmt64, hax and format.
      
      : (hex 273)
      -> "111"
      : (hex "111")
      -> 273
      : (hex 1234567 4)
      -> "12 D687"
      
      (host 'any) -> sym
      Returns the hostname corresponding to the given IP address. See also *Adr.
      
      : (host "80.190.158.9")
      -> "www.leo.org"
      
      picolisp-3.1.5.2.orig/doc/refI.html0000644000000000000000000003657612265263724015511 0ustar rootroot I

      I

      +Idx
      Prefix class for maintaining non-unique full-text indexes to +String relations, a subclass of +Ref. Accepts optional arguments for the minimally indexed substring length (defaults to 3), and a +Hook attribute. Often used in combination with the +Sn soundex index, or the +Fold index prefix classes. See also Database.
      
      (rel nm (+Sn +Idx +String))  # Name
      
      +IdxFold
      Prefix class for maintaining non-unique indexes to subsequent substrings of the folded individual words of +String relations. Accepts optional arguments for the minimally indexed substring length (defaults to 3), and a +Hook attribute. See also +Idx and Database.
      
      (rel nm (+IdxFold +String))            # Item Description
      
      +index
      Abstract base class of all database B-Tree index relations (prefix classes for +relations). The class hierarchy includes +Key, +Ref, +Idx and +IdxFold. See also Database.
      
      (isa '+index Rel)  # Check for an index relation
      
      (id 'num ['num]) -> sym
      (id 'sym [NIL]) -> num
      (id 'sym T) -> (num . num)
      Converts one or two numbers to an external symbol, or an external symbol to a number or a pair of numbers.
      
      : (id 7)
      -> {7}
      : (id 1 2)
      -> {2}
      : (id '{1-2})
      -> 2
      : (id '{1-2} T)
      -> (1 . 2)
      
      (idx 'var 'any 'flg) -> lst
      (idx 'var 'any) -> lst
      (idx 'var) -> lst
      Maintains an index tree in var, and checks for the existence of any. If any is contained in var, the corresponding subtree is returned, otherwise NIL. In the first form, any is destructively inserted into the tree if flg is non-NIL (and any was not already there), or deleted from the tree if flg is NIL. The second form only checks for existence, but does not change the index tree. In the third form (when called with a single var argument) the contents of the tree are returned as a sorted list. If all elements are inserted in sorted order, the tree degenerates into a linear list. See also lup, hash, depth, sort, balance and member.
      
      : (idx 'X 'd T)                              # Insert data
      -> NIL
      : (idx 'X 2 T)
      -> NIL
      : (idx 'X '(a b c) T)
      -> NIL
      : (idx 'X 17 T)
      -> NIL
      : (idx 'X 'A T)
      -> NIL
      : (idx 'X 'd T)
      -> (d (2 NIL 17 NIL A) (a b c))              # 'd' already existed
      : (idx 'X T T)
      -> NIL
      : X                                          # View the index tree
      -> (d (2 NIL 17 NIL A) (a b c) NIL T)
      : (idx 'X 'A)                                # Check for 'A'
      -> (A)
      : (idx 'X 'B)                                # Check for 'B'
      -> NIL
      : (idx 'X)
      -> (2 17 A d (a b c) T)                      # Get list
      : (idx 'X 17 NIL)                            # Delete '17'
      -> (17 NIL A)
      : X
      -> (d (2 NIL A) (a b c) NIL T)               # View it again
      : (idx 'X)
      -> (2 A d (a b c) T)                         # '17' is deleted
      
      (if 'any1 'any2 . prg) -> any
      Conditional execution: If the condition any1 evaluates to non-NIL, any2 is evaluated and returned. Otherwise, prg is executed and the result returned. See also cond, when and if2.
      
      : (if (> 4 3) (println 'OK) (println 'Bad))
      OK
      -> OK
      : (if (> 3 4) (println 'OK) (println 'Bad))
      Bad
      -> Bad
      
      (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any
      Four-way conditional execution for two conditions: If both conditions any1 and any2 evaluate to non-NIL, any3 is evaluated and returned. Otherwise, any4 or any5 is evaluated and returned if any1 or any2 evaluate to non-NIL, respectively. If none of the conditions evaluate to non-NIL, prg is executed and the result returned. See also if and cond.
      
      : (if2 T T 'both 'first 'second 'none)
      -> both
      : (if2 T NIL 'both 'first 'second 'none)
      -> first
      : (if2 NIL T 'both 'first 'second 'none)
      -> second
      : (if2 NIL NIL 'both 'first 'second 'none)
      -> none
      
      (ifn 'any1 'any2 . prg) -> any
      Conditional execution ("If not"): If the condition any1 evaluates to NIL, any2 is evaluated and returned. Otherwise, prg is executed and the result returned.
      
      : (ifn (= 3 4) (println 'OK) (println 'Bad))
      OK
      -> OK
      
      (import . lst) -> NIL
      Wrapper function for intern. Typically used to import symbols from other namespaces, as created by symbols. lst should be a list of symbols. An import conflict error is issued when a symbol with the same name already exists in the current namespace. See also pico and local.
      
      : (import libA~foo libB~bar)
      -> NIL
      
      (in 'any . prg) -> any
      Opens any as input channel during the execution of prg. The current input channel will be saved and restored appropriately. If the argument is NIL, standard input is used. If the argument is a symbol, it is used as a file name (opened for reading and writing if the first character is "+"). If it is a positive number, it is used as the descriptor of an open file. If it is a negative number, the saved input channel such many levels above the current one is used. Otherwise (if it is a list), it is taken as a command with arguments, and a pipe is opened for input. See also ipid, call, load, file, out, err, poll, pipe and ctl.
      
      : (in "a" (list (read) (read) (read)))  # Read three items from file "a"
      -> (123 (a b c) def)
      
      (inc 'num) -> num
      (inc 'var ['num]) -> num
      The first form returns the value of num incremented by 1. The second form increments the VAL of var by 1, or by num. If the first argument is NIL, it is returned immediately. (inc Num) is equivalent to (+ Num 1) and (inc 'Var) is equivalent to (set 'Var (+ Var 1)). See also dec and +.
      
      : (inc 7)
      -> 8
      : (inc -1)
      -> 0
      : (zero N)
      -> 0
      : (inc 'N)
      -> 1
      : (inc 'N 7)
      -> 8
      : N
      -> 8
      
      : (setq L (1 2 3 4))
      -> (1 2 3 4)
      : (inc (cdr L))
      -> 3
      : L
      -> (1 3 3 4)
      
      (inc! 'obj 'sym ['num]) -> num
      Transaction wrapper function for inc. num defaults to 1. Note that for incrementing a property value of an entity typically the inc!> message is used. See also new!, set! and put!.
      
      (inc! Obj 'cnt 0)  # Incrementing a property of a non-entity object
      
      (index 'any 'lst) -> cnt | NIL
      Returns the cnt position of any in lst, or NIL if it is not found. See also offset.
      
      : (index 'c '(a b c d e f))
      -> 3
      : (index '(5 6) '((1 2) (3 4) (5 6) (7 8)))
      -> 3
      
      (info 'any ['flg]) -> (cnt|T dat . tim)
      Returns information about a file with the name any: The current size cnt in bytes, and the modification date and time (UTC). For directories, T is returned instead of the size. If flg is non-NIL and any is the name of a symbolic link, then the link itself is used, not the file that it refers to. See also dir, date, time and lines.
      
      $ ls -l x.l
      -rw-r--r--   1 abu      users         208 Jun 17 08:58 x.l
      $ pil +
      : (info "x.l")
      -> (208 730594 . 32315)
      : (stamp 730594 32315)
      -> "2000-06-17 08:58:35"
      
      (init 'tree ['any1] ['any2]) -> lst
      Initializes a structure for stepping iteratively through a database tree. any1 and any2 may specify a range of keys. If any2 is greater than any1, the traversal will be in opposite direction. See also tree, step, iter and scan.
      
      : (init (tree 'nr '+Item) 3 5)
      -> (((3 . 5) ((3 NIL . {3-3}) (4 NIL . {3-4}) (5 NIL . {3-5}) (6 NIL . {3-6}) (7 NIL . {3-8}))))
      
      (insert 'cnt 'lst 'any) -> lst
      Inserts any into lst at position cnt. This is a non-destructive operation. See also remove, place, append, delete and replace.
      
      : (insert 3 '(a b c d e) 777)
      -> (a b 777 c d e)
      : (insert 1 '(a b c d e) 777)
      -> (777 a b c d e)
      : (insert 9 '(a b c d e) 777)
      -> (a b c d e 777)
      
      (intern 'sym) -> sym
      Creates or finds an internal symbol. If a symbol with the name sym is already intern, it is returned. Otherwise, sym is interned and returned. See also symbols, zap, extern and ====.
      
      : (intern "abc")
      -> abc
      : (intern 'car)
      -> car
      : ((intern (pack "c" "a" "r")) (1 2 3))
      -> 1
      
      (ipid) -> pid | NIL
      Returns the corresponding process ID when the current input channel is reading from a pipe, otherwise NIL. See also opid, in, pipe and load.
      
      : (in '(ls "-l") (println (line T)) (kill (ipid)))
      "total 7364"
      -> T
      
      (isa 'cls|typ 'obj) -> obj | NIL
      Returns obj when it is an object that inherits from cls or type. See also OO Concepts, class, type, new and object.
      
      : (isa '+Address Obj)
      -> {1-17}
      : (isa '(+Male +Person) Obj)
      -> NIL
      
      isa/2
      Pilog predicate that succeeds if the second argument is of the type or class given by the first argument, according to the isa function. Typically used in db/3 or select/3 database queries. See also same/3, bool/3, range/3, head/3, fold/3, part/3 and tolr/3.
      
      : (? (db nm +Person @Prs) (isa +Woman @Prs) (val @Nm @Prs nm))
       @Prs={2-Y} @Nm="Alexandra of Denmark"
       @Prs={2-1I} @Nm="Alice Maud Mary"
       @Prs={2-F} @Nm="Anne"
       @Prs={2-j} @Nm="Augusta Victoria".   # Stop
      
      (iter 'tree ['fun] ['any1] ['any2] ['flg])
      Iterates through a database tree by applying fun to all values. fun defaults to println. any1 and any2 may specify a range of keys. If any2 is greater than any1, the traversal will be in opposite direction. Note that the keys need not to be atomic, depending on the application's index structure. If flg is non-NIL, partial keys are skipped. See also tree, ubIter, scan, init and step.
      
      : (iter (tree 'nr '+Item))
      {3-1}
      {3-2}
      {3-3}
      {3-4}
      {3-5}
      {3-6}
      {3-8}
      -> {7-1}
      : (iter (tree 'nr '+Item) '((This) (println (: nm))))
      "Main Part"
      "Spare Part"
      "Auxiliary Construction"
      "Enhancement Additive"
      "Metal Fittings"
      "Gadget Appliance"
      "Testartikel"
      -> {7-1}
      
      picolisp-3.1.5.2.orig/doc/refJ.html0000644000000000000000000000502112265263724015467 0ustar rootroot J

      J

      +Joint
      Class for bidirectional object relations, a subclass of +Link. Expects a (symbolic) attribute, and list of classes as type of the referred database object (of class +Entity). A +Joint corresponds to two +Links, where the attribute argument is the relation of the back-link in the referred object. See also Database.
      
      (class +Ord +Entity)                   # Order class
      (rel pos (+List +Joint) ord (+Pos))    # List of positions in that order
      ...
      (class +Pos +Entity)    # Position class
      (rel ord (+Joint)       # Back-link to the parent order
      
      (job 'lst . prg) -> any
      Executes a job within its own environment (as specified by symbol-value pairs in lst). The current values of all symbols are saved, the symbols are bound to the values in lst, prg is executed, then the (possibly modified) symbol values are (destructively) stored in the environment list, and the symbols are restored to their original values. The return value is the result of prg. Typically used in curried functions and *Run tasks. See also env, bind, let, use and state.
      
      : (de tst ()
         (job '((A . 0) (B . 0))
            (println (inc 'A) (inc 'B 2)) ) )
      -> tst
      : (tst)
      1 2
      -> 2
      : (tst)
      2 4
      -> 4
      : (tst)
      3 6
      -> 6
      : (pp 'tst)
      (de tst NIL
         (job '((A . 3) (B . 6))
            (println (inc 'A) (inc 'B 2)) ) )
      -> tst
      
      (journal 'any ..) -> T
      Reads journal data from the files with the names any, and writes all changes to the database. See also pool.
      
      : (journal "db.log")
      -> T
      
      picolisp-3.1.5.2.orig/doc/refK.html0000644000000000000000000000406112265263724015473 0ustar rootroot K

      K

      +Key
      Prefix class for maintaining unique indexes to +relations, a subclass of +index. Accepts an optional argument for a +Hook attribute. See also Database.
      
      (rel nr (+Need +Key +Number))  # Mandatory, unique Customer/Supplier number
      
      (key ['cnt]) -> sym
      Returns the next character from standard input as a single-character transient symbol. The console is set to raw mode. While waiting for a key press, a select system call is executed for all file descriptors and timers in the VAL of the global variable *Run. If cnt is non-NIL, that amount of milliseconds is waited maximally, and NIL is returned upon timeout. See also raw and wait.
      
      : (key)           # Wait for a key
      -> "a"            # 'a' pressed
      
      (kill 'pid ['cnt]) -> flg
      Sends a signal with the signal number cnt (or SIGTERM if cnt is not given) to the process with the ID pid. Returns T if successful.
      
      : (kill *Pid 20)                                # Stop current process
      
      [2]+  Stopped               pil +               # Unix shell
      $ fg                                            # Job control: Foreground
      pil +
      -> T                                            # 'kill' was successful
      
      picolisp-3.1.5.2.orig/doc/refL.html0000644000000000000000000005112612265263724015500 0ustar rootroot L

      L

      *Led
      (Debug mode only) A global variable holding a (possibly empty) prg body that implements a "Line editor". When non-NIL, it should return a single symbol (string) upon execution.
      
      : (de *Led "(bye)")
      # *Led redefined
      -> *Led
      : $                                    # Exit
      
      +Link
      Class for object relations, a subclass of +relation. Expects a list of classes as type of the referred database object (of class +Entity). See also Database.
      
      (rel sup (+Ref +Link) NIL (+CuSu))  # Supplier (class Customer/Supplier)
      
      +List
      Prefix class for a list of identical relations. Objects of that class maintain a list of Lisp data of uniform type. See also Database.
      
      (rel pos (+List +Joint) ord (+Pos))  # Positions
      (rel nm (+List +Ref +String))        # List of indexed strings
      (rel val (+Ref +List +Number))       # Indexed list of numeric values
      
      (last 'lst) -> any
      Returns the last element of lst. See also fin and tail.
      
      : (last (1 2 3 4))
      -> 4
      : (last '((a b) c (d e f)))
      -> (d e f)
      
      (later 'var . prg) -> var
      Executes prg in a pipe'ed child process. The return value of prg will later be available in var.
      
      : (prog1  # Parallel background calculation of square numbers
         (mapcan '((N) (later (cons) (* N N))) (1 2 3 4))
         (wait NIL (full @)) )
      -> (1 4 9 16)
      
      (ld) -> any
      (Debug mode only) loads the last file edited with vi or em.
      
      : (vi 'main)
      -> T
      : (ld)
      # main redefined
      -> go
      
      (le0 'any) -> num | NIL
      Returns num when the argument is a number less or equal zero, otherwise NIL. See also lt0, ge0, gt0, =0 and n0.
      
      : (le0 -2)
      -> -2
      : (le0 0)
      -> 0
      : (le0 3)
      -> NIL
      
      (leaf 'tree) -> any
      Returns the first leaf (i.e. the value of the smallest key) in a database tree. See also tree, minKey, maxKey and step.
      
      : (leaf (tree 'nr '+Item))
      -> {3-1}
      : (db 'nr '+Item (minKey (tree 'nr '+Item)))
      -> {3-1}
      
      (length 'any) -> cnt | T
      Returns the "length" of any. For numbers this is the number of decimal digits in the value (plus 1 for negative values), for symbols it is the number of characters in the name, and for lists it is the number of cells (or T for circular lists). See also size and bytes.
      
      : (length "abc")
      -> 3
      : (length "äbc")
      -> 3
      : (length 123)
      -> 3
      : (length (1 (2) 3))
      -> 3
      : (length (1 2 3 .))
      -> T
      
      (let sym 'any . prg) -> any
      (let (sym 'any ..) . prg) -> any
      Defines local variables. The value of the symbol sym - or the values of the symbols sym in the list of the second form - are saved and the symbols are bound to the evaluated any arguments. prg is executed, then the symbols are restored to their original values. The result of prg is returned. It is an error condition to pass NIL as a sym argument. See also let?, bind, recur, with, for, job and use.
      
      : (setq  X 123  Y 456)
      -> 456
      : (let X "Hello" (println X))
      "Hello"
      -> "Hello"
      : (let (X "Hello" Y "world") (prinl X " " Y))
      Hello world
      -> "world"
      : X
      -> 123
      : Y
      -> 456
      
      (let? sym 'any . prg) -> any
      Conditional local variable binding and execution: If any evalutes to NIL, NIL is returned. Otherwise, the value of the symbol sym is saved and sym is bound to the evaluated any argument. prg is executed, then sym is restored to its original value. The result of prg is returned. It is an error condition to pass NIL as the sym argument. (let? sym 'any ..) is equivalent to (when 'any (let sym @ ..)). See also let, bind, job and use.
      
      : (setq Lst (1 NIL 2 NIL 3))
      -> (1 NIL 2 NIL 3)
      : (let? A (pop 'Lst) (println 'A A))
      A 1
      -> 1
      : (let? A (pop 'Lst) (println 'A A))
      -> NIL
      
      (lieu 'any) -> sym | NIL
      Returns the argument any when it is an external symbol and currently manifest in heap space, otherwise NIL. See also ext?.
      
      : (lieu *DB)
      -> {1}
      
      (line 'flg ['cnt ..]) -> lst|sym
      Reads a line of characters from the current input channel. End of line is recognized as linefeed (hex "0A"), carriage return (hex "0D"), or the combination of both. (Note that a single carriage return may not work on network connections, because the character look-ahead to distinguish from return+linefeed can block the connection.) If flg is NIL, a list of single-character transient symbols is returned. When cnt arguments are given, subsequent characters of the input line are grouped into sublists, to allow parsing of fixed field length records. If flg is non-NIL, strings are returned instead of single-character lists. NIL is returned upon end of file. See also char, read, till and eof.
      
      : (line)
      abcdefghijkl
      -> ("a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l")
      : (line T)
      abcdefghijkl
      -> "abcdefghijkl"
      : (line NIL 1 2 3)
      abcdefghijkl
      -> (("a") ("b" "c") ("d" "e" "f") "g" "h" "i" "j" "k" "l")
      : (line T 1 2 3)
      abcdefghijkl
      -> ("a" "bc" "def" "g" "h" "i" "j" "k" "l")
      
      (lines 'any ..) -> cnt
      Returns the sum of the number of lines in the files with the names any, or NIL if none was found. See also info.
      
      : (lines "x.l")
      -> 11
      
      (link 'any ..) -> any
      Links one or several new elements any to the end of the list in the current make environment. This operation is efficient also for long lists, because a pointer to the last element of the list is maintained. link returns the last linked argument. See also yoke, chain and made.
      
      : (make
         (println (link 1))
         (println (link 2 3)) )
      1
      3
      -> (1 2 3)
      
      (lint 'sym) -> lst
      (lint 'sym 'cls) -> lst
      (lint '(sym . cls)) -> lst
      (Debug mode only) Checks the function definition or file contents (in the first form), or the method body of sym (second and third form), for possible pitfalls. Returns an association list of diagnoses, where var indicates improper variables, dup duplicate parameters, def an undefined function, bnd an unbound variable, and use unused variables. See also noLint, lintAll, debug, trace and *Dbg.
      
      : (de foo (R S T R)     # 'T' is a improper parameter, 'R' is duplicated
         (let N 7             # 'N' is unused
            (bar X Y) ) )     # 'bar' is undefined, 'X' and 'Y' are not bound
      -> foo
      : (lint 'foo)
      -> ((var T) (dup R) (def bar) (bnd Y X) (use N))
      
      (lintAll ['sym ..]) -> lst
      (Debug mode only) Applies lint to all internal symbols - and optionally to all files sym - and returns a list of diagnoses. See also noLint.
      
      : (more (lintAll "file1.l" "file2.l"))
      ...
      
      (lisp 'sym ['fun]) -> num
      (64-bit version only) Installs under the tag sym a callback function fun, and returns a pointer num suitable to be passed to a C function via 'native'. If fun is NIL, the corresponding entry is freed. Maximally 24 callback functions can be installed that way. 'fun' should be a function of maximally five numbers, and should return a number. "Numbers" in this context are 64-bit scalars, and may not only represent integers, but also pointers or other encoded data. See also native and struct.
      
      (load "lib/native.l")
      
      (gcc "ltest" NIL
         (cbTest (Fun) cbTest 'N Fun) )
      
      long cbTest(int(*fun)(int,int,int,int,int)) {
         return fun(1,2,3,4,5);
      }
      /**/
      
      : (cbTest
         (lisp 'cbTest
            '((A B C D E)
               (msg (list A B C D E))
               (* A B C D E) ) ) )
      (1 2 3 4 5)
      -> 120
      
      (list 'any ['any ..]) -> lst
      Returns a list of all any arguments. See also cons.
      
      : (list 1 2 3 4)
      -> (1 2 3 4)
      : (list 'a (2 3) "OK")
      -> (a (2 3) "OK")
      
      lst/3
      Pilog predicate that returns subsequent list elements, after applying the get algorithm to that object and the following arguments. Often used in database queries. See also map/3.
      
      : (? (db nr +Ord 1 @Ord) (lst @Pos @Ord pos))
       @Ord={3-7} @Pos={4-1}
       @Ord={3-7} @Pos={4-2}
       @Ord={3-7} @Pos={4-3}
      -> NIL
      
      (lst? 'any) -> flg
      Returns T when the argument any is a (possibly empty) list (NIL or a cons pair). See also pair.
      
      : (lst? NIL)
      -> T
      : (lst? (1 . 2))
      -> T
      : (lst? (1 2 3))
      -> T
      
      (listen 'cnt1 ['cnt2]) -> cnt | NIL
      Listens at a socket descriptor cnt1 (as received by port) for an incoming connection, and returns the new socket descriptor cnt. While waiting for a connection, a select system call is executed for all file descriptors and timers in the VAL of the global variable *Run. If cnt2 is non-NIL, that amount of milliseconds is waited maximally, and NIL is returned upon timeout. The global variable *Adr is set to the IP address of the client. See also accept, connect, *Adr.
      
      : (setq *Socket
         (listen (port 6789) 60000) )  # Listen at port 6789 for max 60 seconds
      -> 4
      : *Adr
      -> "127.0.0.1"
      
      (lit 'any) -> any
      Returns the literal (i.e. quoted) value of any, by consing it with the quote function if necessary.
      
      : (lit T)
      -> T
      : (lit 1)
      -> 1
      : (lit '(1))
      -> (1)
      : (lit '(a))
      -> '(a)
      
      (load 'any ..) -> any
      Loads all any arguments. Normally, the name of each argument is taken as a file to be executed in a read-eval loop. The argument semantics are identical to that of in, with the exception that if an argument is a symbol and its first character is a hyphen '-', then that argument is parsed as an executable list (without the surrounding parentheses). When any is T, all remaining command line arguments are loaded recursively. When any is NIL, standard input is read, a prompt is issued before each read operation, the results are printed to standard output (read-eval-print loop), and load terminates when an empty line is entered. In any case, load terminates upon end of file, or when NIL is read. The index for transient symbols is cleared before and after the load, so that all transient symbols in a file have a local scope. If the namespace was switched (with symbols) while executing a file, it is restored to the previous one. Returns the value of the last evaluated expression. See also script, ipid, call, file, in, out and str.
      
      : (load "lib.l" "-* 1 2 3")
      -> 6
      
      (loc 'sym 'lst) -> sym
      Locates in lst a transient symbol with the same name as sym. Allows to get hold of otherwise inaccessible symbols. See also ====.
      
      : (loc "X" curry)
      -> "X"
      : (== @ "X")
      -> NIL
      
      (local . lst) -> sym
      Wrapper function for zap. Typically used to create namespace-local symbols. lst should be a list of symbols. See also pico, symbols, import and intern.
      
      : (symbols 'myLib 'pico)
      -> pico
      myLib: (local bar foo)
      -> "foo"
      
      myLib: (de foo (A)  # 'foo' is local to 'myLib'
         ...
      myLib: (de bar (B)  # 'bar' is local to 'myLib'
         ...
      
      (locale 'sym1 'sym2 ['sym ..])
      Sets the current locale to that given by the country file sym1 and the language file sym2 (both located in the "loc/" directory), and optional application-specific directories sym. The locale influences the language, and numerical, date and other formats. See also *Uni, datStr, strDat, expDat, day, telStr, expTel and and money.
      
      : (locale "DE" "de" "app/loc/")
      -> "Zip"
      : ,"Yes"
      -> "Ja"
      
      (lock ['sym]) -> cnt | NIL
      Write-locks an external symbol sym (file record locking), or the whole database root file if sym is NIL. Returns NIL if successful, or the ID of the process currently holding the lock. When sym is non-NIL, the lock is released at the next top level call to commit or rollback, otherwise only when another database is opened with pool, or when the process terminates. See also *Solo.
      
      : (lock '{1})        # Lock single object
      -> NIL
      : (lock)             # Lock whole database
      -> NIL
      
      (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
      Endless loop with multiple conditional exits: The body is executed an unlimited number of times. If a clause has NIL or T as its CAR, the clause's second element is evaluated as a condition and - if the result is NIL or non-NIL, respectively - the prg is executed and the result returned. See also do and for.
      
      : (let N 3
         (loop
            (prinl N)
            (T (=0 (dec 'N)) 'done) ) )
      3
      2
      1
      -> done
      
      (low? 'any) -> sym | NIL
      Returns any when the argument is a string (symbol) that starts with a lowercase character. See also lowc and upp?
      
      : (low? "a")
      -> "a"
      : (low? "A")
      -> NIL
      : (low? 123)
      -> NIL
      : (low? ".")
      -> NIL
      
      (lowc 'any) -> any
      Lower case conversion: If any is not a symbol, it is returned as it is. Otherwise, a new transient symbol with all characters of any, converted to lower case, is returned. See also uppc, fold and low?.
      
      : (lowc 123)
      -> 123
      : (lowc "ABC")
      -> "abc"
      
      (lt0 'any) -> num | NIL
      Returns num when the argument is a number and less than zero, otherwise NIL. See also le0, ge0, gt0, =0 and n0.
      
      : (lt0 -2)
      -> -2
      : (lt0 3)
      -> NIL
      
      (lup 'lst 'any) -> lst
      (lup 'lst 'any 'any2) -> lst
      Looks up any in the CAR-elements of cons pairs stored in the index tree lst, as built-up by idx. In the first form, the first found cons pair is returned, in the second form a list of all pairs whose CAR is in the range any .. any2. See also assoc.
      
      : (idx 'A 'a T)
      -> NIL
      : (idx 'A (1 . b) T)
      -> NIL
      : (idx 'A 123 T)
      -> NIL
      : (idx 'A (1 . a) T)
      -> NIL
      : (idx 'A (1 . c) T)
      -> NIL
      : (idx 'A (2 . d) T)
      -> NIL
      : (idx 'A)
      -> (123 a (1 . a) (1 . b) (1 . c) (2 . d))
      : (lup A 1)
      -> (1 . b)
      : (lup A 2)
      -> (2 . d)
      : (lup A 1 1)
      -> ((1 . a) (1 . b) (1 . c))
      : (lup A 1 2)
      -> ((1 . a) (1 . b) (1 . c) (2 . d))
      
      picolisp-3.1.5.2.orig/doc/refM.html0000644000000000000000000005433712265263724015510 0ustar rootroot M

      M

      *Msg
      A global variable holding the last recently issued error message. See also Error Handling, *Err and ^.
      
      : (+ 'A 2)
      !? (+ 'A 2)
      A -- Number expected
      ?
      :
      : *Msg
      -> "Number expected"
      
      +Mis
      Prefix class to explicitly specify validation functions for +relations. Expects a function that takes a value and an entity object, and returns NIL if everything is correct, or an error string. See also Database.
      
      (class +Ord +Entity)            # Order class
      (rel pos (+Mis +List +Joint)    # List of positions in that order
         ((Val Obj)
            (when (memq NIL Val)
               "There are empty positions" ) )
         ord (+Pos) )
      
      (macro prg) -> any
      Substitues all pat? symbols in prg (using fill), and executes the result with run. Used occasionally to call functions which otherwise do not evaluate their arguments.
      
      : (de timerMessage (@N . @Prg)
         (setq @N (- @N))
         (macro
            (task @N 0 . @Prg) ) )
      -> timerMessage
      : (timerMessage 6000 (println 'Timer 6000))
      -> (-6000 0 (println 'Timer 6000))
      : (timerMessage 12000 (println 'Timer 12000))
      -> (-12000 0 (println 'Timer 12000))
      : (more *Run)
      (-12000 2616 (println 'Timer 12000))
      (-6000 2100 (println 'Timer 6000))
      -> NIL
      : Timer 6000
      Timer 12000
      ...
      
      (made ['lst1 ['lst2]]) -> lst
      Initializes a new list value for the current make environment. All list elements already produced with chain and link are discarded, and lst1 is used instead. Optionally, lst2 can be specified as the new linkage cell, otherwise the last cell of lst1 is used. When called without arguments, made does not modify the environment. In any case, the current list is returned.
      
      : (make
         (link 'a 'b 'c)         # Link three items
         (println (made))        # Print current list (a b c)
         (made (1 2 3))          # Discard it, start new with (1 2 3)
         (link 4) )              # Link 4
      (a b c)
      -> (1 2 3 4)
      
      (mail 'any 'cnt 'sym1 'sym2|lst1 'sym3 'lst2 . prg)'
      Sends an eMail via SMTP to a mail server at host any, port cnt. sym1 should be the "from" address, sym2|lst1 the "to" address(es), and sym3 the subject. lst2 is a list of attachments, each one specified by three elements for path, name and mime type. prg generates the mail body with prEval. See also connect.
      
      (mail "localhost" 25                               # Local mail server
         "a@bc.de"                                       # "From" address
         "abu@software-lab.de"                           # "To" address
         "Testmail"                                      # Subject
         (quote
            "img/go.png" "go.png" "image/png"            # First attachment
            "img/7fach.gif" "7fach.gif" "image/gif" )    # Second attachment
         "Hello,"                                        # First line
         NIL                                             # (empty line)
         (prinl (pack "This is mail #" (+ 3 4))) )       # Third line
      
      (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any
      Initializes and executes a list-building process with the made, chain, link and yoke functions, and returns the result list. For efficiency, pointers to the head and the tail of the list are maintained internally.
      
      : (make (link 1) (link 2 3) (link 4))
      -> (1 2 3 4)
      : (make (made (1 2 3)) (link 4))
      -> (1 2 3 4)
      
      (map 'fun 'lst ..) -> lst
      Applies fun to lst and all successive CDRs. When additional lst arguments are given, they are passed to fun in the same way. Returns the result of the last application. See also mapc, maplist, mapcar, mapcon, mapcan and filter.
      
      : (map println (1 2 3 4) '(A B C))
      (1 2 3 4) (A B C)
      (2 3 4) (B C)
      (3 4) (C)
      (4) NIL
      -> NIL
      
      map/3
      Pilog predicate that returns a list and subsequent CDRs of that list, after applying the get algorithm to that object and the following arguments. Often used in database queries. See also lst/3.
      
      : (? (db nr +Ord 1 @Ord) (map @L @Ord pos))
       @Ord={3-7} @L=({4-1} {4-2} {4-3})
       @Ord={3-7} @L=({4-2} {4-3})
       @Ord={3-7} @L=({4-3})
      -> NIL
      
      (mapc 'fun 'lst ..) -> any
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns the result of the last application. See also map, maplist, mapcar, mapcon, mapcan and filter.
      
      : (mapc println (1 2 3 4) '(A B C))
      1 A
      2 B
      3 C
      4 NIL
      -> NIL
      
      (mapcan 'fun 'lst ..) -> lst
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns a (destructively) concatenated list of all results. See also map, mapc, maplist, mapcar, mapcon, filter.
      
      : (mapcan reverse '((a b c) (d e f) (g h i)))
      -> (c b a f e d i h g)
      
      (mapcar 'fun 'lst ..) -> lst
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns a list of all results. See also map, mapc, maplist, mapcon, mapcan and filter.
      
      : (mapcar + (1 2 3) (4 5 6))
      -> (5 7 9)
      : (mapcar '((X Y) (+ X (* Y Y))) (1 2 3 4) (5 6 7 8))
      -> (26 38 52 68)
      
      (mapcon 'fun 'lst ..) -> lst
      Applies fun to lst and all successive CDRs. When additional lst arguments are given, they are passed to fun in the same way. Returns a (destructively) concatenated list of all results. See also map, mapc, maplist, mapcar, mapcan and filter.
      
      : (mapcon copy '(1 2 3 4 5))
      -> (1 2 3 4 5 2 3 4 5 3 4 5 4 5 5)
      
      (maplist 'fun 'lst ..) -> lst
      Applies fun to lst and all successive CDRs. When additional lst arguments are given, they are passed to fun in the same way. Returns a list of all results. See also map, mapc, mapcar, mapcon, mapcan and filter.
      
      : (maplist cons (1 2 3) '(A B C))
      -> (((1 2 3) A B C) ((2 3) B C) ((3) C))
      
      (maps 'fun 'sym ['lst ..]) -> any
      Applies fun to all properties of sym. When additional lst arguments are given, their elements are also passed to fun. Returns the result of the last application. See also putl and getl.
      
      : (put 'X 'a 1)
      -> 1
      : (put 'X 'b 2)
      -> 2
      : (put 'X 'flg T)
      -> T
      : (getl 'X)
      -> (flg (2 . b) (1 . a))
      : (maps println 'X '(A B))
      flg A
      (2 . b) B
      (1 . a) NIL
      -> NIL
      
      (mark 'sym|0 ['NIL | 'T | '0]) -> flg
      Tests, sets or resets a mark for sym in the database (for a second argument of NIL, T or 0, respectively), and returns the old value. The marks are local to the current process (not stored in the database), and vanish when the process terminates. If the first argument is zero, all marks are cleared.
      
      : (pool "db")
      -> T
      : (mark '{1} T)      # Mark
      -> NIL
      : (mark '{1})        # Test
      -> T                 # -> marked
      : (mark '{1} 0)      # Unmark
      -> T
      : (mark '{1})        # Test
      -> NIL               # -> unmarked
      
      (match 'lst1 'lst2) -> flg
      Takes lst1 as a pattern to be matched against lst2, and returns T when successful. Atoms must be equal, and sublists must match recursively. Symbols in the pattern list with names starting with an at-mark "@" (see pat?) are taken as wildcards. They can match zero, one or more elements, and are bound to the corresponding data. See also chop, split and fill.
      
      : (match '(@A is @B) '(This is a test))
      -> T
      : @A
      -> (This)
      : @B
      -> (a test)
      : (match '(@X (d @Y) @Z) '((a b c) (d (e f) g) h i))
      -> T
      : @X
      -> ((a b c))
      : @Y
      -> ((e f) g)
      : @Z
      -> (h i)
      
      (max 'any ..) -> any
      Returns the largest of all any arguments. See also min and Comparing.
      
      : (max 2 'a 'z 9)
      -> z
      : (max (5) (2 3) 'X)
      -> (5)
      
      (maxKey 'tree ['any1 ['any2]]) -> any
      Returns the largest key in a database tree. If a minimal key any1 and/or a maximal key any2 is given, the largest key from that range is returned. See also tree, leaf, minKey and genKey.
      
      : (maxKey (tree 'nr '+Item))
      -> 7
      : (maxKey (tree 'nr '+Item) 3 5)
      -> 5
      
      (maxi 'fun 'lst ..) -> any
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns that element from lst for which fun returned a maximal value. See also mini and sort.
      
      : (setq A 1  B 2  C 3)
      -> 3
      : (maxi val '(A B C))
      -> C
      : (maxi                          # Symbol with largest list value
         '((X)
            (and (pair (val X)) (size @)) )
         (all) )
      -> pico
      
      (member 'any 'lst) -> any
      Returns the tail of lst that starts with any when any is a member of lst, otherwise NIL. See also memq, assoc and idx.
      
      : (member 3 (1 2 3 4 5 6))
      -> (3 4 5 6)
      : (member 9 (1 2 3 4 5 6))
      -> NIL
      : (member '(d e f) '((a b c) (d e f) (g h i)))
      -> ((d e f) (g h i))
      
      member/2
      Pilog predicate that succeeds if the the first argument is a member of the list in the second argument. See also equal/2 and member.
      
      :  (? (member @X (a b c)))
       @X=a
       @X=b
       @X=c
      -> NIL
      
      (memq 'any 'lst) -> any
      Returns the tail of lst that starts with any when any is a member of lst, otherwise NIL. == is used for comparison (pointer equality). See also member, mmeq, asoq, delq and Comparing.
      
      : (memq 'c '(a b c d e f))
      -> (c d e f)
      : (memq (2) '((1) (2) (3)))
      -> NIL
      
      (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any
      Fetches a property value any, by searching the property lists of the classes and superclasses of obj, or the classes in typ, for the property key sym, and by applying the get algorithm to the following optional arguments. See also var:.
      
      : (setq A '(B))            # Be 'A' an object of class 'B'
      -> (B)
      : (put 'B 'a 123)
      -> 123
      : (meta 'A 'a)             # Fetch 'a' from 'B'
      -> 123
      
      (meth 'obj ['any ..]) -> any
      This function is usually not called directly, but is used by dm as a template to initialize the VAL of message symbols. It searches for itself in the methods of obj and its classes and superclasses, and executes that method. An error "Bad message" is issued if the search is unsuccessful. See also OO Concepts, method, send and try.
      
      : meth
      -> 67283504    # Value of 'meth'
      : stop>
      -> 67283504    # Value of any message
      
      (method 'msg 'obj) -> fun
      Returns the function body of the method that would be executed upon sending the message msg to the object obj. If the message cannot be located in obj, its classes and superclasses, NIL is returned. See also OO Concepts, send, try, meth, super, extra, class.
      
      : (method 'mis> '+Number)
      -> ((Val Obj) (and Val (not (num? Val)) "Numeric input expected"))
      
      (methods 'sym) -> lst
      (Debug mode only) Returns a list of method specifications for the object or class sym, as they are inherited from sym's classes and superclasses. See also OO Concepts, dep, class and can.
      
      : (more (methods '+Joint))
      (keep> . +Joint)
      (lose> . +Joint)
      (rel> . +Joint)
      (mis> . +Joint)
      (T . +Joint)
      (revise> . +relation)
      (print> . +relation)
      (zap> . +relation)
      (del> . +relation)
      (put> . +relation)
      (has> . +relation)
      (ele> . +relation)
      
      (min 'any ..) -> any
      Returns the smallest of all any arguments. See also max and Comparing.
      
      : (min 2 'a 'z 9)
      -> 2
      : (min (5) (2 3) 'X)
      -> X
      
      (minKey 'tree ['any1 ['any2]]) -> any
      Returns the smallest key in a database tree. If a minimal key any1 and/or a maximal key any2 is given, the smallest key from that range is returned. See also tree, leaf, maxKey and genKey.
      
      : (minKey (tree 'nr '+Item))
      -> 1
      : (minKey (tree 'nr '+Item) 3 5)
      -> 3
      
      (mini 'fun 'lst ..) -> any
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns that element from lst for which fun returned a minimal value. See also maxi and sort.
      
      : (setq A 1  B 2  C 3)
      -> 3
      : (mini val '(A B C))
      -> A
      
      (mix 'lst cnt|'any ..) -> lst
      Builds a list from the elements of the argument lst, as specified by the following cnt|'any arguments. If such an argument is a number, the cnt'th element from lst is taken, otherwise that argument is evaluated and the result is used.
      
      : (mix '(a b c d) 3 4 1 2)
      -> (c d a b)
      : (mix '(a b c d) 1 'A 4 'D)
      -> (a A d D)
      
      (mmeq 'lst 'lst) -> any
      Returns the tail of the second argument lst that starts with a member of the first argument lst, otherwise NIL. == is used for comparison (pointer equality). See also member, memq, asoq and delq.
      
      : (mmeq '(a b c) '(d e f))
      -> NIL
      : (mmeq '(a b c) '(d b x))
      -> (b x)
      
      (money 'num ['sym]) -> sym
      Formats a number num into a digit string with two decimal places, according to the current locale. If an additional currency name is given, it is appended (separated by a space). See also telStr, datStr and format.
      
      : (money 123456789)
      -> "1,234,567.89"
      : (money 12345 "EUR")
      -> "123.45 EUR"
      : (locale "DE" "de")
      -> NIL
      : (money 123456789 "EUR")
      -> "1.234.567,89 EUR"
      
      (more 'lst ['fun]) -> flg
      (more 'cls) -> any
      (Debug mode only) Displays the elements of lst (first form), or the type and methods of cls (second form). fun defaults to print. In the second form, the method definitions of cls are pretty-printed with pp. After each step, more waits for console input, and terminates when a non-empty line is entered. In that case, T is returned, otherwise (when end of data is reached) NIL. See also query and show.
      
      : (more (all))                         # Display all internal symbols
      inc>
      leaf
      nil
      inc!
      accept.                                # Stop
      -> T
      
      : (more (all) show)                    # 'show' all internal symbols
      inc> 67292896
         *Dbg ((859 . "lib/db.l"))
      
      leaf ((Tree) (let (Node (cdr (root Tree)) X) (while (val Node) (setq X (cadr @) Node (car @))) (cddr X)))
         *Dbg ((173 . "lib/btree.l"))
      
      nil 67284680
         T (((@X) (^ @ (not (-> @X)))))
      .                                      # Stop
      -> T
      
      : (more '+Link)                        # Display a class
      (+relation)
      
      (dm mis> (Val Obj)
         (and
            Val
            (nor (isa (: type) Val) (canQuery Val))
            "Type error" ) )
      
      (dm T (Var Lst)
         (unless (=: type (car Lst)) (quit "No Link" Var))
         (super Var (cdr Lst)) )
      
      -> NIL
      
      (msg 'any ['any ..]) -> any
      Prints any with print, followed by all any arguments (printed with prin) and a newline, to standard error. The first any argument is returned.
      
      : (msg (1 a 2 b 3 c) " is a mixed " "list")
      (1 a 2 b 3 c) is a mixed list
      -> (1 a 2 b 3 c)
      
      picolisp-3.1.5.2.orig/doc/refN.html0000644000000000000000000003654212265263724015507 0ustar rootroot N

      N

      +Need
      Prefix class for mandatory +relations. Note that this does not enforce any requirements by itself, it only returns an error message if the mis> message is explicitly called, e.g. by GUI functions. See also Database.
      
      (rel nr (+Need +Key +Number))  # Item number is mandatory
      
      +Number
      Class for numeric relations, a subclass of +relation. Accepts an optional argument for the fixpoint scale (currently not used). See also Database.
      
      (rel pr (+Number) 2)  # Price, with two decimal places
      
      (n== 'any ..) -> flg
      Returns T when not all any arguments are the same (pointer equality). (n== 'any ..) is equivalent to (not (== 'any ..)). See also == and Comparing.
      
      : (n== 'a 'a)
      -> NIL
      : (n== (1) (1))
      -> T
      
      (n0 'any) -> flg
      Returns T when any is not a number with value zero. See also =0, lt0, le0, ge0 and gt0.
      
      : (n0 (- 6 3 2 1))
      -> NIL
      : (n0 'a)
      -> T
      
      (nT 'any) -> flg
      Returns T when any is not the symbol T. See also =T.
      
      : (nT 0)
      -> T
      : (nT "T")
      -> T
      : (nT T)
      -> NIL
      
      (name 'sym ['sym2]) -> sym
      Returns, if sym2 is not given, a new transient symbol with the name of sym. Otherwise sym must be a transient symbol, and its name is changed to that of sym2 (note that this may give inconsistencies if the symbol is still referred to from other namespaces). See also str, sym, symbols, zap and intern.
      
      : (name 'abc)
      -> "abc"
      : (name "abc")
      -> "abc"
      : (name '{abc})
      -> "abc"
      : (name (new))
      -> NIL
      : (de foo (Lst) (car Lst))  # 'foo' calls 'car'
      -> foo
      : (intern (name (zap 'car) "xxx"))  # Globally change the name of 'car'
      -> xxx
      : (xxx (1 2 3))
      -> 1
      : (pp 'foo)
      (de foo (Lst)
         (xxx Lst) )                      # Name changed
      -> foo
      : (foo (1 2 3))                     # 'foo' still works
      -> 1
      : (car (1 2 3))                     # Reader returns a new 'car' symbol
      !? (car (1 2 3))
      car -- Undefined
      ?
      
      (nand 'any ..) -> flg
      Logical NAND. The expressions any are evaluated from left to right. If NIL is encountered, T is returned immediately. Else NIL is returned. (nand ..) is equivalent to (not (and ..)).
      
      : (nand (lt0 7) (read))
      -> T
      : (nand (lt0 -7) (read))
      abc
      -> NIL
      : (nand (lt0 -7) (read))
      NIL
      -> T
      
      (native 'cnt1|sym1 'cnt2|sym2 'any 'any ..) -> any
      (64-bit version only) Calls a native C function. The first argument should specify a shared object library, either "@" (the current main program), sym1 (a library path name), or cnt1 (a library handle obtained by a previous call). The second argument should be a symbol name sym2, or a function pointer cnt2 obtained by a previous call). Practically, the first two arguments will be always passed as transient symbols, which will get the library handle and function pointer assigned as values to be cached and used in subsequent calls. The third argument any is a result specification, while all following arguments are the arguments to the native function. The functionality is described in detail in Native C Calls.

      The result specification may either be one of the atoms

      
         NIL   void
         B     byte     # Byte (unsigned 8 bit)
         C     char     # Character (UTF-8, 1-3 bytes)
         I     int      # Integer (signed 32 bit)
         N     long     # Long or pointer (signed 64 bit)
         S     string   # String (UTF-8)
        -1.0   float    # Scaled fixpoint number
        +1.0   double   # Scaled fixpoint number
      

      or nested lists of these atoms with size specifications to denote arrays and structures, e.g.

      
         (N . 4)        # long[4];           -> (1 2 3 4)
         (N (C . 4))    # {long; char[4];}   -> (1234 ("a" "b" "c" NIL))
         (N (B . 7))    # {long; byte[7];}   -> (1234 (1 2 3 4 5 6 7))
      

      Arguments can be

      • integers (up to 64-bit) or pointers, passed as numbers
      • strings, passed as symbols
      • fixpoint numbers, passed as cons pairs consisting of a the value and the scale (if the scale is positive, the number is passed as a double, otherwise as a float)
      • structures, passed as lists with
        • a variable in the CAR (to recieve the returned structure data, ignored when the CAR is NIL)
        • a cons pair for the size and result specification in the CADR (see above), and
        • an optional sequence of initialization items in the CDDR, where each may be
          • a positive number, stored as an unsigned byte value
          • a negative number, whose absolute value is stored as an unsigned integer
          • a pair (num . cnt) where 'num' is stored in a field of 'cnt' bytes
          • a pair (sym . cnt) where 'sym' is stored as a null-terminated string in a field of 'cnt' bytes
          • a list (1.0 num ...) where the 'num' elements (scaled fixpoint numbers) are stored as a sequence of double precision floating point numbers
          • a list (-1.0 num ...) where the 'num' elements (scaled fixpoint numbers) are stored as a sequence of single precision floating point numbers
          If the last CDR of the initialization sequence is a number, it is used as a fill-byte value for the remaining space in the structure.

      native takes care of allocating memory for strings, arrays or structures, and frees that memory when done.

      The number of fixpoint arguments is limited to six. For NaN or negative infinity NIL, and for positive infinity T is returned.

      The C function may in turn call a function

      
         long lisp(char*, long, long, long, long, long);
      

      which accepts a symbol name as the first argument, and up to 5 numbers. lisp() calls that symbol with the five numbers, and expects a numeric return value. "Numbers" in this context are 64-bit scalars, and may not only represent integers, but also pointers or other encoded data. See also struct, lisp and errno.

      
      : (native "@" "getenv" 'S "TERM")  # Same as (sys "TERM")
      -> "xterm"
      
      : (native "@" "printf" 'I "abc%d%s^J" (+ 3 4) (pack "X" "Y" "Z"))
      abc7XYZ
      -> 8
      
      : (native "@" "printf" 'I "This is %.3f^J" (123456 . 1000))
      This is 123.456
      -> 16
      
      : (use Tim
         (native "@" "time" NIL '(Tim (8 B . 8)))  # time_t 8   # Get time_t structure
         (native "@" "localtime" '(I . 9) (cons NIL (8) Tim)) ) # Read local time
      -> (32 18 13 31 11 109 4 364 0)  # 13:18:32, Dec. 31st, 2009
      
      : (native "libcrypto.so" "SHA1" '(B . 20) "abcd" 4 0)
      -> (129 254 139 254 135 87 108 62 203 34 66 111 142 87 132 115 130 145 122 207)
      
      (need 'cnt ['lst ['any]]) -> lst
      (need 'cnt ['num|sym]) -> lst
      Produces a list of at least cnt elements. When called without optional arguments, a list of cnt NIL's is returned. When lst is given, it is extended to the left (if cnt is positive) or (destructively) to the right (if cnt is negative) with any elements. In the second form, a list of cnt atomic values is returned. See also range.
      
      : (need 5)
      -> (NIL NIL NIL NIL NIL)  # Allocate 5 cells
      : (need 5 '(a b c))
      -> (NIL NIL a b c)
      : (need -5 '(a b c))
      -> (a b c NIL NIL)
      : (need 5 '(a b c) " ")  # String alignment
      -> (" " " " a b c)
      : (need 7 0)
      -> (0 0 0 0 0 0 0)
      
      (new ['flg|num] ['typ ['any ..]]) -> obj
      Creates and returns a new object. If flg is given and non-NIL, the new object will be an external symbol (created in database file 1 if T, or in the corresponding database file if num is given). typ (typically a list of classes) is assigned to the VAL, and the initial T message is sent with the arguments any to the new object. If no T message is defined for the classes in typ or their superclasses, the any arguments should evaluate to alternating keys and values for the initialization of the new object. See also box, object, class, type, isa, send and Database.
      
      : (new)
      -> $134426427
      : (new T '(+Address))
      -> {1A;3}
      
      (new! 'typ ['any ..]) -> obj
      Transaction wrapper function for new. (new! '(+Cls) 'key 'val ...) is equivalent to (dbSync) (new (db: +Cls) '(+Cls) 'key 'val ...) (commit 'upd). See also set!, put! and inc!.
      
      : (new! '(+Item)  # Create a new item
         'nr 2                      # Item number
         'nm "Spare Part"           # Description
         'sup (db 'nr '+CuSu 2)     # Supplier
         'inv 100                   # Inventory
         pr 12.50 )                 # Price
      
      (next) -> any
      Can only be used inside functions with a variable number of arguments (with @). Returns the next argument from the internal list. See also args, arg, rest, and pass.
      
      : (de foo @ (println (next)))          # Print next argument
      -> foo
      : (foo)
      NIL
      -> NIL
      : (foo 123)
      123
      -> 123
      
      (nil . prg) -> NIL
      Executes prg, and returns NIL. See also t, prog, prog1 and prog2.
      
      : (nil (println 'OK))
      OK
      -> NIL
      
      nil/1
      Pilog predicate expects an argument variable, and succeeds if that variable is bound to NIL. See also not/1.
      
      : (? @X NIL (nil @X))
       @X=NIL
      -> NIL
      
      (noLint 'sym)
      (noLint 'sym|(sym . cls) 'sym2)
      (Debug mode only) Excludes the check for a function definition of sym (in the first form), or for variable binding and usage of sym2 in the function definition, file contents or method body of sym (second form), during calls to lint. See also lintAll.
      
      : (de foo ()
         (bar FreeVariable) )
      -> foo
      : (lint 'foo)
      -> ((def bar) (bnd FreeVariable))
      : (noLint 'bar)
      -> bar
      : (noLint 'foo 'FreeVariable)
      -> (foo . FreeVariable)
      : (lint 'foo)
      -> NIL
      
      (nond ('any1 . prg1) ('any2 . prg2) ..) -> any
      Negated ("non-cond") multi-way conditional: If any of the anyN conditions evaluates to NIL, prgN is executed and the result returned. Otherwise (all conditions evaluate to non-NIL), NIL is returned. See also cond, ifn and unless.
      
      : (nond
         ((= 3 3) (println 1))
         ((= 3 4) (println 2))
         (NIL (println 3)) )
      2
      -> 2
      
      (nor 'any ..) -> flg
      Logical NOR. The expressions any are evaluated from left to right. If a non-NIL value is encountered, NIL is returned immediately. Else T is returned. (nor ..) is equivalent to (not (or ..)).
      
      : (nor (lt0 7) (= 3 4))
      -> T
      
      (not 'any) -> flg
      Logical negation. Returns T if any evaluates to NIL.
      
      : (not (== 'a 'a))
      -> NIL
      : (not (get 'a 'a))
      -> T
      
      not/1
      Pilog predicate that succeeds if and only if the goal cannot be proven. See also nil/1, true/0 and fail/0.
      
      : (? (equal 3 4))
      -> NIL
      : (? (not (equal 3 4)))
      -> T
      
      (nth 'lst 'cnt ..) -> lst
      Returns the tail of lst starting from the cnt'th element of lst. Successive cnt arguments operate on the results in the same way. (nth 'lst 2) is equivalent to (cdr 'lst). See also get.
      
      : (nth '(a b c d) 2)
      -> (b c d)
      : (nth '(a (b c) d) 2 2)
      -> (c)
      : (cdadr '(a (b c) d))
      -> (c)
      
      (num? 'any) -> num | NIL
      Returns any when the argument any is a number, otherwise NIL.
      
      : (num? 123)
      -> 123
      : (num? (1 2 3))
      -> NIL
      
      picolisp-3.1.5.2.orig/doc/refO.html0000644000000000000000000002133712265263724015504 0ustar rootroot O

      O

      *Once
      Holds an idx tree of already loaded source locations (as returned by file) See also once.
      
      : *Once
      -> (("lib/" "misc.l" . 11) (("lib/" "http.l" . 9) (("lib/" "form.l" . 11))))
      
      *OS
      A global constant holding the name of the operating system. Possible values include "Linux", "FreeBSD", "Darwin" or "Cygwin". See also *CPU.
      
      : *OS
      -> "Linux"
      
      (obj (typ var [hook] val ..) var2 val2 ..) -> obj
      Finds or creates a database object (using request) corresponding to (typ var [hook] val ..), and initializes additional properties using the varN and valN arguments.
      
      : (obj ((+Item) nr 2) nm "Spare Part" sup `(db 'nr '+CuSu 2) inv 100 pr 1250)
      -> {3-2}
      
      (object 'sym 'any ['sym2 'any2 ..]) -> obj
      Defines sym to be an object with the value (or type) any. The property list is initialized with all optionally supplied key-value pairs. See also OO Concepts, new, type and isa.
      
      : (object 'Obj '(+A +B +C) 'a 1 'b 2 'c 3)
      -> Obj
      : (show 'Obj)
      Obj (+A +B +C)
         c 3
         b 2
         a 1
      -> Obj
      
      (oct 'num ['num]) -> sym
      (oct 'sym) -> num
      Converts a number num to an octal string, or an octal string sym to a number. In the first case, if the second argument is given, the result is separated by spaces into groups of such many digits. See also bin, hex, fmt64, hax and format.
      
      : (oct 73)
      -> "111"
      : (oct "111")
      -> 73
      : (oct 1234567 3)
      -> "4 553 207"
      
      (off var ..) -> NIL
      Stores NIL in all var arguments. See also on, onOff, zero and one.
      
      : (off A B)
      -> NIL
      : A
      -> NIL
      : B
      -> NIL
      
      (offset 'lst1 'lst2) -> cnt | NIL
      Returns the cnt position of the tail list lst1 in lst2, or NIL if it is not found. See also index and tail.
      
      : (offset '(c d e f) '(a b c d e f))
      -> 3
      : (offset '(c d e) '(a b c d e f))
      -> NIL
      
      (on var ..) -> T
      Stores T in all var arguments. See also off, onOff, zero and one.
      
      : (on A B)
      -> T
      : A
      -> T
      : B
      -> T
      
      (once . prg) -> any
      Executes prg once, when the current file is loaded the first time. Subsequent loads at a later time will not execute prg, and once returns NIL. See also *Once.
      
      (once
         (zero *Cnt1 *Cnt2)  # Init counters
         (load "file1.l" "file2.l") )  # Load other files
      
      (one var ..) -> 1
      Stores 1 in all var arguments. See also zero, on, off and onOff.
      
      : (one A B)
      -> 1
      : A
      -> 1
      : B
      -> 1
      
      (onOff var ..) -> flg
      Logically negates the values of all var arguments. Returns the new value of the last symbol. See also on, off, zero and one.
      
      : (onOff A B)
      -> T
      : A
      -> T
      : B
      -> T
      : (onOff A B)
      -> NIL
      : A
      -> NIL
      : B
      -> NIL
      
      (open 'any ['flg]) -> cnt | NIL
      Opens the file with the name any in read/write mode (or read-only if flg is non-NIL), and returns a file descriptor cnt (or NIL on error). A leading "@" character in any is substituted with the PicoLisp Home Directory, as it was remembered during interpreter startup. If flg is NIL and the file does not exist, it is created. The file descriptor can be used in subsequent calls to in and out. See also close and poll.
      
      : (open "x")
      -> 3
      
      (opid) -> pid | NIL
      Returns the corresponding process ID when the current output channel is writing to a pipe, otherwise NIL. See also ipid and out.
      
      : (out '(cat) (call 'ps "-p" (opid)))
        PID TTY          TIME CMD
       7127 pts/3    00:00:00 cat
      -> T
      
      (opt) -> sym
      Return the next command line argument ("option", as would be processed by load) as a string, and remove it from the remaining command line arguments. See also Invocation and argv.
      
      $ pil  -"de f () (println 'opt (opt))"  -f abc  -bye
      opt "abc"
      
      (or 'any ..) -> any
      Logical OR. The expressions any are evaluated from left to right. If a non-NIL value is encountered, it is returned immediately. Else the result of the last expression is returned.
      
      : (or (= 3 3) (read))
      -> T
      : (or (= 3 4) (read))
      abc
      -> abc
      
      or/2
      Pilog predicate that takes an arbitrary number of clauses, and succeeds if one of them can be proven. See also not/1.
      
      : (?
         (or
            ((equal 3 @X) (equal @X 4))
            ((equal 7 @X) (equal @X 7)) ) )
       @X=7
      -> NIL
      (out 'any . prg) -> any
      Opens any as output channel during the execution of prg. The current output channel will be saved and restored appropriately. If the argument is NIL, standard output is used. If the argument is a symbol, it is used as a file name (opened in "append" mode if the first character is "+"). If it is a positve number, it is used as the descriptor of an open file. If it is a negative number, the saved output channel such many levels above the current one is used. Otherwise (if it is a list), it is taken as a command with arguments, and a pipe is opened for output. See also opid, call, in, err, ctl, pipe, poll, close and load.
      
      : (out "a" (println 123 '(a b c) 'def))  # Write one line to file "a"
      -> def
      
      picolisp-3.1.5.2.orig/doc/refP.html0000644000000000000000000007140112265263724015502 0ustar rootroot P

      P

      *PPid
      A global constant holding the process-id of the parent picolisp process, or NIL if the current process is a top level process.
      
      : (println *PPid *Pid)
      NIL 5286
      
      : (unless (fork) (println *PPid *Pid) (bye))
      5286 5522
      
      *Pid
      A global constant holding the current process-id.
      
      : *Pid
      -> 6386
      : (call "ps")  # Show processes
        PID TTY          TIME CMD
       .... ...      ........ .....
       6386 pts/1    00:00:00 pil   # <- current process
       6388 pts/1    00:00:00 ps
      -> T
      
      *Prompt
      Global variable holding a (possibly empty) prg body, which is executed - and the result printed - every time before a prompt is output to the console in the "read-eval-print-loop" (REPL).
      
      : (de *Prompt (pack "[" (stamp) "]"))
      # *Prompt redefined
      -> *Prompt
      [2011-10-11 16:50:05]: (+ 1 2 3)
      -> 6
      [2011-10-11 16:50:11]:
      
      (pack 'any ..) -> sym
      Returns a transient symbol whose name is concatenated from all arguments any. A NIL arguments contributes nothing to the result string, a number is converted to a digit string, a symbol supplies the characters of its name, and for a list its elements are taken. See also text and glue.
      
      : (pack 'car " is " 1 '(" symbol " name))
      -> "car is 1 symbol name"
      
      (pad 'cnt 'any) -> sym
      Returns a transient symbol with any packed with leading '0' characters, up to a field width of cnt. See also format and align.
      
      : (pad 5 1)
      -> "00001"
      : (pad 5 123456789)
      -> "123456789"
      
      (pair 'any) -> any
      Returns any when the argument is a cons pair. See also atom and lst?.
      
      : (pair NIL)
      -> NIL
      : (pair (1 . 2))
      -> (1 . 2)
      : (pair (1 2 3))
      -> (1 2 3)
      
      part/3
      Pilog predicate that succeeds if the first argument, after folding it to a canonical form, is a substring of the folded string representation of the result of applying the get algorithm to the following arguments. Typically used as filter predicate in select/3 database queries. See also sub?, isa/2, same/3, bool/3, range/3, head/3, fold/3 and tolr/3.
      
      : (?
         @Nr (1 . 5)
         @Nm "part"
         (select (@Item)
            ((nr +Item @Nr) (nm +Item @Nm))
            (range @Nr @Item nr)
            (part @Nm @Item nm) ) )
       @Nr=(1 . 5) @Nm="part" @Item={3-1}
       @Nr=(1 . 5) @Nm="part" @Item={3-2}
      -> NIL
      
      (pass 'fun ['any ..]) -> any
      Passes to fun all arguments any, and all remaining variable arguments (@) as they would be returned by rest. (pass 'fun 'any) is equivalent to (apply 'fun (rest) 'any). See also apply.
      
      : (de bar (A B . @)
         (println 'bar A B (rest)) )
      -> bar
      : (de foo (A B . @)
         (println 'foo A B)
         (pass bar 1)
         (pass bar 2) )
      -> foo
      : (foo 'a 'b 'c 'd 'e 'f)
      foo a b
      bar 1 c (d e f)
      bar 2 c (d e f)
      -> (d e f)
      
      (pat? 'any) -> pat | NIL
      Returns any when the argument any is a symbol whose name starts with an at-mark "@", otherwise NIL.
      
      : (pat? '@)
      -> @
      : (pat? "@Abc")
      -> "@Abc"
      : (pat? "ABC")
      -> NIL
      : (pat? 123)
      -> NIL
      
      (patch 'lst 'any . prg) -> any
      Destructively replaces all sub-expressions of lst, that match the pattern any, by the result of the execution of prg. See also daemon and redef.
      
      : (pp 'hello)
      (de hello NIL
         (prinl "Hello world!") )
      -> hello
      
      : (patch hello 'prinl 'println)
      -> NIL
      : (pp 'hello)
      (de hello NIL
         (println "Hello world!") )
      -> hello
      
      : (patch hello '(prinl @S) (fill '(println "We said: " . @S)))
      -> NIL
      : (hello)
      We said: Hello world!
      -> "Hello world!"
      
      (path 'any) -> sym
      Substitutes any leading "@" character in the any argument with the PicoLisp Home Directory, as it was remembered during interpreter startup. Optionally, the name may be preceded by a "+" character (as used by in and out). This mechanism is used internally by all I/O functions. See also Invocation, basename and dirname.
      
      $ /usr/bin/picolisp /usr/lib/picolisp/lib.l
      : (path "a/b/c")
      -> "a/b/c"
      : (path "@a/b/c")
      -> "/usr/lib/picolisp/a/b/c"
      : (path "+@a/b/c")
      -> "+/usr/lib/picolisp/a/b/c"
      
      (peek) -> sym
      Single character look-ahead: Returns the same character as the next call to char would return. See also skip.
      
      $ cat a
      # Comment
      abcd
      $ pil +
      : (in "a" (list (peek) (char)))
      -> ("#" "#")
      
      permute/2
      Pilog predicate that succeeds if the second argument is a permutation of the list in the second argument. See also append/3.
      
      : (? (permute (a b c) @X))
       @X=(a b c)
       @X=(a c b)
       @X=(b a c)
       @X=(b c a)
       @X=(c a b)
       @X=(c b a)
      -> NIL
      
      (pick 'fun 'lst ..) -> any
      Applies fun to successive elements of lst until non-NIL is returned. Returns that value, or NIL if fun did not return non-NIL for any element of lst. When additional lst arguments are given, their elements are also passed to fun. (pick 'fun 'lst) is equivalent to (fun (find 'fun 'lst)). See also seek, find and extract.
      
      : (setq A NIL  B 1  C NIL  D 2  E NIL  F 3)
      -> 3
      : (find val '(A B C D E))
      -> B
      : (pick val '(A B C D E))
      -> 1
      
      pico
      (64-bit version only) A global constant holding the initial (default) namespace of internal symbols. Its value is a cons pair of two 'idx' trees, one for symbols with short names and one for symbols with long names (more than 7 bytes in the name). See also symbols, import and intern.
      
      : (symbols)
      -> pico
      : (cdr pico)
      -> (rollback (*NoTrace (ledSearch (expandTab (********)) *CtryCode ...
      
      (pil ['any ..]) -> sym
      Returns the path name to the packed any arguments in the directory ".pil/" in the user's home directory. See also tmp.
      
      : (pil "history")  # Path to the line editor's history file
      -> "/home/app/.pil/history"
      
      (pilog 'lst . prg) -> any
      Evaluates a Pilog query, and executes prg for each result set with all Pilog variables bound to their matching values. See also solve, ?, goal and prove.
      
      : (pilog '((append @X @Y (a b c))) (println @X '- @Y))
      NIL - (a b c)
      (a) - (b c)
      (a b) - (c)
      (a b c) - NIL
      -> NIL
      
      (pipe exe) -> cnt
      (pipe exe . prg) -> any
      Executes exe in a fork'ed child process (which terminates thereafter). In the first form, pipe just returns a file descriptor to read from the standard output of that process. In the second form, it opens the standard output of that process as input channel during the execution of prg. The current input channel will be saved and restored appropriately. See also later, ipid, in and out.
      
      : (pipe                                # equivalent to 'any'
         (prinl "(a b # Comment^Jc d)")         # (child process)
         (read) )                               # (parent process)
      -> (a b c d)
      : (pipe                                # pipe through an external program
         (out '(tr "[a-z]" "[A-Z]")             # (child process)
            (prinl "abc def ghi") )
         (line T) )                             # (parent process)
      -> "ABC DEF GHI"
      
      (place 'cnt 'lst 'any) -> lst
      Places any into lst at position cnt. This is a non-destructive operation. See also insert, remove, append, delete and replace.
      
      : (place 3 '(a b c d e) 777)
      -> (a b 777 d e)
      : (place 1 '(a b c d e) 777)
      -> (777 b c d e)
      : (place 9 '(a b c d e) 777)
      -> (a b c d e 777)
      
      (poll 'cnt) -> cnt | NIL
      Checks for the availability of data for reading on the file descriptor cnt. See also open, in and close.
      
      : (and (poll *Fd) (in @ (read)))  # Prevent blocking
      
      (pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T
      Opens the file sym1 as a database file in read/write mode. If the file does not exist, it is created. A currently open database is closed. lst is a list of block size scale factors (i.e. numbers), defaulting to (2) (for a single file with a 256 byte block size). If lst is given, an individual database file is opened for each item. If sym2 is non-NIL, it is opened in append-mode as an asynchronous replication journal. If sym3 is non-NIL, it is opened for reading and appending, to be used as a synchronous transaction log during commits. See also dbs, *Dbs and journal.
      
      : (pool "/dev/hda2")
      -> T
      
      : *Dbs
      -> (1 2 2 4)
      : (pool "dbFile" *Dbs)
      -> T
      :
      abu:~/pico  ls -l dbFile*
      -rw-r--r-- 1 abu abu 256 2007-06-11 07:57 dbFile1
      -rw-r--r-- 1 abu abu  13 2007-06-11 07:57 dbFile2
      -rw-r--r-- 1 abu abu  13 2007-06-11 07:57 dbFile3
      -rw-r--r-- 1 abu abu  13 2007-06-11 07:57 dbFile4
      
      (pop 'var) -> any
      Pops the first element (CAR) from the stack in var. See also push, queue, cut, del and fifo.
      
      : (setq S '((a b c) (1 2 3)))
      -> ((a b c) (1 2 3))
      : (pop S)
      -> a
      : (pop (cdr S))
      -> 1
      : (pop 'S)
      -> (b c)
      : S
      -> ((2 3))
      
      (port ['T] 'cnt|(cnt . cnt) ['var]) -> cnt
      Opens a TCP-Port cnt (or a UDP-Port if the first argument is T), and returns a socket descriptor suitable as an argument for listen or accept (or udp, respectively). If cnt is zero, some free port number is allocated. If a pair of cnts is given instead, it should be a range of numbers which are tried in turn. When var is given, it is bound to the port number.
      
      : (port 0 'A)                       # Allocate free port
      -> 4
      : A
      -> 1034                             # Got 1034
      : (port (4000 . 4008) 'A)           # Try one of these ports
      -> 5
      : A
      -> 4002
      
      (pp 'sym) -> sym
      (pp 'sym 'cls) -> sym
      (pp '(sym . cls)) -> sym
      Pretty-prints the function or method definition of sym. The output format would regenerate that same definition when read and executed. See also pretty, debug and vi.
      
      : (pp 'tab)
      (de tab (Lst . @)
         (for N Lst
            (let V (next)
               (and (gt0 N) (space (- N (length V))))
               (prin V)
               (and
                  (lt0 N)
                  (space (- 0 N (length V))) ) ) )
         (prinl) )
      -> tab
      
      : (pp 'has> '+Entity)
      (dm has> (Var Val)
         (or
            (nor Val (get This Var))
            (has> (meta This Var) Val (get This Var)) ) )
      -> has>
      
      : (more (can 'has>) pp)
      (dm (has> . +relation) (Val X)
         (and (= Val X) X) )
      
      (dm (has> . +Fold) (Val X)
         (extra
            Val
            (if (= Val (fold Val)) (fold X) X) ) )
      
      (dm (has> . +Entity) (Var Val)
         (or
            (nor Val (get This Var))
            (has> (meta This Var) Val (get This Var)) ) )
      
      (dm (has> . +List) (Val X)
         (and
            Val
            (or
               (extra Val X)
               (find '((X) (extra Val X)) X) ) ) )
      
      (dm (has> . +Bag) (Val X)
         (and
            Val
            (or (super Val X) (car (member Val X))) ) )
      
      (pr 'any ..) -> any
      Binary print: Prints all any arguments to the current output channel in encoded binary format. See also rd, bytes, tell, hear and wr.
      
      : (out "x" (pr 7 "abc" (1 2 3) 'a))  # Print to "x"
      -> a
      : (hd "x")
      00000000  04 0E 0E 61 62 63 01 04 02 04 04 04 06 03 05 61  ...abc.........a
      -> NIL
      
      (prEval 'prg ['cnt]) -> any
      Executes prg, similar to run, by evaluating all expressions in prg (within the binding environment given by cnt-1). As a side effect, all atomic expressions will be printed with prinl. See also eval.
      
      : (let Prg 567
         (prEval
            '("abc" (prinl (+ 1 2 3)) Prg 987) ) )
      abc
      6
      567
      987
      -> 987
      
      (pre? 'any1 'any2) -> any2 | NIL
      Returns any2 when the string representation of any1 is a prefix of the string representation of any2. See also sub?.
      
      : (pre? "abc" "abcdef")
      -> "abcdef"
      : (pre? "def" "abcdef")
      -> NIL
      : (pre? (+ 3 4) "7fach")
      -> "7fach"
      : (pre? NIL "abcdef")
      -> "abcdef"
      
      (pretty 'any 'cnt)
      Pretty-prints any. If any is an atom, or a list with a size not greater than 12, it is printed as is. Otherwise, only the opening parenthesis and the CAR of the list is printed, all other elementes are pretty-printed recursively indented by three spaces, followed by a space and the corresponding closing parenthesis. The initial indentation level cnt defaults to zero. See also pp.
      
      : (pretty '(a (b c d) (e (f (g) (h) (i)) (j (k) (l) (m))) (n o p) q))
      (a
         (b c d)
         (e
            (f (g) (h) (i))
            (j (k) (l) (m)) )
         (n o p)
         q )-> ")"
      
      (prin 'any ..) -> any
      Prints the string representation of all any arguments to the current output channel. No space or newline is printed between individual items, or after the last item. For lists, all elements are prin'ted recursively. See also prinl.
      
      : (prin 'abc 123 '(a 1 b 2))
      abc123a1b2-> (a 1 b 2)
      
      (prinl 'any ..) -> any
      Prints the string representation of all any arguments to the current output channel, followed by a newline. No space or newline is printed between individual items. For lists, all elements are prin'ted recursively. See also prin.
      
      : (prinl 'abc 123 '(a 1 b 2))
      abc123a1b2
      -> (a 1 b 2)
      
      (print 'any ..) -> any
      Prints all any arguments to the current output channel. If there is more than one argument, a space is printed between successive arguments. No space or newline is printed after the last item. See also println, printsp, sym and str
      
      : (print 123)
      123-> 123
      : (print 1 2 3)
      1 2 3-> 3
      : (print '(a b c) 'def)
      (a b c) def-> def
      
      (println 'any ..) -> any
      Prints all any arguments to the current output channel, followed by a newline. If there is more than one argument, a space is printed between successive arguments. See also print, printsp.
      
      : (println '(a b c) 'def)
      (a b c) def
      -> def
      
      (printsp 'any ..) -> any
      Prints all any arguments to the current output channel, followed by a space. If there is more than one argument, a space is printed between successive arguments. See also print, println.
      
      : (printsp '(a b c) 'def)
      (a b c) def -> def
      
      (prior 'lst1 'lst2) -> lst | NIL
      Returns the cell in lst2 which immediately precedes the cell lst1, or NIL if lst1 is not found in lst2 or is the very first cell. == is used for comparison (pointer equality). See also offset and memq.
      
      : (setq L (1 2 3 4 5 6))
      -> (1 2 3 4 5 6)
      : (setq X (cdddr L))
      -> (4 5 6)
      : (prior X L)
      -> (3 4 5 6)
      
      (proc 'sym ..) -> T
      (Debug mode only) Shows a list of processes with command names given by the sym arguments, using the system ps utility. See also hd.
      
      : (proc 'pil)
        PID  PPID  STARTED  SIZE %CPU WCHAN  CMD
      16993  3267 12:38:21  1516  0.5 -      /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil +
      15731  1834 12:36:35  2544  0.1 -      /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil app/main.l -main -go +
      15823 15731 12:36:44  2548  0.0 -        /usr/bin/picolisp /usr/lib/picolisp/lib.l /usr/bin/pil app/main.l -main -go +
      -> T
      
      (prog . prg) -> any
      Executes prg, and returns the result of the last expression. See also nil, t, prog1 and prog2.
      
      : (prog (print 1) (print 2) (print 3))
      123-> 3
      
      (prog1 'any1 . prg) -> any1
      Executes all arguments, and returns the result of the first expression any1. See also nil, t, prog and prog2.
      
      : (prog1 (print 1) (print 2) (print 3))
      123-> 1
      
      (prog2 'any1 'any2 . prg) -> any2
      Executes all arguments, and returns the result of the second expression any2. See also nil, t, prog and prog1.
      
      : (prog2 (print 1) (print 2) (print 3))
      123-> 2
      
      (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var
      Fetches a property for a property key sym from a symbol. That symbol is sym1 (if no other arguments are given), or a symbol found by applying the get algorithm to sym1|lst and the following arguments. The property (the cons pair, not just its value) is returned, suitable for direct (destructive) manipulations with functions expecting a var argument. See also ::.
      
      : (put 'X 'cnt 0)
      -> 0
      : (prop 'X 'cnt)
      -> (0 . cnt)
      : (inc (prop 'X 'cnt))        # Directly manipulate the property value
      -> 1
      : (get 'X 'cnt)
      -> 1
      
      (protect . prg) -> any
      Executes prg, and returns the result of the last expression. If a signal is received during that time, its handling will be delayed until the execution of prg is completed. See also alarm, *Hup, *Sig[12] and kill.
      
      : (protect (journal "db1.log" "db2.log"))
      -> T
      
      (prove 'lst ['lst]) -> lst
      The Pilog interpreter. Tries to prove the query list in the first argument, and returns an association list of symbol-value pairs, or NIL if not successful. The query list is modified as a side effect, allowing subsequent calls to prove for further results. The optional second argument may contain a list of symbols; in that case the successful matches of rules defined for these symbols will be traced. See also goal, -> and unify.
      
      : (prove (goal '((equal 3 3))))
      -> T
      : (prove (goal '((equal 3 @X))))
      -> ((@X . 3))
      : (prove (goal '((equal 3 4))))
      -> NIL
      
      (prune ['cnt])
      Optimizes memory usage by pruning in-memory nodes of database trees. Typically called repeatedly during bulk data imports. If cnt is NIL, further pruning will be disabled. Otherwise, all nodes which have not been accessed (with fetch or store) for cnt calls to prune will be wiped. See also lieu.
      
      (in File1
         (while (someData)
            (new T '(+Cls1) ..)
            (at (0 . 10000) (commit) (prune 100)) ) )
      (in File2
         (while (moreData)
            (new T '(+Cls2) ..)
            (at (0 . 10000) (commit) (prune 100)) ) )
      (commit)
      (prune)
      
      (push 'var 'any ..) -> any
      Implements a stack using a list in var. The any arguments are cons'ed in front of the value list. See also push1, pop, queue and fifo.
      
      : (push 'S 3)              # Use the VAL of 'S' as a stack
      -> 3
      : S
      -> (3)
      : (push 'S 2)
      -> 2
      : (push 'S 1)
      -> 1
      : S
      -> (1 2 3)
      : (push S 999)             # Now use the CAR of the list in 'S'
      -> 999
      : (push S 888 777)
      -> 777
      : S
      -> ((777 888 999 . 1) 2 3)
      
      (push1 'var 'any ..) -> any
      Maintains a unique list in var. Each any argument is cons'ed in front of the value list only if it is not already a member of that list. See also push, pop and queue.
      
      : (push1 'S 1 2 3)
      -> 3
      : S
      -> (3 2 1)
      : (push1 'S 2 4)
      -> 4
      : S
      -> (4 3 2 1)
      
      (put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any
      Stores a new value any for a property key sym (or in the symbol value for zero) in a symbol. That symbol is sym1 (if no other arguments are given), or a symbol found by applying the get algorithm to sym1|lst and the following arguments. See also =:.
      
      : (put 'X 'a 1)
      -> 1
      : (get 'X 'a)
      -> 1
      : (prop 'X 'a)
      -> (1 . a)
      
      : (setq L '(A B C))
      -> (A B C)
      : (setq B 'D)
      -> D
      : (put L 2 0 'p 5)  # Store '5' under the 'p' propery of the value of 'B'
      -> 5
      : (getl 'D)
      -> ((5 . p))
      
      (put! 'obj 'sym 'any) -> any
      Transaction wrapper function for put. Note that for setting property values of entities typically the put!> message is used. See also new!, set! and inc!.
      
      (put! Obj 'cnt 0)  # Setting a property of a non-entity object
      
      (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst
      Stores a complete new property list lst in a symbol. That symbol is sym1 (if no other arguments are given), or a symbol found by applying the get algorithm to sym1|lst1 and the following arguments. All previously defined properties for that symbol are lost. See also getl and maps.
      
      : (putl 'X '((123 . a) flg ("Hello" . b)))
      -> ((123 . a) flg ("Hello" . b))
      : (get 'X 'a)
      -> 123
      : (get 'X 'b)
      -> "Hello"
      : (get 'X 'flg)
      -> T
      
      (pwd) -> sym
      Returns the path to the current working directory. See also dir and cd.
      
      : (pwd)
      -> "/home/app/"
      
      picolisp-3.1.5.2.orig/doc/refQ.html0000644000000000000000000000577612265263724015517 0ustar rootroot Q

      Q

      (qsym . sym) -> lst
      Returns a cons pair of the value and property list of sym. See also quote, val and getl.
      
      : (setq A 1234)
      -> 1234
      : (put 'A 'a 1)
      -> 1
      : (put 'A 'b 2)
      -> 2
      : (put 'A 'f T)
      -> T
      : (qsym . A)
      -> (1234 f (2 . b) (1 . a))
      
      (quote . any) -> any
      Returns any unevaluated. The reader recognizes the single quote char ' as a macro for this function. See also lit.
      
      : 'a
      -> a
      : '(foo a b c)
      -> (foo a b c)
      : (quote (quote (quote a)))
      -> ('('(a)))
      
      (query 'lst ['lst]) -> flg
      Handles an interactive Pilog query. The two lst arguments are passed to prove. query displays each result, waits for console input, and terminates when a non-empty line is entered. See also ?, pilog and solve.
      
      : (query (goal '((append @X @Y (a b c)))))
       @X=NIL @Y=(a b c)
       @X=(a) @Y=(b c).   # Stop
      -> NIL
      
      (queue 'var 'any) -> any
      Implements a queue using a list in var. The any argument is (destructively) concatenated to the end of the value list. See also push, pop and fifo.
      
      : (queue 'A 1)
      -> 1
      : (queue 'A 2)
      -> 2
      : (queue 'A 3)
      -> 3
      : A
      -> (1 2 3)
      : (pop 'A)
      -> 1
      : A
      -> (2 3)
      
      (quit ['any ['any]])
      Stops current execution. If no arguments are given, all pending finally expressions are executed and control is returned to the top level read-eval-print loop. Otherwise, an error handler is entered. The first argument can be some error message, and the second might be the reason for the error. See also Error Handling.
      
      : (de foo (X) (quit "Sorry, my error" X))
      -> foo
      : (foo 123)                                  # 'X' is bound to '123'
      123 -- Sorry, my error                       # Error entered
      ? X                                          # Inspect 'X'
      -> 123
      ?                                            # Empty line: Exit
      :
      
      picolisp-3.1.5.2.orig/doc/refR.html0000644000000000000000000005736412265263724015520 0ustar rootroot R

      R

      *Run
      This global variable can hold a list of prg expressions which are used during key, sync, wait and listen. The first element of each expression must either be a positive number (thus denoting a file descriptor to wait for) or a negative number (denoting a timeout value in milliseconds (in that case another number must follow to hold the remaining time)). A select system call is performed with these values, and the corresponding prg body is executed when input data are available or when a timeout occurred. See also task.
      
      : (de *Run (-2000 0 (println '2sec)))     # Install 2-sec-timer
      -> *Run
      : 2sec                                    # Prints "2sec" every 2 seconds
      2sec
      2sec
                                                # (Ctrl-D) Exit
      $
      
      +Ref
      Prefix class for maintaining non-unique indexes to +relations, a subclass of +index. Accepts an optional argument for a +Hook attribute. See also Database.
      
      (rel tel (+Fold +Ref +String))  # Phone number with folded, non-unique index
      
      +Ref2
      Prefix class for maintaining a secondary ("backing") index to +relations. Can only be used as a prefix class to +Key or +Ref. It maintains an index in the current (sub)class, in addition to that in one of the superclasses, to allow (sub)class-specific queries. See also Database.
      
      (class +Ord +Entity)             # Order class
      (rel nr (+Need +Key +Number))    # Order number
      ...
      (class +EuOrd +Ord)              # EU-specific order subclass
      (rel nr (+Ref2 +Key +Number))    # Order number with backing index
      
      +relation
      Abstract base class of all database releations. Relation objects are usually defined with rel. The class hierarchy includes the classes +Any, +Bag, +Bool, +Number, +Date, +Time, +Symbol, +String, +Link, +Joint and +Blob, and the prefix classes +Hook, +Hook2, +index, +Key, +Ref, +Ref2, +Idx, +IdxFold, +Sn, +Fold, +Aux, +UB, +Dep, +List, +Need, +Mis and +Alt. See also Database and +Entity.

      Messages to relation objects include

      
      mis> (Val Obj)       # Return error if mismatching type or value
      has> (Val X)         # Check if the value is present
      put> (Obj Old New)   # Put new value
      rel> (Obj Old New)   # Maintain relational strutures
      lose> (Obj Val)      # Delete relational structures
      keep> (Obj Val)      # Restore deleted relational structures
      zap> (Obj Val)       # Clean up relational structures
      
      (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg
      Returns a pseudo random number in the range cnt1 .. cnt2 (or -2147483648 .. +2147483647 if no arguments are given). If the argument is T, a boolean value flg is returned. See also seed.
      
      : (rand 3 9)
      -> 3
      : (rand 3 9)
      -> 7
      
      (range 'num1 'num2 ['num3]) -> lst
      Produces a list of numbers in the range num1 through num2. When num3 is non-NIL), it is used to increment num1 (if it is smaller than num2) or to decrement num1 (if it is greater than num2). See also need.
      
      : (range 1 6)
      -> (1 2 3 4 5 6)
      : (range 6 1)
      -> (6 5 4 3 2 1)
      : (range -3 3)
      -> (-3 -2 -1 0 1 2 3)
      : (range 3 -3 2)
      -> (3 1 -1 -3)
      
      range/3
      Pilog predicate that succeeds if the first argument is in the range of the result of applying the get algorithm to the following arguments. Typically used as filter predicate in select/3 database queries. See also Comparing, isa/2, same/3, bool/3, head/3, fold/3, part/3 and tolr/3.
      
      : (?
         @Nr (1 . 5)  # Numbers between 1 and 5
         @Nm "part"
         (select (@Item)
            ((nr +Item @Nr) (nm +Item @Nm))
            (range @Nr @Item nr)
            (part @Nm @Item nm) ) )
       @Nr=(1 . 5) @Nm="part" @Item={3-1}
       @Nr=(1 . 5) @Nm="part" @Item={3-2}
      -> NIL
      
      (rank 'any 'lst ['flg]) -> lst
      Searches a ranking list. lst should be sorted. Returns the element from lst with a maximal CAR less or equal to any (if flg is NIL), or with a minimal CAR greater or equal to any (if flg is non-NIL), or NIL if no match is found. See also assoc and Comparing.
      
      : (rank 0 '((1 . a) (100 . b) (1000 . c)))
      -> NIL
      : (rank 50 '((1 . a) (100 . b) (1000 . c)))
      -> (1 . a)
      : (rank 100 '((1 . a) (100 . b) (1000 . c)))
      -> (100 . b)
      : (rank 300 '((1 . a) (100 . b) (1000 . c)))
      -> (100 . b)
      : (rank 9999 '((1 . a) (100 . b) (1000 . c)))
      -> (1000 . c)
      : (rank 50 '((1000 . a) (100 . b) (1 . c)) T)
      -> (100 . b)
      
      (raw ['flg]) -> flg
      Console mode control function. When called without arguments, it returns the current console mode (NIL for "cooked mode"). Otherwise, the console is set to the new state. See also key.
      
      $ pil
      : (raw)
      -> NIL
      $ pil +
      : (raw)
      -> T
      
      (rc 'sym 'any1 ['any2]) -> any
      Fetches a value from a resource file sym, or stores a value any2 in that file, using a key any1. All values are stored in a list in the file, using assoc. During the whole operation, the file is exclusively locked with ctl.
      
      : (info "a.rc")               # File exists?
      -> NIL                        # No
      : (rc "a.rc" 'a 1)            # Store 1 for 'a'
      -> 1
      : (rc "a.rc" 'b (2 3 4))      # Store (2 3 4) for 'b'
      -> (2 3 4)
      : (rc "a.rc" 'c 'b)           # Store 'b' for 'c'
      -> b
      : (info "a.rc")               # Check file
      -> (28 733124 . 61673)
      : (in "a.rc" (echo))          # Display it
      ((c . b) (b 2 3 4) (a . 1))
      -> T
      : (rc "a.rc" 'c)              # Fetch value for 'c'
      -> b
      : (rc "a.rc" @)               # Fetch value for 'b'
      -> (2 3 4)
      
      (rd ['sym]) -> any
      (rd 'cnt) -> num | NIL
      Binary read: Reads one item from the current input channel in encoded binary format. When called with a cnt argument (second form), that number of raw bytes (in big endian format if cnt is positive, otherwise little endian) is read as a single number. Upon end of file, if the sym argument is given, it is returned, otherwise NIL. See also pr, tell, hear and wr.
      
      : (out "x" (pr 'abc "EOF" 123 "def"))
      -> "def"
      : (in "x" (rd))
      -> abc
      : (in "x"
         (make
            (use X
               (until (== "EOF" (setq X (rd "EOF")))  # '==' detects end of file
                  (link X) ) ) ) )
      -> (abc "EOF" 123 "def")  # as opposed to reading a symbol "EOF"
      
      : (in "/dev/urandom" (rd 20))
      -> 396737673456823753584720194864200246115286686486
      
      (read ['sym1 ['sym2]]) -> any
      Reads one item from the current input channel. NIL is returned upon end of file. When called without arguments, an arbitrary Lisp expression is read. Otherwise, a token (a number, an internal symbol, a transient symbol (for punctuation), or a list of symbols (for a string)) is read. In that case, sym1 specifies which set of characters to accept for continuous symbol names (in addition to the standard alphanumerical characters), and sym2 an optional comment character. See also any, str, line, skip and eof.
      
      : (list (read) (read) (read))    # Read three things from console
      123                              # a number
      abcd                             # a symbol
      (def                             # and a list
      ghi
      jkl
      )
      -> (123 abcd (def ghi jkl))
      : (make (while (read "_" "#") (link @)))
      abc = def_ghi("xyz"+-123) # Comment
      NIL
      -> (abc "=" def_ghi "(" ("x" "y" "z") "+" "-" 123 ")")
      
      (recur fun) -> any
      (recurse ..) -> any
      Implements anonymous recursion, by defining the function recurse on the fly. During the execution of fun, the symbol recurse is bound to the function definition fun. See also let and lambda.
      
      : (de fibonacci (N)
         (when (lt0 N)
            (quit "Bad fibonacci" N) )
         (recur (N)
            (if (> 2 N)
               1
               (+
                  (recurse (dec N))
                  (recurse (- N 2)) ) ) ) )
      -> fibonacci
      : (fibonacci 22)
      -> 28657
      : (fibonacci -7)
      -7 -- Bad fibonacci
      
      (redef sym . fun) -> sym
      Redefines sym in terms of itself. The current definition is saved in a new symbol, which is substituted for each occurrence of sym in fun, and which is also returned. See also de, undef, daemon and patch.
      
      : (de hello () (prinl "Hello world!"))
      -> hello
      : (pp 'hello)
      (de hello NIL
         (prinl "Hello world!") )
      -> hello
      
      : (redef hello (A B)
         (println 'Before A)
         (prog1 (hello) (println 'After B)) )
      -> "hello"
      : (pp 'hello)
      (de hello (A B)
         (println 'Before A)
         (prog1 ("hello") (println 'After B)) )
      -> hello
      : (hello 1 2)
      Before 1
      Hello world!
      After 2
      -> "Hello world!"
      
      : (redef * @
         (msg (rest))
         (pass *) )
      -> "*"
      : (* 1 2 3)
      (1 2 3)
      -> 6
      
      : (redef + @
         (pass (ifn (num? (next)) pack +) (arg)) )
      -> "+"
      : (+ 1 2 3)
      -> 6
      : (+ "a" 'b '(c d e))
      -> "abcde"
      
      
      (rel var lst [any ..]) -> any
      Defines a relation for var in the current class *Class, using lst as the list of classes for that relation, and possibly additional arguments any for its initialization. See also Database, class, extend, dm and var.
      
      (class +Person +Entity)
      (rel nm  (+List +Ref +String))            # Names
      (rel tel (+Ref +String))                  # Telephone
      (rel adr (+Joint) prs (+Address))         # Address
      
      (class +Address +Entity)
      (rel cit (+Need +Hook +Link) (+City))     # City
      (rel str (+List +Ref +String) cit)        # Street
      (rel prs (+List +Joint) adr (+Person))    # Inhabitants
      
      (class +City +Entity)
      (rel nm  (+List +Ref +String))            # Zip / Names
      
      (release 'sym) -> NIL
      Releases the mutex represented by the file 'sym'. This is the reverse operation of acquire.
      
      : (release "sema1")
      -> NIL
      
      remote/2
      Pilog predicate for remote database queries. It takes a list and an arbitrary number of clauses. The list should contain a Pilog variable for the result in the CAR, and a list of resources in the CDR. The clauses will be evaluated on remote machines according to these resources. Each resource must be a cons pair of two functions, an "out" function in the CAR, and an "in" function in the CDR. See also *Ext, select/3 and db/3.
      
      (setq *Ext           # Set up external offsets
         (mapcar
            '((@Host @Ext)
               (cons @Ext
                  (curry (@Host @Ext (Sock)) (Obj)
                     (when (or Sock (setq Sock (connect @Host 4040)))
                        (ext @Ext
                           (out Sock (pr (cons 'qsym Obj)))
                           (prog1 (in Sock (rd))
                              (unless @
                                 (close Sock)
                                 (off Sock) ) ) ) ) ) ) )
            '("localhost")
            '(20) ) )
      
      (de rsrc ()  # Simple resource handler, ignoring errors or EOFs
         (extract
            '((@Ext Host)
               (let? @Sock (connect Host 4040)
                  (cons
                     (curry (@Ext @Sock) (X)  # out
                        (ext @Ext (out @Sock (pr X))) )
                     (curry (@Ext @Sock) ()  # in
                        (ext @Ext (in @Sock (rd))) ) ) ) )
            '(20)
            '("localhost") ) )
      
      : (?
         @Nr (1 . 3)
         @Sup 2
         @Rsrc (rsrc)
         (remote (@Item . @Rsrc)
            (db nr +Item @Nr @Item)
            (val @Sup @Item sup nr) )
         (show @Item) )
      {L-2} (+Item)
         pr 1250
         inv 100
         sup {K-2}
         nm Spare Part
         nr 2
       @Nr=(1 . 3) @Sup=2 @Rsrc=((((X) (ext 20 (out 16 (pr X)))) NIL (ext 20 (in 16 (rd))))) @Item={L-2}
      -> NIL
      
      (remove 'cnt 'lst) -> lst
      Removes the element at position cnt from lst. This is a non-destructive operation. See also insert, place, append, delete and replace.
      
      : (remove 3 '(a b c d e))
      -> (a b d e)
      : (remove 1 '(a b c d e))
      -> (b c d e)
      : (remove 9 '(a b c d e))
      -> (a b c d e)
      
      (repeat) -> lst
      Makes the current Pilog definition "tail recursive", by closing the previously defined rules in the definition's T property to a circular list. See also repeat/0 and be.
      
      (be a (1))     # Define three facts
      (be a (2))
      (be a (3))
      (repeat)       # Unlimited supply
      
      : (? (a @N))
       @N=1
       @N=2
       @N=3
       @N=1
       @N=2
       @N=3.         # Stop
      -> NIL
      
      repeat/0
      Pilog predicate that always succeeds, also on backtracking. See also repeat and true/0.
      
      : (be integer (@I)   # Generate unlimited supply of integers
         (^ @C (box 0))    # Init to zero
         (repeat)          # Repeat from here
         (^ @I (inc (-> @C))) )
      -> integer
      
      : (? (integer @X))
       @X=1
       @X=2
       @X=3
       @X=4.               # Stop
      -> NIL
      
      (replace 'lst 'any1 'any2 ..) -> lst
      Replaces in lst all occurrences of any1 with any2. For optional additional argument pairs, this process is repeated. This is a non-destructive operation. See also append, delete, insert, remove and place.
      
      : (replace '(a b b a) 'a 'A)
      -> (A b b A)
      : (replace '(a b b a) 'b 'B)
      -> (a B B a)
      : (replace '(a b b a) 'a 'B 'b 'A)
      -> (B A A B)
      
      (request 'typ 'var ['hook] 'val ..) -> obj
      Returns a database object. If a matching object cannot be found (using db), a new object of the given type is created (using new). See also obj.
      
      : (request '(+Item) 'nr 2)
      -> {3-2}
      
      (rest) -> lst
      Can only be used inside functions with a variable number of arguments (with @). Returns the list of all remaining arguments from the internal list. See also args, next, arg and pass.
      
      : (de foo @ (println (rest)))
      -> foo
      : (foo 1 2 3)
      (1 2 3)
      -> (1 2 3)
      
      (retract) -> lst
      Removes a Pilog fact or rule. See also be, clause, asserta and assertz.
      
      : (be a (1))
      -> a
      : (be a (2))
      -> a
      : (be a (3))
      -> a
      
      : (retract '(a (2)))
      -> (((1)) ((3)))
      
      :  (? (a @N))
       @N=1
       @N=3
      -> NIL
      
      retract/1
      Pilog predicate that removes a fact or rule. See also retract, asserta/1 and assertz/1.
      
      : (be a (1))
      -> a
      : (be a (2))
      -> a
      : (be a (3))
      -> a
      
      : (? (retract (a 2)))
      -> T
      : (rules 'a)
      1 (be a (1))
      2 (be a (3))
      -> a
      
      (reverse 'lst) -> lst
      Returns a reversed copy of lst. See also flip.
      
      : (reverse (1 2 3 4))
      -> (4 3 2 1)
      
      (rewind) -> flg
      Sets the file position indicator for the current output stream to the beginning of the file, and truncates the file length to zero. Returns T when successful. See also flush.
      
      : (out "a" (prinl "Hello world"))
      -> "Hello world"
      : (in "a" (echo))
      Hello world
      -> T
      : (info "a")
      -> (12 733216 . 53888)
      : (out "a" (rewind))
      -> T
      : (info "a")
      -> (0 733216 . 53922)
      
      (rollback) -> flg
      Cancels a transaction, by discarding all modifications of external symbols. See also commit.
      
      : (pool "db")
      -> T
      # .. Modify external objects ..
      : (rollback)            # Rollback
      -> T
      
      (root 'tree) -> (num . sym)
      Returns the root of a database index tree, with the number of entries in num, and the base node in sym. See also tree.
      
      : (root (tree 'nr '+Item))
      -> (7 . {7-1})
      
      (rot 'lst ['cnt]) -> lst
      Rotate: The contents of the cells of lst are (destructively) shifted right, and the value from the last cell is stored in the first cell. Without the optional cnt argument, the whole list is rotated, otherwise only the first cnt elements. See also flip .
      
      : (rot (1 2 3 4))             # Rotate all four elements
      -> (4 1 2 3)
      : (rot (1 2 3 4 5 6) 3)       # Rotate only the first three elements
      -> (3 1 2 4 5 6)
      
      (round 'num1 'num2) -> sym
      Formats a number num1 with num2 decimal places, according to the current scale *Scl. num2 defaults to 3. See also Numbers and format.
      
      : (scl 4)               # Set scale to 4
      -> 4
      : (round 123456)        # Format with three decimal places
      -> "12.346"
      : (round 123456 2)      # Format with two decimal places
      -> "12.35"
      : (format 123456 *Scl)  # Format with full precision
      -> "12.3456"
      
      (rules 'sym ..) -> sym
      Prints all rules defined for the sym arguments. See also Pilog and be.
      
      : (rules 'member 'append)
      1 (be member (@X (@X . @)))
      2 (be member (@X (@ . @Y)) (member @X @Y))
      1 (be append (NIL @X @X))
      2 (be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z))
      -> append
      
      (run 'any ['cnt ['lst]]) -> any
      If any is an atom, run behaves like eval. Otherwise any is a list, which is evaluated in sequence. The last result is returned. If a binding environment offset cnt is given, that evaluation takes place in the corresponding environment, and an optional lst of excluded symbols can be supplied. See also up.
      
      : (run '((println (+ 1 2 3)) (println 'OK)))
      6
      OK
      -> OK
      
      picolisp-3.1.5.2.orig/doc/refS.html0000644000000000000000000010537312265263724015513 0ustar rootroot S

      S

      *Scl
      A global variable holding the current fixpoint input scale. See also Numbers and scl.
      
      : (str "123.45")  # Default value of '*Scl' is 0
      -> (123)
      : (setq *Scl 3)
      -> 3
      : (str "123.45")
      -> (123450)
      
      : 123.4567
      -> 123457
      : 12.3456
      -> 12346
      
      *Sig1
      *Sig2
      Global variables holding (possibly empty) prg bodies, which will be executed when a SIGUSR1 signal (or a SIGUSR2 signal, respectively) is sent to the current process. See also alarm, sigio and *Hup.
      
      : (de *Sig1 (msg 'SIGUSR1))
      -> *Sig1
      
      *Solo
      A global variable indicating exclusive database access. Its value is 0 initially, set to T (or NIL) during cooperative database locks when lock is successfully called with a NIL (or non-NIL) argument. See also *Zap.
      
      : *Solo
      -> 0
      : (lock *DB)
      -> NIL
      : *Solo
      -> NIL
      : (rollback)
      -> T
      : *Solo
      -> 0
      : (lock)
      -> NIL
      : *Solo
      -> T
      : (rollback)
      -> T
      : *Solo
      -> T
      
      +Sn
      Prefix class for maintaining indexes according to a modified soundex algorithm, for tolerant name searches, to +String relations. Typically used in combination with the +Idx prefix class. See also Database.
      
      (rel nm (+Sn +Idx +String))  # Name
      
      +String
      Class for string (transient symbol) relations, a subclass of +Symbol. Accepts an optional argument for the string length (currently not used). See also Database.
      
      (rel nm (+Sn +Idx +String))  # Name, indexed by soundex and substrings
      
      +Swap
      Prefix class for +relations where the data are to be stored in the value of a separate external symbol instead of the relation's object. Typically used for data which are relatively large and/or rarely accessed. Doesn't work with bidirectional relations (+Joint or +index). See also Database.
      
      (rel pw (+Swap +String))               # Password
      (rel nr (+Swap +List +Number))         # List of bignums
      
      +Symbol
      Class for symbolic relations, a subclass of +relation. Objects of that class typically maintain internal symbols, as opposed to the more often-used +String for transient symbols. See also Database.
      
      (rel perm (+List +Symbol))  # Permission list
      
      same/3
      Pilog predicate that succeeds if the first argument matches the result of applying the get algorithm to the following arguments. Typically used as filter predicate in select/3 database queries. See also isa/2, bool/3, range/3, head/3, fold/3, part/3 and tolr/3.
      
      : (?
         @Nr 2
         @Nm "Spare"
         (select (@Item)
            ((nr +Item @Nr) (nm +Item @Nm))
            (same @Nr @Item nr)
            (head @Nm @Item nm) ) )
       @Nr=2 @Nm="Spare" @Item={3-2}
      
      (scan 'tree ['fun] ['any1] ['any2] ['flg])
      Scans through a database tree by applying fun to all key-value pairs. fun should be a function accepting two arguments for key and value. It defaults to println. any1 and any2 may specify a range of keys. If any2 is greater than any1, the traversal will be in opposite direction. Note that the keys need not to be atomic, depending on the application's index structure. If flg is non-NIL, partial keys are skipped. See also tree, iter, init and step.
      
      : (scan (tree 'nm '+Item))
      ("ASLRSNSTRSTN" {3-3} . T) {3-3}
      ("Additive" {3-4}) {3-4}
      ("Appliance" {3-6}) {3-6}
      ("Auxiliary Construction" . {3-3}) {3-3}
      ("Construction" {3-3}) {3-3}
      ("ENNSNNTTTF" {3-4} . T) {3-4}
      ("Enhancement Additive" . {3-4}) {3-4}
      ("Fittings" {3-5}) {3-5}
      ("GTSTFLNS" {3-6} . T) {3-6}
      ("Gadget Appliance" . {3-6}) {3-6}
      ...
      
      : (scan (tree 'nm '+Item) println NIL T T)  # 'flg' is non-NIL
      ("Auxiliary Construction" . {3-3}) {3-3}
      ("Enhancement Additive" . {3-4}) {3-4}
      ("Gadget Appliance" . {3-6}) {3-6}
      ("Main Part" . {3-1}) {3-1}
      ("Metal Fittings" . {3-5}) {3-5}
      ("Spare Part" . {3-2}) {3-2}
      ("Testartikel" . {3-8}) {3-8}
      -> {7-6}
      
      (scl 'num [. prg]) -> num
      If prg is given, it binds *Scl dynamically to num during the execution of prg. Otherwise, it sets *Scl globally to num. See also Numbers.
      
      : (scl 0)
      -> 0
      : (str "123.45")
      -> (123)
      : (scl 1)
      -> 1
      : (read)
      123.45
      -> 1235
      : (scl 3)
      -> 3
      : (str "123.45")
      -> (123450)
      : (scl 1 (str "123.45"))
      -> (1235)
      : *Scl
      -> 3
      
      (script 'any ..) -> any
      The first any argument is loaded, with the remaining arguments passed as variable arguments. They can be accessed with next, arg, args and rest. With that, the syntax in the script is the same as that in the body of a function with variable arguments (see lambda expressions, "when the CAR is the symbol @").
      
      $ cat x
      (* (next) (next))
      
      $ pil +
      : (script "x" 3 4)
      -> 12
      
      (sect 'lst 'lst) -> lst
      Returns the intersection of the lst arguments. See also diff.
      
      : (sect (1 2 3 4) (3 4 5 6))
      -> (3 4)
      : (sect (1 2 3) (4 5 6))
      -> NIL
      
      (seed 'any) -> cnt
      Initializes the random generator's seed, and returns a pseudo random number in the range -2147483648 .. +2147483647. See also rand and hash.
      
      : (seed "init string")
      -> 2015582081
      : (rand)
      -> -706917003
      : (rand)
      -> 1224196082
      
      : (seed (time))
      -> 128285383
      
      (seek 'fun 'lst ..) -> lst
      Applies fun to lst and all successive CDRs, until non-NIL is returned. Returns the tail of lst starting with that element, or NIL if fun did not return non-NIL for any element of lst. When additional lst arguments are given, they are passed to fun in the same way. See also find, pick.
      
      : (seek '((X) (> (car X) 9)) (1 5 8 12 19 22))
      -> (12 19 22)
      
      (select [var ..] cls [hook|T] [var val ..]) -> obj | NIL
      (Debug mode only) Interactive database function, loosely modelled after the SQL 'SELECT' command. A (limited) front-end to the Pilog select/3 predicate. When called with only a cls argument, select steps through all objects of that class, and shows their complete contents (this is analog to 'SELECT * from CLS'). If cls is followed by attribute/value specifications, the search is limited to these values (this is analog to 'SELECT * from CLS where VAR = VAL'). If between the select function and cls one or several attribute names are supplied, only these attribute (instead of the full show) are printed. These attribute specifications may also be lists, then the get algorithm will be used to retrieve related data. See also update, Database and Pilog.
      
      : (select +Item)                       # Show all items
      {3-1} (+Item)
         nr 1
         pr 29900
         inv 100
         sup {2-1}
         nm "Main Part"
      
      {3-2} (+Item)
         nr 2
         pr 1250
         inv 100
         sup {2-2}
         nm "Spare Part"
      .                                      # Stop
      -> {3-2}
      
      : (select +Item nr 3)                  # Show only item 3
      {3-3} (+Item)
         nr 3
         sup {2-1}
         pr 15700
         nm "Auxiliary Construction"
         inv 100
      .                                      # Stop
      -> {3-3}
      
      # Show selected attributes for items 3 through 3
      : (select nr nm pr (sup nm) +Item nr (3 . 5))
      3 "Auxiliary Construction" 157.00 "Active Parts Inc." {3-3}
      4 "Enhancement Additive" 9.99 "Seven Oaks Ltd." {3-4}
      5 "Metal Fittings" 79.80 "Active Parts Inc." {3-5}
      -> NIL
      
      select/3
      Pilog database predicate that allows combined searches over +index and other relations. It takes a list of Pilog variables, a list of generator clauses, and an arbitrary number of filter clauses. The functionality is described in detail in The 'select' Predicate. See also db/3, isa/2, same/3, bool/3, range/3, head/3, fold/3, part/3, tolr/3 and remote/2.
      
      : (?
         @Nr (2 . 5)          # Select all items with numbers between 2 and 5
         @Sup "Active"        # and suppliers matching "Active"
         (select (@Item)                                  # Bind results to '@Item'
            ((nr +Item @Nr) (nm +CuSu @Sup (sup +Item)))  # Generator clauses
            (range @Nr @Item nr)                          # Filter clauses
            (part @Sup @Item sup nm) ) )
       @Nr=(2 . 5) @Sup="Active" @Item={3-3}
       @Nr=(2 . 5) @Sup="Active" @Item={3-5}
      -> NIL
      
      (send 'msg 'obj ['any ..]) -> any
      Sends the message msg to the object obj, optionally with arguments any. If the message cannot be located in obj, its classes and superclasses, an error "Bad message" is issued. See also OO Concepts, try, method, meth, super and extra.
      
      : (send 'stop> Dlg)  # Equivalent to (stop> Dlg)
      -> NIL
      
      (seq 'cnt|sym1) -> sym | NIL
      Sequential single step: Returns the first external symbol in the cnt'th database file, or the next external symbol following sym1 in the database, or NIL when the end of the database is reached. See also free.
      
      : (pool "db")
      -> T
      : (seq *DB)
      -> {2}
      : (seq @)
      -> {3}
      
      (set 'var 'any ..) -> any
      Stores new values any in the var arguments. See also setq, val, con and def.
      
      : (set 'L '(a b c)  (cdr L) '999)
      -> 999
      : L
      -> (a 999 c)
      
      (set! 'obj 'any) -> any
      Transaction wrapper function for set. Note that for setting the value of entities typically the set!> message is used. See also new!, put! and inc!.
      
      (set! Obj (* Count Size))  # Setting a non-entity object to a numeric value
      
      (setq var 'any ..) -> any
      Stores new values any in the var arguments. See also set, val and def.
      
      : (setq  A 123  B (list A A))  # Set 'A' to 123, then 'B' to (123 123)
      -> (123 123)
      
      (show 'any ['sym|cnt ..]) -> any
      Shows the name, value and property list of a symbol found by applying the get algorithm to any and the following arguments. See also edit and view.
      
      : (setq A 123456)
      -> 123456
      : (put 'A 'x 1)
      -> 1
      : (put 'A 'lst (9 8 7))
      -> (9 8 7)
      : (put 'A 'flg T)
      -> T
      
      : (show 'A)
      A 123456
         flg
         lst (9 8 7)
         x 1
      -> A
      
      : (show 'A 'lst 2)
      -> 8
      
      show/1
      Pilog predicate that always succeeds, and shows the name, value and property list of the argument symbol. See also show.
      
      : (? (db nr +Item 2 @Item) (show @Item))
      {3-2} (+Item)
         nm "Spare Part"
         nr 2
         pr 1250
         inv 100
         sup {2-2}
       @Item={3-2}
      -> NIL
      
      (sigio 'cnt . prg) -> cnt
      Sets a signal handler prg for SIGIO on the file descriptor cnt. Returns the file descriptor. See also alarm, *Hup and *Sig[12].
      
      # First session
      : (sigio (setq *SigSock (port T 4444))  # Register signal handler at UDP port
         (while (udp *SigSock)                # Queue all received data
            (fifo '*SigQueue @) ) )
      -> 3
      
      # Second session
      : (for I 7 (udp "localhost" 4444 I))  # Send numbers to first session
      
      # First session
      : (fifo '*SigQueue)
      -> 1
      : (fifo '*SigQueue)
      -> 2
      
      (size 'any) -> cnt
      Returns the "size" of any. For numbers this is the number of bytes needed for the value, for external symbols it is the number of bytes it would occupy in the database, for other symbols it is the number of bytes occupied by the UTF-8 representation of the name, and for lists it is the total number of cells in this list and all its sublists. See also length and bytes.
      
      : (size "abc")
      -> 3
      : (size "äbc")
      -> 4
      : (size 127)  # One byte
      -> 1
      : (size 128)  # Two bytes (eight bits plus sign bit!)
      -> 2
      : (size (1 (2) 3))
      -> 4
      : (size (1 2 3 .))
      -> 3
      
      (skip ['any]) -> sym
      Skips all whitespace (and comments if any is given) in the input stream. Returns the next available character, or NIL upon end of file. See also peek and eof.
      
      $ cat a
      # Comment
      abcd
      $ pil +
      : (in "a" (skip "#"))
      -> "a"
      
      (solve 'lst [. prg]) -> lst
      Evaluates a Pilog query and, returns the list of result sets. If prg is given, it is executed for each result set, with all Pilog variables bound to their matching values, and returns a list of the results. See also pilog, ?, goal and prove.
      
      : (solve '((append @X @Y (a b c))))
      -> (((@X) (@Y a b c)) ((@X a) (@Y b c)) ((@X a b) (@Y c)) ((@X a b c) (@Y)))
      
      : (solve '((append @X @Y (a b c))) @X)
      -> (NIL (a) (a b) (a b c))
      
      (sort 'lst ['fun]) -> lst
      Sorts lst by destructively exchanging its elements. If fun is given, it is used as a "less than" predicate for comparisons. Typically, sort is used in combination with by, giving shorter and often more efficient solutions than with the predicate function. See also Comparing, group, maxi, mini and uniq.
      
      : (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2))
      -> (NIL 1 2 3 4 a b c d (1 2 3) (a b c) (x y z) T)
      : (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2) >)
      -> (T (x y z) (a b c) (1 2 3) d c b a 4 3 2 1 NIL)
      : (by cadr sort '((1 4 3) (5 1 3) (1 2 4) (3 8 5) (6 4 5)))
      -> ((5 1 3) (1 2 4) (1 4 3) (6 4 5) (3 8 5))
      
      (space ['cnt]) -> cnt
      Prints cnt spaces, or a single space when cnt is not given. See also beep, prin and char.
      
      : (space)
       -> 1
      : (space 1)
       -> 1
      : (space 2)
        -> 2
      
      (sp? 'any) -> flg
      Returns T when the argument any is NIL, or if it is a string (symbol) that consists only of whitespace characters.
      
      : (sp? "  ")
      -> T
      : (sp? "ABC")
      -> NIL
      : (sp? 123)
      -> NIL
      
      (split 'lst 'any ..) -> lst
      Splits lst at all places containing an element any and returns the resulting list of sublists. See also stem.
      
      : (split (1 a 2 b 3 c 4 d 5 e 6) 'e 3 'a)
      -> ((1) (2 b) (c 4 d 5) (6))
      : (mapcar pack (split (chop "The quick brown fox") " "))
      -> ("The" "quick" "brown" "fox")
      
      (sqrt 'num ['flg|num]) -> num
      Returns the square root of the num argument. If flg is given and non-NIL, the result will be rounded. If in addition to that flg is a number, the first argument will be multiplied with it before doing the square root calculation. See also */.
      
      : (sqrt 64)
      -> 8
      : (sqrt 1000)
      -> 31
      : (sqrt 1000 T)
      -> 32
      : (sqrt 10000000000000000000000000000000000000000)
      -> 100000000000000000000
      
      : (scl 6)
      -> 6
      : (sqrt 2.0 1.0)
      -> 1414214
      
      (stack ['cnt]) -> cnt | (.. sym . cnt)
      (64-bit version only) Maintains the stack segment size for coroutines (the main stack segment is limited - while at least one coroutine is running - to four times that size). If called without a cnt argument, or if already one or more coroutines are running, the current size in megabytes is returned. Otherwise, the stack segment size is set to the new value (default 1 MB). The main segment's size is always four times the size of coroutine segments. If there are running coroutines, their tags will be consed in front of the size. See also heap.
      
      $ ulimit -s unlimited  &&  pil +  # Guarantee stack space
      : (stack)      # Current size
      -> 1
      : (stack 4)    # Set to 4 MB
      -> 4
      : (co 'inc (let N 0 (loop (yield (inc 'N)))))  # Create two coroutines
      -> 1
      : (co 'dec (let N 0 (loop (yield (dec 'N)))))
      -> -1
      : (stack)
      -> (dec inc . 4)
      
      (stamp ['dat 'tim]|['T]) -> sym
      Returns a date-time string in the form "YYYY-MM-DD HH:MM:SS". If dat and tim is missing, the current date and time is used. If T is passed, the current Coordinated Universal Time (UTC) is used instead. See also date and time.
      
      : (stamp)
      -> "2000-09-12 07:48:04"
      : (stamp (date) 0)
      -> "2000-09-12 00:00:00"
      : (stamp (date 2000 1 1) (time 12 0 0))
      -> "2000-01-01 12:00:00"
      
      (state 'var (sym|lst exe [. prg]) ..) -> any
      Implements a finite state machine. The variable var holds the current state as a symbolic value. When a clause is found that contains the current state in its CAR sym|lst value, and where the exe in its CADR evaluates to non-NIL, the current state will be set to that value, the body prg in the CDDR will be executed, and the result returned. T is a catch-all for any state. If no state-condition matches, NIL is returned. See also case, cond and job.
      
      : (de tst ()
         (job '((Cnt . 4))
            (state '(start)
               (start 'run
                  (printsp 'start) )
               (run (and (gt0 (dec 'Cnt)) 'run)
                  (printsp 'run) )
               (run 'stop
                  (printsp 'run) )
               (stop 'start
                  (setq Cnt 4)
                  (println 'stop) ) ) ) )
      -> tst
      : (do 12 (tst))
      start run run run run stop
      start run run run run stop
      -> stop
      : (pp 'tst)
      (de tst NIL
         (job '((Cnt . 4))
            (state '(start)
            ...
      -> tst
      : (do 3 (tst))
      start run run -> run
      : (pp 'tst)
      (de tst NIL
         (job '((Cnt . 2))
            (state '(run)
            ...
      -> tst
      
      (stem 'lst 'any ..) -> lst
      Returns the tail of lst that does not contain any of the any arguments. (stem 'lst 'any ..) is equivalent to (last (split 'lst 'any ..)). See also tail and split.
      
      : (stem (chop "abc/def\\ghi") "/" "\\")
      -> ("g" "h" "i")
      
      (step 'lst ['flg]) -> any
      Single-steps iteratively through a database tree. lst is a structure as received from init. If flg is non-NIL, partial keys are skipped. See also tree, scan, iter, leaf and fetch.
      
      : (setq Q (init (tree 'nr '+Item) 3 5))
      -> (((3 . 5) ((3 NIL . {3-3}) (4 NIL . {3-4}) (5 NIL . {3-5}) (6 NIL . {3-6}) (7 NIL . {3-8}))))
      : (get (step Q) 'nr)
      -> 3
      : (get (step Q) 'nr)
      -> 4
      : (get (step Q) 'nr)
      -> 5
      : (get (step Q) 'nr)
      -> NIL
      
      (store 'tree 'any1 'any2 ['(num1 . num2)])
      Stores a value any2 for the key any1 in a database tree. num1 is a database file number, as used in new (defaulting to 1), and num2 a database block size (defaulting to 256). When any2 is NIL, the corresponding entry is deleted from the tree. See also tree and fetch.
      
      : (store (tree 'nr '+Item) 2 '{3-2})
      
      (str 'sym ['sym1]) -> lst
      (str 'lst) -> sym
      In the first form, the string sym is parsed into a list. This mechanism is also used by load. If sym1 is given, it should specify a set of characters, and str will then return a list of tokens analog to read. The second form does the reverse operation by building a string from a list. See also any, name and sym.
      
      : (str "a (1 2) b")
      -> (a (1 2) b)
      : (str '(a "Hello" DEF))
      -> "a \"Hello\" DEF"
      : (str "a*3+b*4" "_")
      -> (a "*" 3 "+" b "*" 4)
      
      (str? 'any) -> sym | NIL
      Returns the argument any when it is a transient symbol (string), otherwise NIL. See also sym?, box? and ext?.
      
      : (str? 123)
      -> NIL
      : (str? '{ABC})
      -> NIL
      : (str? 'abc)
      -> NIL
      : (str? "abc")
      -> "abc"
      
      (strDat 'sym) -> dat
      Converts a string sym in the date format of the current locale to a date. See also expDat, $dat and datStr.
      
      : (strDat "2007-06-01")
      -> 733134
      : (strDat "01.06.2007")
      -> NIL
      : (locale "DE" "de")
      -> NIL
      : (strDat "01.06.2007")
      -> 733134
      : (strDat "1.6.2007")
      -> 733134
      
      (strip 'any) -> any
      Strips all leading quote symbols from any.
      
      : (strip 123)
      -> 123
      : (strip '''(a))
      -> (a)
      : (strip (quote quote a b c))
      -> (a b c)
      
      (struct 'num 'any 'any ..) -> any
      Creates or extracts data structures, suitable to be passed to or returned from native C functions. The first num argument should be a native value, either a scalar, or a pointer obtained by calling functions like malloc(). The second argument any is a result specification, while all following initialization items are stored in the structure pointed to by the first argument. See also Native C Calls.
      
      : (scl 2)
      -> 2
      
      ## /* We assume the following C structure */
      ## typedef struct value {
      ##    int x, y;
      ##    double a, b, c;
      ##    long z;
      ##    char nm[4];
      ## } value;
      
      # Allocate structure
      : (setq P (native "@" "malloc" 'N 44))
      -> 9204032
      
      # Store two integers, three doubles, one long, and four characters
      : (struct P 'N -7 -4 (1.0 0.11 0.22 0.33) (7 . 8) 65 66 67 0)
      -> 9204032
      
      # Extract the structure
      : (struct P '((I . 2) (1.0 . 3) N (C . 4)))
      -> ((7 4) (11 22 33) 7 ("A" "B" "C" NIL))
      
      # Do both in a single call (allowing conversions of data types)
      : (struct P
         '((I . 2) (1.0 . 3) N (C . 4))
         -7 -4 (1.0 0.11 0.22 0.33) (7 . 8) 65 66 67 0 )
      -> ((7 4) (11 22 33) 7 ("A" "B" "C" NIL))
      
      # De-allocate structure
      : (native "@" "free" NIL P)
      -> NIL
      
      (sub? 'any1 'any2) -> any2 | NIL
      Returns any2 when the string representation of any1 is a substring of the string representation of any2. See also pre?.
      
      : (sub? "def" "abcdef")
      -> T
      : (sub? "abb" "abcdef")
      -> NIL
      : (sub? NIL "abcdef")
      -> T
      
      (subr 'sym) -> num
      Converts a Lisp-function that was previously converted with expr back to a C-function.
      
      : car
      -> 67313448
      : (expr 'car)
      -> (@ (pass $385260187))
      : (subr 'car)
      -> 67313448
      : car
      -> 67313448
      
      (sum 'fun 'lst ..) -> num
      Applies fun to each element of lst. When additional lst arguments are given, their elements are also passed to fun. Returns the sum of all numeric values returned from fun.
      
      : (setq A 1  B 2  C 3)
      -> 3
      : (sum val '(A B C))
      -> 6
      : (sum * (3 4 5) (5 6 7))        # Vector dot product
      -> 74
      : (sum                           # Total size of symbol list values
         '((X)
            (and (pair (val X)) (size @)) )
         (what) )
      -> 32021
      
      (super ['any ..]) -> any
      Can only be used inside methods. Sends the current message to the current object This, this time starting the search for a method at the superclass(es) of the class where the current method was found. See also OO Concepts, extra, method, meth, send and try.
      
      (dm stop> ()         # 'stop>' method of current class
         (super)           # Call the 'stop>' method of the superclass
         ... )             # other things
      
      (swap 'var 'any) -> any
      Set the value of var to any, and return the previous value. See also xchg and set.
      
      : (setq A 7  L (1 2 3))
      -> (1 2 3)
      : (swap (cdr L) (swap 'A 'xyz))
      -> 2
      : A
      -> xyz
      : L
      -> (1 7 3)
      
      (sym 'any) -> sym
      Generate the printed representation of any into the name of a new symbol sym. This is the reverse operation of any. See also name and str.
      
      : (sym '(abc "Hello" 123))
      -> "(abc \"Hello\" 123)"
      
      (sym? 'any) -> flg
      Returns T when the argument any is a symbol. See also str?, box? and ext?.
      
      : (sym? 'a)
      -> T
      : (sym? NIL)
      -> T
      : (sym? 123)
      -> NIL
      : (sym? '(a b))
      -> NIL
      
      (symbols) -> sym
      (symbols 'sym1) -> sym2
      (symbols 'sym1 'sym ..) -> sym2
      (64-bit version only) Creates and manages namespaces of internal symbols: In the first form, the current namespace is returned. In the second form, the current namespace is set to sym1, and the previous namespace sym2 is returned. In the third form, sym1 is assigned a balanced copy of the existing namespace(s) sym, and becomes the new current namespace, returning the previous namespace sym2. If in the third form more than one sym argument is given, possibly conflicting symbols in later namespaces are not interned into sym2. See also pico, local, import, intern and load.
      
      : (symbols 'myLib 'pico)
      -> pico
      myLib: (de foo (X)
         (bar (inc X)) )
      -> foo
      myLib: (symbols 'pico)
      -> myLib
      : (pp 'foo)
      (de foo . NIL)
      -> foo
      : (pp 'myLib~foo)
      (de "foo" (X)
         ("bar" (inc X)) )
      -> "foo"
      : (symbols 'myLib)
      -> pico
      myLib: (pp 'foo)
      (de foo (X)
         (bar (inc X)) )
      -> foo
      myLib:
      
      (sync) -> flg
      Waits for pending data from all family processes. While other processes are still sending data (via the tell mechanism), a select system call is executed for all file descriptors and timers in the VAL of the global variable *Run. When used in a non-database context, (tell) should be called in the end to inform the parent process that it may grant synchronization to other processes waiting for sync. In a database context, where sync is usually called by dbSync, this is not necessary because it is done internally by commit or rollback. See also key and wait.
      
      : (or (lock) (sync))       # Ensure database consistency
      -> T                       # (numeric process-id if lock failed)
      
      (sys 'any ['any]) -> sym
      Returns or sets a system environment variable.
      
      : (sys "TERM")  # Get current value
      -> "xterm"
      : (sys "TERM" "vt100")  # Set new value
      -> "vt100"
      : (sys "TERM")
      -> "vt100"
      
      picolisp-3.1.5.2.orig/doc/refT.html0000644000000000000000000005345312265263724015515 0ustar rootroot T

      T

      *Tmp
      A global variable holding the temporary directory name created with tmp. See also *Bye.
      
      : *Bye
      -> ((saveHistory) (and *Tmp (call 'rm "-r" *Tmp)))
      : (tmp "foo" 123)
      -> "/home/app/.pil/tmp/27140/foo123"
      : *Tmp
      -> "/home/app/.pil/tmp/27140/"
      

      *Tsm
      A global variable which may hold a cons pair of two strings with escape sequences, to switch on and off an alternative transient symbol markup. If set, print will output these sequences to the console instead of the standard double quote markup characters. An easy way to switch on transient symbol markup is loading "@lib/tsm.l".
      
      : (de *Tsm "^[[4m" . "^[[24m")   # vt100 escape sequences for underline
      -> *Tsm
      : Hello world
      -> Hello world
      : (off *Tsm)
      -> NIL
      : "Hello world"                  # No underlining
      -> "Hello world"
      
      +Time
      Class for clock time values (as calculated by time), a subclass of +Number. See also Database.
      
      (rel tim (+Time))  # Time of the day
      
      T
      A global constant, evaluating to itself. T is commonly returned as the boolean value "true" (though any non-NIL values could be used). It represents the absolute maximum, as it is larger than any other object. As a property key, it is used to store Pilog clauses, and inside Pilog clauses it is the cut operator. See also NIL and and Comparing.
      
      : T
      -> T
      : (= 123 123)
      -> T
      : (get 'not T)
      -> ((@P (1 (-> @P)) T (fail)) (@P))
      
      This
      Holds the current object during method execution (see OO Concepts), or inside the body of a with statement. As it is a normal symbol, however, it can be used in normal bindings anywhere. See also isa, :, =:, :: and var:.
      
      : (with 'X (println 'This 'is This))
      This is X
      -> X
      : (put 'X 'a 1)
      -> 1
      : (put 'X 'b 2)
      -> 2
      : (put 'Y 'a 111)
      -> 111
      : (put 'Y 'b 222)
      -> 222
      : (mapcar '((This) (cons (: a) (: b))) '(X Y))
      -> ((1 . 2) (111 . 222))
      
      (t . prg) -> T
      Executes prg, and returns T. See also nil, prog, prog1 and prog2.
      
      : (t (println 'OK))
      OK
      -> T
      
      (tab 'lst 'any ..) -> NIL
      Print all any arguments in a tabular format. lst should be a list of numbers, specifying the field width for each argument. All items in a column will be left-aligned for negative numbers, otherwise right-aligned. See also align, center and wrap.
      
      : (let Fmt (-3 14 14)
         (tab Fmt "Key" "Rand 1" "Rand 2")
         (tab Fmt "---" "------" "------")
         (for C '(A B C D E F)
            (tab Fmt C (rand) (rand)) ) )
      Key        Rand 1        Rand 2
      ---        ------        ------
      A               0    1481765933
      B     -1062105905    -877267386
      C      -956092119     812669700
      D       553475508   -1702133896
      E      1344887256   -1417066392
      F      1812158119   -1999783937
      -> NIL
      
      (tail 'cnt|lst 'lst) -> lst
      Returns the last cnt elements of lst. If cnt is negative, it is added to the length of lst. If the first argument is a lst, tail is a predicate function returning that argument list if it is equal to the tail of the second argument, and NIL otherwise. (tail -2 Lst) is equivalent to (nth Lst 3). See also offset, head, last and stem.
      
      : (tail 3 '(a b c d e f))
      -> (d e f)
      : (tail -2 '(a b c d e f))
      -> (c d e f)
      : (tail 0 '(a b c d e f))
      -> NIL
      : (tail 10 '(a b c d e f))
      -> (a b c d e f)
      : (tail '(d e f) '(a b c d e f))
      -> (d e f)
      
      (task 'num ['num] [sym 'any ..] [. prg]) -> lst
      A front-end to the *Run global. If called with only a single num argument, the corresponding entry is removed from the value of *Run. Otherwise, a new entry is created. If an entry with that key already exists, an error is issued. For negative numbers, a second number must be supplied. If sym/any arguments are given, a job environment is built for thie *Run entry. See also forked and timeout.
      
      : (task -10000 5000 N 0 (msg (inc 'N)))            # Install task
      -> (-10000 5000 (job '((N . 0)) (msg (inc 'N))))   # for every 10 seconds
      : 1                                                # ... after 5 seconds
      2                                                  # ... after 10 seconds
      3                                                  # ... after 10 seconds
      (task -10000)                                      # remove again
      -> NIL
      
      : (task (port T 4444) (eval (udp @)))              # Receive RPC via UDP
      -> (3 (eval (udp @)))
      
      # Another session (on the same machine)
      : (udp "localhost" 4444 '(println *Pid))  # Send RPC message
      -> (println *Pid)
      
      (telStr 'sym) -> sym
      Formats a telephone number according to the current locale. If the string head matches the local country code, it is replaced with 0, otherwise + is prepended. See also expTel, datStr, money and format.
      
      : (telStr "49 1234 5678-0")
      -> "+49 1234 5678-0"
      : (locale "DE" "de")
      -> NIL
      : (telStr "49 1234 5678-0")
      -> "01234 5678-0"
      
      (tell ['cnt] 'sym ['any ..]) -> any
      Family IPC: Send an executable list (sym any ..) to all family members (i.e. all children of the current process, and all other children of the parent process, see fork) for automatic execution. When the cnt argument is given and non-zero, it should be the PID of such a process, and the list will be sent only to that process. tell is also used internally by commit to notify about database changes. When called without arguments, no message is actually sent, and the parent process may grant sync to the next waiting process. See also hear.
      
      : (call 'ps "x")                          # Show processes
        PID TTY      STAT   TIME COMMAND
        ..
       1321 pts/0    S      0:00 /usr/bin/picolisp ..  # Parent process
       1324 pts/0    S      0:01 /usr/bin/picolisp ..  # First child
       1325 pts/0    S      0:01 /usr/bin/picolisp ..  # Second child
       1326 pts/0    R      0:00 ps x
      -> T
      : *Pid                                    # We are the second child
      -> 1325
      : (tell 'println '*Pid)                   # Ask all others to print their Pid's
      1324
      -> *Pid
      
      (test 'any . prg)
      Executes prg, and issues an error if the result does not match the any argument. See also assert.
      
      : (test 12 (* 3 4))
      -> NIL
      : (test 12 (+ 3 4))
      ((+ 3 4))
      12 -- 'test' failed
      ?
      
      (text 'any1 'any ..) -> sym
      Builds a new transient symbol (string) from the string representation of any1, by replacing all occurrences of an at-mark "@", followed by one of the letters "1" through "9", and "A" through "Z", with the corresponding any argument. In this context "@A" refers to the 10th argument. A literal at-mark in the text can be represented by two successive at-marks. See also pack and glue.
      
      : (text "abc @1 def @2" 'XYZ 123)
      -> "abc XYZ def 123"
      : (text "a@@bc.@1" "de")
      -> "a@bc.de"
      
      (throw 'sym 'any)
      Non-local jump into a previous catch environment with the jump label sym (or T as a catch-all). Any pending finally expressions are executed, local symbol bindings are restored, open files are closed and internal data structures are reset appropriately, as the environment was at the time when the corresponding catch was called. Then any is returned from that catch. See also quit.
      
      : (de foo (N)
         (println N)
         (throw 'OK) )
      -> foo
      : (let N 1  (catch 'OK (foo 7))  (println N))
      7
      1
      -> 1
      
      (tick (cnt1 . cnt2) . prg) -> any
      Executes prg, then (destructively) adds the number of elapsed user ticks to the cnt1 parameter, and the number of elapsed system ticks to the cnt2 parameter. Thus, cnt1 and cnt2 will finally contain the total number of user and system time ticks spent in prg and all functions called (this works also for recursive functions). For execution profiling, tick is usually inserted into words with prof, and removed with unprof. See also usec.
      
      : (de foo ()                        # Define function with empty loop
         (tick (0 . 0) (do 100000000)) )
      -> foo
      : (foo)                             # Execute it
      -> NIL
      : (pp 'foo)
      (de foo NIL
         (tick (97 . 0) (do 100000000)) ) # 'tick' incremented 'cnt1' by 97
      -> foo
      
      (till 'any ['flg]) -> lst|sym
      Reads from the current input channel till a character contained in any is found (or until end of file if any is NIL). If flg is NIL, a list of single-character transient symbols is returned. Otherwise, a single string is returned. See also from and line.
      
      : (till ":")
      abc:def
      -> ("a" "b" "c")
      : (till ":" T)
      abc:def
      -> "abc"
      
      (tim$ 'tim ['flg]) -> sym
      Formats a time tim. If flg is NIL, the format is HH:MM, otherwise it is HH:MM:SS. See also $tim and dat$.
      
      : (tim$ (time))
      -> "10:57"
      : (tim$ (time) T)
      -> "10:57:56"
      
      (time ['T]) -> tim
      (time 'tim) -> (h m s)
      (time 'h 'm ['s]) -> tim | NIL
      (time '(h m [s])) -> tim | NIL
      Calculates the time of day, represented as the number of seconds since midnight. When called without arguments, the current local time is returned. When called with a T argument, the time of the last call to date is returned. When called with a single number tim, it is taken as a time value and a list with the corresponding hour, minute and second is returned. When called with two or three numbers (or a list of two or three numbers) for the hour, minute (and optionally the second), the corresponding time value is returned (or NIL if they do not represent a legal time). See also date, stamp, usec, tim$ and $tim.
      
      : (time)                         # Now
      -> 32334
      : (time 32334)                   # Now
      -> (8 58 54)
      : (time 25 30)                   # Illegal time
      -> NIL
      
      (timeout ['num])
      Sets or refreshes a timeout value in the *Run global, so that the current process executes bye after the given period. If called without arguments, the timeout is removed. See also task.
      
      : (timeout 3600000)           # Timeout after one hour
      -> (-1 3600000 (bye))
      : *Run                        # Look after a few seconds
      -> ((-1 3574516 (bye)))
      
      (tmp ['any ..]) -> sym
      Returns the path name to the packed any arguments in a process-local temporary directory. The directory name consists of the path to ".pil/tmp/" in the user's home directory, followed by the current process ID *Pid. This directory is automatically created if necessary, and removed upon termination of the process (bye). See also pil, *Tmp and *Bye .
      
      : *Pid
      -> 27140
      : (tmp "foo" 123)
      -> "/home/app/.pil/tmp/27140/foo123"
      : (out (tmp "foo" 123) (println 'OK))
      -> OK
      : (dir (tmp))
      -> ("foo123")
      : (in (tmp "foo" 123) (read))
      -> OK
      
      tolr/3
      Pilog predicate that succeeds if the first argument is either a substring or a +Sn soundex match of the result of applying the get algorithm to the following arguments. Typically used as filter predicate in select/3 database queries. See also isa/2, same/3, bool/3, range/3, head/3, fold/3 and part/3.
      
      : (?
         @Nr (1 . 5)
         @Nm "Sven"
         (select (@CuSu)
            ((nr +CuSu @Nr) (nm +CuSu @Nm))
            (range @Nr @CuSu nr)
            (tolr @Nm @CuSu nm) )
         (val @Name @CuSu nm) )
       @Nr=(1 . 5) @Nm="Sven" @CuSu={2-2} @Name="Seven Oaks Ltd."
      
      (touch 'sym) -> sym
      When sym is an external symbol, it is marked as "modified" so that upon a later commit it will be written to the database file. An explicit call of touch is only necessary when the value or properties of sym are indirectly modified.
      
      : (get '{2} 'lst)
      -> (1 2 3 4 5)
      : (set (cdr (get (touch '{2}) 'lst)) 999)    # Only read-access, need 'touch'
      -> 999
      : (get '{2} 'lst)                            # Modified second list element
      -> (1 999 3 4 5)
      
      (trace 'sym) -> sym
      (trace 'sym 'cls) -> sym
      (trace '(sym . cls)) -> sym
      (Debug mode only) Inserts a $ trace function call at the beginning of the function or method body of sym, so that trace information will be printed before and after execution. Built-in functions (C-function pointer) are automatically converted to Lisp expressions (see expr). See also *Dbg, traceAll and untrace, debug and lint.
      
      : (trace '+)
      -> +
      : (+ 3 4)
       + : 3 4
       + = 7
      -> 7
      
      (traceAll ['lst]) -> sym
      (Debug mode only) Traces all Lisp level functions by inserting a $ function call at the beginning. lst may contain symbols which are to be excluded from that process. In addition, all symbols in the global variable *NoTrace are excluded. See also trace, untrace and *Dbg.
      
      : (traceAll)      # Trace all Lisp level functions
      -> balance
      
      (trail ['flg]) -> lst
      (64-bit version only) Returns a stack backtrace for the current point of program execution, The list elements are either expressions (denoting function or method calls), or symbols followed by their corresponding values. If flg is NIL, the symbols and their values are omitted, and only the expressions are returned. See also up and env.
      
      : (de f (A B)
         (g (inc A) (dec B)) )
      -> f
      : (de g (X Y)
         (trail T) )
      -> g
      : (f 3 4)
      -> ((f 3 4) A 3 B 4 (g (inc A) (dec B)) X 4 Y 3)
      
      : (for (L (f 3 4)  L)  # Pretty-print trail
         (if (pair (car L))
            (println (pop 'L))
            (space 3)
            (println (pop 'L) (pop 'L)) ) )
      
         L NIL
      (f 3 4)
         A 3
         B 4
      (g (inc A) (dec B))
         X 4
         Y 3
      
      (tree 'var 'cls ['hook]) -> tree
      Returns a data structure specifying a database index tree. var and cls determine the relation, with an optional hook object. See also root, fetch, store, count, leaf, minKey, maxKey, init, step, scan, iter, prune, zapTree and chkTree.
      
      : (tree 'nm '+Item)
      -> (nm . +Item)
      
      (trim 'lst) -> lst
      Returns a copy of lst with all trailing whitespace characters or NIL elements removed. See also clip.
      
      : (trim (1 NIL 2 NIL NIL))
      -> (1 NIL 2)
      : (trim '(a b " " " "))
      -> (a b)
      
      true/0
      Pilog predicate that always succeeds. See also fail/0 and repeat/0.
      
      :  (? (true))
      -> T
      
      (try 'msg 'obj ['any ..]) -> any
      Tries to send the message msg to the object obj, optionally with arguments any. If obj is not an object, or if the message cannot be located in obj, in its classes or superclasses, NIL is returned. See also OO Concepts, send, method, meth, super and extra.
      
      : (try 'msg> 123)
      -> NIL
      : (try 'html> 'a)
      -> NIL
      
      (type 'any) -> lst
      Return the type (list of classes) of the object sym. See also OO Concepts, isa, class, new and object.
      
      : (type '{1A;3})
      (+Address)
      : (type '+DnButton)
      -> (+Tiny +Rid +JS +Able +Button)
      
      picolisp-3.1.5.2.orig/doc/refU.html0000644000000000000000000003411312265263724015506 0ustar rootroot U

      U

      *Uni
      A global variable holding an idx tree, with all unique data that were collected with the comma (,) read-macro. Typically used for localization. See also Read-Macros and locale.
      
      : (off *Uni)            # Clear
      -> NIL
      : ,"abc"                # Collect a transient symbol
      -> "abc"
      : ,(1 2 3)              # Collect a list
      -> (1 2 3)
      : *Uni
      -> ("abc" NIL (1 2 3))
      
      +UB
      Prefix class for +Aux to maintain an UB-Tree index instead of the direct values. This allows efficient range access to multidimensional data. Only positive numeric keys are supported. See also ubIter and Database.
      
      (class +Pos +Entity)
      (rel x (+UB +Aux +Ref +Number) (y z))
      (rel y (+Number))
      (rel z (+Number))
      
      : (scan (tree 'x '+Pos))
      (288362200753438306 . {13}) {13}
      (348187139486943716 . {16}) {16}
      (605261596962573238 . {11}) {11}
      (638523558602802506 . {7}) {7}   # UBKEY of (453062 450921 613956)
      (654697989157410399 . {12}) {12}
      ...
      
      : (show '{7})
      {7} (+Pos)
         x 453062
         y 450921
         z 613956
      -> {7}
      
      # Discrete queries work the same way as without the +UB prefix
      : (db 'x '+Pos 453062 'y 450921 'z 613956)
      -> {7}
      : (aux 'x '+Pos 453062 450921 613956)
      -> {7}
      : (? (db x +Pos (453062 450921 613956) @Pos))
       @Pos={7}
      -> NIL
      
      # Range queries work efficiently with 'collect'. Note that though also Pilog
      queries can handle UB-trees, they may do so sub-optimally for certain ranges.
      : (collect 'x '+Pos (200000 200000 200000) (899999 899999 899999))
      -> ({7} {14} {17} {15})
      
      (u) -> T
      (Debug mode only) Removes ! all breakpoints in all subexpressions of the current breakpoint. Typically used when single-stepping a function or method with debug. See also d and unbug.
      
      ! (u)                         # Unbug subexpression(s) at breakpoint
      -> T
      
      (ubIter 'tree 'dim 'fun 'lst1 'lst2)
      Efficiently iterates through a database +UB tree, by applying fun to all values. dim is the number of the key dimensions, lst1 and lst2 specify a range of keys. collect uses ubIter internally for UB-tree queries. See also iter.
      
      : (ubIter (tree 'x '+Pos) 3 show (200000 200000 200000) (899999 899999 899999))
      {7} (+Pos)
         z 613956
         y 450921
         x 453062
      {14} (+Pos)
         z 771372
         y 262217
         x 862358
      {17} (+Pos)
         z 676836
         y 529576
         x 398229
      {15} (+Pos)
         z 889332
         y 691799
         x 265381
      -> NIL
      
      (udp 'any1 'any2 'any3) -> any
      (udp 'cnt) -> any
      Simple unidirectional sending/receiving of UDP packets. In the first form, any3 is sent to a UDP server listening at host any1, port any2. In the second form, one item is received from a UDP socket cnt, established with port. See also listen and connect.
      
      # First session
      : (port T 6666)
      -> 3
      : (udp 3)  # Receive a datagram
      
      # Second session (on the same machine)
      : (udp "localhost" 6666 '(a b c))
      -> (a b c)
      
      # First session
      -> (a b c)
      
      (ultimo 'y 'm) -> cnt
      Returns the date of the last day of the month m in the year y. See also day and week.
      
      : (date (ultimo 2007 1))
      -> (2007 1 31)
      : (date (ultimo 2007 2))
      -> (2007 2 28)
      : (date (ultimo 2004 2))
      -> (2004 2 29)
      : (date (ultimo 2000 2))
      -> (2000 2 29)
      : (date (ultimo 1900 2))
      -> (1900 2 28)
      
      (unbug 'sym) -> T
      (unbug 'sym 'cls) -> T
      (unbug '(sym . cls)) -> T
      (Debug mode only) Removes all ! breakpoints in the function or method body of sym, as inserted with debug or d, or directly with edit. See also u.
      
      : (pp 'tst)
      (de tst (N)
         (! println (+ 3 N)) )         # 'tst' has a breakpoint '!'
      -> tst
      : (unbug 'tst)                   # Unbug it
      -> T
      : (pp 'tst)                      # Restore
      (de tst (N)
         (println (+ 3 N)) )
      
      (undef 'sym) -> fun
      (undef 'sym 'cls) -> fun
      (undef '(sym . cls)) -> fun
      Undefines the function or method sym. Returns the previous definition. See also de, dm, def and redef.
      
      : (de hello () "Hello world!")
      -> hello
      : hello
      -> (NIL "Hello world!")
      : (undef 'hello)
      -> (NIL "Hello world!")
      : hello
      -> NIL
      
      (unify 'any) -> lst
      Unifies any with the current Pilog environment at the current level and with a value of NIL, and returns the new environment or NIL if not successful. See also prove and ->.
      
      : (? (^ @A (unify '(@B @C))))
       @A=(((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T)
      
      (uniq 'lst) -> lst
      Returns a unique list, by eleminating all duplicate elements from lst. See also Comparing, sort and group.
      
      : (uniq (2 4 6 1 2 3 4 5 6 1 3 5))
      -> (2 4 6 1 3 5)
      
      uniq/2
      Pilog predicate that succeeds if the first argument is not yet stored in the second argument's index structure. idx is used internally storing for the values and checking for uniqueness. See also member/2.
      
      : (? (uniq a @Z))       # Remember 'a'
       @Z=NIL                 # Succeeded
      
      : (? (uniq b @Z))       # Remember 'b'
       @Z=NIL                 # Succeeded
      
      : (? (uniq a @Z))       # Remembered 'a'?
      -> NIL                  # Yes: Not unique
      
      (unless 'any . prg) -> any
      Conditional execution: When the condition any evaluates to non-NIL, NIL is returned. Otherwise prg is executed and the result returned. See also when.
      
      : (unless (= 3 3) (println 'Strange 'result))
      -> NIL
      : (unless (= 3 4) (println 'Strange 'result))
      Strange result
      -> result
      
      (until 'any . prg) -> any
      Conditional loop: While the condition any evaluates to NIL, prg is repeatedly executed. If prg is never executed, NIL is returned. Otherwise the result of prg is returned. See also while.
      
      : (until (=T (setq N (read)))
         (println 'square (* N N)) )
      4
      square 16
      9
      square 81
      T
      -> 81
      
      (untrace 'sym) -> sym
      (untrace 'sym 'cls) -> sym
      (untrace '(sym . cls)) -> sym
      (Debug mode only) Removes the $ trace function call at the beginning of the function or method body of sym, so that no more trace information will be printed before and after execution. Built-in functions (C-function pointer) are automatically converted to their original form (see subr). See also trace and traceAll.
      
      : (trace '+)                           # Trace the '+' function
      -> +
      : +
      -> (@ ($ + @ (pass $385455126)))       # Modified for tracing
      : (untrace '+)                         # Untrace '+'
      -> +
      : +
      -> 67319120                            # Back to original form
      
      (up [cnt] sym ['val]) -> any
      Looks up (or modifies) the cnt'th previously saved value of sym in the corresponding enclosing environment. If cnt is not given, 1 is used. The 64-bit version also allows to omit the sym argument, then the corresponding expression (function or method call) is returned. See also eval, run, trail and env.
      
      : (let N 1 ((quote (N) (println N (up N))) 2))
      2 1
      -> 1
      : (let N 1 ((quote (N) (println N (up N) (up N 7))) 2) N)
      2 1 7
      -> 7
      
      : (de foo (N)
         (println (up))  # 64-bits only
         (inc N) )
      -> foo
      : (foo 7)
      (foo 7)
      -> 8
      
      (upd sym ..) -> lst
      Synchronizes the internal state of all passed (external) symbols by passing them to wipe. upd is the standard function passed to commit during database transactions.
      
      (commit 'upd)  # Commit changes, informing all sister processes
      
      (update 'obj ['var]) -> obj
      (Debug mode only) Interactive database function for modifying external symbols. When called only with an obj argument, update steps through the value and all properties of that object (and recursively also through substructures) and allows to edit them with the console line editor. When the var argument is given, only that single property is handed to the editor. To delete a propery, NIL must be explicitly entered. update will correctly handle all entity/relation mechanisms. See also select, edit and Database.
      
      : (show '{3-1})            # Show item 1
      {3-1} (+Item)
         nr 1
         pr 29900
         inv 100
         sup {2-1}
         nm "Main Part"
      -> {3-1}
      
      : (update '{3-1} 'pr)      # Update the prices of that item
      {3-1} pr 299.00            # The cursor is right behind "299.00"
      -> {3-1}
      
      (upp? 'any) -> sym | NIL
      Returns any when the argument is a string (symbol) that starts with an uppercase character. See also uppc and low?
      
      : (upp? "A")
      -> T
      : (upp? "a")
      -> NIL
      : (upp? 123)
      -> NIL
      : (upp? ".")
      -> NIL
      
      (uppc 'any) -> any
      Upper case conversion: If any is not a symbol, it is returned as it is. Otherwise, a new transient symbol with all characters of any, converted to upper case, is returned. See also lowc, fold and upp?.
      
      : (uppc 123)
      -> 123
      : (uppc "abc")
      -> "ABC"
      : (uppc 'car)
      -> "CAR"
      
      (use sym . prg) -> any
      (use (sym ..) . prg) -> any
      Defines local variables. The value of the symbol sym - or the values of the symbols sym in the list of the second form - are saved, prg is executed, then the symbols are restored to their original values. During execution of prg, the values of the symbols can be temporarily modified. The return value is the result of prg. See also bind, job and let.
      
      : (setq  X 123  Y 456)
      -> 456
      : (use (X Y) (setq  X 3  Y 4) (* X Y))
      -> 12
      : X
      -> 123
      : Y
      -> 456
      
      (useKey 'var 'cls ['hook]) -> num
      Generates or reuses a key for a database tree, by randomly trying to locate a free number. See also genKey.
      
      : (maxKey (tree 'nr '+Item))
      -> 8
      : (useKey 'nr '+Item)
      -> 12
      
      (usec ['flg]) -> num
      Returns the number the microseconds. If flg is non-NIL, the microsecond fraction of the last call to time is returned, otherwise the number of microseconds since interpreter startup. See also date and tick.
      
      : (usec)
      -> 1154702479219050
      : (list (date (date)) (time (time T)) (usec T))
      -> ((2013 1 4) (10 12 39) 483321)
      
      picolisp-3.1.5.2.orig/doc/refV.html0000644000000000000000000001237612265263724015516 0ustar rootroot V

      V

      (val 'var) -> any
      Returns the current value of var. See also setq, set and def.
      
      : (setq L '(a b c))
      -> (a b c)
      : (val 'L)
      -> (a b c)
      : (val (cdr L))
      -> b
      
      val/3
      Pilog predicate that returns the value of an object's attribute. Typically used in database queries. The first argument is a Pilog variable to bind the value, the second is the object, and the third and following arguments are used to apply the get algorithm to that object. See also db/3 and select/3.
      
      : (?
         (db nr +Item (2 . 5) @Item)   # Fetch articles 2 through 5
         (val @Nm @Item nm)            # Get item description
         (val @Sup @Item sup nm) )     # and supplier's name
       @Item={3-2} @Nm="Spare Part" @Sup="Seven Oaks Ltd."                             @Item={3-3} @Nm="Auxiliary Construction" @Sup="Active Parts Inc."
       @Item={3-4} @Nm="Enhancement Additive" @Sup="Seven Oaks Ltd."
       @Item={3-5} @Nm="Metal Fittings" @Sup="Active Parts Inc."
      -> NIL
      
      (var sym . any) -> any
      (var (sym . cls) . any) -> any
      Defines a class variable sym with the initial value any for the current class, implicitly given by the value of the global variable *Class, or - in the second form - for the explicitly given class cls. See also OO Concepts, rel and var:.
      
      : (class +A)
      -> +A
      : (var a . 1)
      -> 1
      : (var b . 2)
      -> 2
      : (show '+A)
      +A NIL
         b 2
         a 1
      -> +A
      
      (var: sym) -> any
      Fetches the value of a class variable sym for the current object This, by searching the property lists of its class(es) and supperclasses. See also OO Concepts, var, with, meta, :, =: and ::.
      
      : (object 'O '(+A) 'a 9 'b 8)
      -> O
      : (with 'O (list (: a) (: b) (var: a) (var: b)))
      -> (9 8 1 2)
      
      (version ['flg]) -> lst
      Prints the current version as a string of dot-separated numbers, and returns the current version as a list of numbers. The JVM- and C-versions print an additional "JVM" or "C", respectively, separated by a space. When flg is non-NIL, printing is suppressed.
      
      $ pil -version
      3.0.1.22
      : (version T)
      -> (3 0 1 22)
      
      (vi 'sym) -> sym
      (vi 'sym 'cls) -> sym
      (vi '(sym . cls)) -> sym
      (vi) -> NIL
      (Debug mode only) Opens the "vi" editor on the function or method definition of sym. A call to ld thereafter will load the modified file. A call without arguments permanently switches the REPL line editor and the edit function to "vi" mode. See also doc, edit, em, *Dbg, debug and pp.
      
      : (vi 'url> '+CuSu)  # Edit the method's source code, then exit from 'vi'
      -> T
      
      (view 'lst ['T]) -> any
      Views lst as tree-structured ASCII graphics. When the T argument is given, lst should be a binary tree structure (as generated by idx), which is then shown as a left-rotated tree. See also pretty and show.
      
      : (balance 'I '(a b c d e f g h i j k l m n o))
      -> NIL
      : I
      -> (h (d (b (a) c) f (e) g) l (j (i) k) n (m) o)
      
      : (view I)
      +-- h
      |
      +---+-- d
      |   |
      |   +---+-- b
      |   |   |
      |   |   +---+-- a
      |   |   |
      |   |   +-- c
      |   |
      |   +-- f
      |   |
      |   +---+-- e
      |   |
      |   +-- g
      |
      +-- l
      |
      +---+-- j
      |   |
      |   +---+-- i
      |   |
      |   +-- k
      |
      +-- n
      |
      +---+-- m
      |
      +-- o
      -> NIL
      
      : (view I T)
               o
            n
               m
         l
               k
            j
               i
      h
               g
            f
               e
         d
               c
            b
               a
      -> NIL
      
      picolisp-3.1.5.2.orig/doc/refW.html0000644000000000000000000001412612265263724015512 0ustar rootroot W

      W

      (wait ['cnt] . prg) -> any
      Waits for a condition. While the result of the execution of prg is NIL, a select system call is executed for all file descriptors and timers in the VAL of the global variable *Run. When cnt is non-NIL, the waiting time is limited to cnt milliseconds. Returns the result of prg. See also key and sync.
      
      : (wait 2000)                                # Wait 2 seconds
      -> NIL
      : (prog
         (zero *Cnt)
         (setq *Run                                # Install background loop
            '((-2000 0 (println (inc '*Cnt)))) )   # Increment '*Cnt' every 2 sec
         (wait NIL (> *Cnt 6))                     # Wait until > 6
         (off *Run) )
      1                                            # Waiting ..
      2
      3
      4
      5
      6
      7
      -> NIL
      
      (week 'dat) -> num
      Returns the number of the week for a given date dat. See also day, ultimo, datStr and strDat.
      
      : (datStr (date))
      -> "2007-06-01"
      : (week (date))
      -> 22
      
      (when 'any . prg) -> any
      Conditional execution: When the condition any evaluates to non-NIL, prg is executed and the result is returned. Otherwise NIL is returned. See also unless.
      
      : (when (> 4 3) (println 'OK) (println 'Good))
      OK
      Good
      -> Good
      
      (while 'any . prg) -> any
      Conditional loop: While the condition any evaluates to non-NIL, prg is repeatedly executed. If prg is never executed, NIL is returned. Otherwise the result of prg is returned. See also until.
      
      : (while (read)
         (println 'got: @) )
      abc
      got: abc
      1234
      got: 1234
      NIL
      -> 1234
      
      (what 'sym) -> lst
      (Debug mode only) Returns a list of all internal symbols that match the pattern string sym. See also match, who and can.
      
      : (what "cd@dr")
      -> (cdaddr cdaadr cddr cddddr cdddr cddadr cdadr)
      
      (who 'any) -> lst
      (Debug mode only) Returns a list of all functions or method definitions that contain the atom or pattern any. See also match, what and can.
      
      : (who 'caddr)                         # Who is using 'caddr'?
      -> ($dat lint1 expDat datStr $tim tim$ mail _gen dat$ datSym)
      
      : (who "Type error")
      -> ((mis> . +Link) *Uni (mis> . +Joint))
      
      : (more (who "Type error") pp)         # Pretty print all results
      (dm (mis> . +Link) (Val Obj)
         (and
            Val
            (nor (isa (: type) Val) (canQuery Val))
            "Type error" ) )
      .                                      # Stop
      -> T
      
      (wipe 'sym|lst) -> sym|lst
      Clears the VAL and the property list of sym, or of all symbols in the list lst. When a symbol is an external symbol, its state is also set to "not loaded". Does nothing when sym is an external symbol that has been modified or deleted ("dirty").
      
      : (setq A (1 2 3 4))
      -> (1 2 3 4)
      : (put 'A 'a 1)
      -> 1
      : (put 'A 'b 2)
      -> 2
      : (show 'A)
      A (1 2 3 4)
         b 2
         a 1
      -> A
      : (wipe 'A)
      -> A
      : (show 'A)
      A NIL
      -> A
      
      (with 'sym . prg) -> any
      Saves the current object This and sets it to the new value sym. Then prg is executed, and This is restored to its previous value. The return value is the result of prg. Used typically to access the local data of sym in the same manner as inside a method body. prg is not executed (and NIL is returned) when sym is NIL. (with 'X . prg) is equivalent to (let? This 'X . prg).
      
      : (put 'X 'a 1)
      -> 1
      : (put 'X 'b 2)
      -> 2
      : (with 'X (list (: a) (: b)))
      -> (1 2)
      
      (wr 'cnt ..) -> cnt
      Writes all cnt arguments as raw bytes to the current output channel. See also rd and pr.
      
      : (out "x" (wr 1 255 257))  # Write to "x"
      -> 257
      : (hd "x")
      00000000  01 FF 01                                         ...
      -> NIL
      
      (wrap 'cnt 'lst) -> sym
      Returns a transient symbol with all characters in lst packed in lines with a maximal length of cnt. See also tab, align and center.
      
      : (wrap 20 (chop "The quick brown fox jumps over the lazy dog"))
      -> "The quick brown fox^Jjumps over the lazy^Jdog"
      : (wrap 8 (chop "The quick brown fox jumps over the lazy dog"))
      -> "The^Jquick^Jbrown^Jfox^Jjumps^Jover the^Jlazy dog"
      
      picolisp-3.1.5.2.orig/doc/refX.html0000644000000000000000000000247712265263724015521 0ustar rootroot X

      X

      (xchg 'var 'var ..) -> any
      Exchange the values of successive var argument pairs. See also swap and set.
      
      : (setq  A 1  B 2  C '(a b c))
      -> (a b c)
      : (xchg  'A C  'B (cdr C))
      -> 2
      : A
      -> a
      : B
      -> b
      : C
      -> (1 2 c)
      
      (xor 'any 'any) -> flg
      Returns T if exactly one of the arguments evaluates to non-NIL.
      
      : (xor T NIL)
      -> T
      : (xor T T)
      -> NIL
      
      (x| 'num ..) -> num
      Returns the bitwise XOR of all num arguments. When one of the arguments evaluates to NIL, it is returned immediately. See also &, | and bit?.
      
      : (x| 2 7)
      -> 5
      : (x| 2 7 1)
      -> 4
      
      picolisp-3.1.5.2.orig/doc/refY.html0000644000000000000000000000367712265263724015525 0ustar rootroot Y

      Y

      (yield 'any ['sym]) -> any
      (64-bit version only) Transfers control from the current coroutine back to the caller (when the sym tag is not given), or to some other coroutine (specified by sym) to continue execution at the point where that coroutine had called yield before. In the first case, the value any will be returned from the corresponding co call, in the second case it will be the return value of that yield call. See also stack, catch and throw.
      
      : (co "rt1"                            # Start first routine
         (msg (yield 1) " in rt1 from rt2")  # Return '1', wait for value from "rt2"
         7 )                                 # Then return '7'
      -> 1
      
      : (co "rt2"                            # Start second routine
         (yield 2 "rt1") )                   # Send '2' to "rt1"
      2 in rt1 from rt2
      -> 7
      
      (yoke 'any ..) -> any
      Inserts one or several new elements any in front of the list in the current make environment. yoke returns the last inserted argument. See also link, chain and made.
      
      : (make (link 2 3) (yoke 1) (link 4))
      -> (1 2 3 4)
      
      picolisp-3.1.5.2.orig/doc/refZ.html0000644000000000000000000000621412265263724015514 0ustar rootroot Z

      Z

      *Zap
      A global variable holding a list and a pathname. If given, and the value of *Solo is NIL, external symbols which are no longer accessible can be collected in the CAR, e.g. during DB tree processing, and written to the file in the CDR at the next commit. A (typically periodic) call to zap_ will clean them up later.
      
      : (setq *Zap '(NIL . "db/app/_zap"))
      -> "db/app/_zap"
      
      (zap 'sym) -> sym
      "Delete" the symbol sym. For internal symbols, that means to remove it from the internal index, effectively transforming it to a transient symbol. For external symbols, it means to mark it as "deleted", so that upon a later commit it will be removed from the database file. See also intern.
      
      : (de foo (Lst) (car Lst))          # 'foo' calls 'car'
      -> foo
      : (zap 'car)                        # Delete the symbol 'car'
      -> "car"
      : (pp 'foo)
      (de foo (Lst)
         ("car" Lst) )                    # 'car' is now a transient symbol
      -> foo
      : (foo (1 2 3))                     # 'foo' still works
      -> 1
      : (car (1 2 3))                     # Reader returns a new 'car' symbol
      !? (car (1 2 3))
      car -- Undefined
      ?
      
      (zapTree 'sym)
      Recursively deletes a tree structure from the database. See also tree, chkTree and prune.
      
      : (zapTree (cdr (root (tree 'nm '+Item))))
      
      (zap_)
      Delayed deletion (with zap) of external symbols which were collected e.g. during DB tree processing. An auxiliary file (with the name taken from the CDR of the value of *Zap, concatenated with a "_" character) is used as an intermediary file.
      
      : *Zap
      -> (NIL . "db/app/Z")
      : (call 'ls "-l" "db/app")
      ...
      -rw-r--r-- 1 abu abu     1536 2007-06-23 12:34 Z
      -rw-r--r-- 1 abu abu     1280 2007-05-23 12:15 Z_
      ...
      : (zap_)
      ...
      : (call 'ls "-l" "db/app")
      ...
      -rw-r--r-- 1 abu abu     1536 2007-06-23 12:34 Z_
      ...
      
      (zero var ..) -> 0
      Stores 0 in all var arguments. See also one, on, off and onOff.
      
      : (zero A B)
      -> 0
      : A
      -> 0
      : B
      -> 0
      
      picolisp-3.1.5.2.orig/CHANGES0000644000000000000000000004005012265263724014142 0ustar rootroot* XXmar14 picoLisp-3.1.6 * 31dec13 picoLisp-3.1.5 Phone GUI support 'prune' LRU scheme Bug in volatile properties 'cnt2' argument to 'gc' (64-bit) Improved UB-Tree support * 30sep13 picoLisp-3.1.4 Bug in bignum 'rd' (64-bit) 'swap' function Optimized 'sqrt' Changed 'canvas' to '' Pass delay-argument to 'drawCanvas' 'grid' wrap flags 'ssl' timeout 'casq' flow function Pilog Lisp call syntax with '^' 'read' preserves trailing white space * 29jun13 picoLisp-3.1.3 'snapshot' in "lib/too.l" 'info' optional 'flg' argument '+Swap' relation prefix class Allow unlimited number of coroutines Default coroutine stack segment size 1 MB JavaScript canvas library '+OnClick' GUI prefix class Flight Simulator in "misc/rcsim.l" (64-bit) Removed z3d/rcsim flight simulator (32-bit) Bug in 'conc' (64-bit) * 30mar13 picoLisp-3.1.2 'lisp' calls from 'native' in emulator '' function 'fold' analog to 'lowc' / 'uppc' 'fold' second arg default zero Removed 'dbg' startup script Trim trailing spaces in "lib/form.js" Bug in 'accept' on BSD '+Hook2' index prefix class Password hashing 'usec' optional 'flg' argument JavaScript 'rd' in "lib/plio.js" 'bytes' function Join multiple namespaces with 'symbols' * 30nov12 picoLisp-3.1.1 Emacs-style editing with 'em' Line editor arrow-key support Changed from CTags to ETags format Backtrace with 'trail' and 'up' (64-bit) Changed semantics of token 'read' '-server' function 64-bit emulator '*CPU' global variable (64-bit) Bug in 'collect' for 'fold'ed keys File descriptor leak in 'dir' (64-bit) Namespace support also in Ersatz PicoLisp JavaScript 'lisp' calls '+DbHint' GUI prefix class Stack alignments (64-bit) Native 'struct' function (64-bit) double/float in 'native' structures (64-bit) Allow 'zap' protected symbols outside 'pico' namespace (64-bit) Bug in 'who' * 10apr12 picoLisp-3.1.0 Generalized 'scl' Pilog 'for/[2-4]' predicate Bug in 'isLifeE_F' (64-bit) Bug in 'firstByteA_B' (64-bit) 'httpGate' session bug Simplified 'sigio' Volatile 'NIL' property Bug in 'fold' (64-bit) Bug in 'db' for partial '+Aux' access Bug in 'interface' (Ersatz) 'locale' optional arguments * 30dec11 picoLisp-3.0.9 Bash completion Changed GUI '+Hint' system Calculated message passing (64-bit) Improved "tags" file handling IPv6 support '*Prompt' global variable 'local' symbols function 'open' optional 'flg' argument * 30sep11 picoLisp-3.0.8 'load' preserves current namespace "src64/tags" for 'vi' source access 'import' symbols function Namespace support with 'symbols' (64-bit) Bug in '@' lambda bindings (32-bit) GC bug in 64-bit bignums Bug in 64-bit 'exec' error handling Bug in 'rand' (64-bit) EOF bug in pipes to stdin 'clause' function 'prop' and '::' cons default cell "lib/test.l" position independent 'hash' function Bug in 'dbFetchEX' for db extensions * 30jun11 picoLisp-3.0.7 Numbers and strings in 'native' structure arguments Signal portability problems 'dbSync' on arbitrary objects UB-Tree support in "lib/db.l" Renamed "ersatz/picolisp" to "ersatz/pil" Changed '@' to '!' for functions in URLs 64-bit version for PowerPC (ppc64) Local 'pil' startup script Bug in 'replace' (64-bit) Moved temporary directories to ~/.pil/tmp/ Moved line editor history to ~/.pil/history * 29mar11 picoLisp-3.0.6 Bug in 'poll' (64-bit) Bug in 'accept' (64-bit) 'err' function Removed 'rpc' function man pages for 'picolisp' and 'pil' 'version' also for 32-bit Map/apply support for FEXPRs Bug in vararg method calls (64-bit) 'fill' handles '^' 'le0' function Interpreter not exited upon '*Tsm' by default off, moved to "lib/tsm.l" Command line '+' debug flag 'round' defaults to 3 * 31dec10 picoLisp-3.0.5 'bin' function 'prior' function 'circ?' function Ersatz PicoLisp (Java) version Bug in (rd 'cnt) * 30sep10 picoLisp-3.0.4 'tell' accepts PID argument Deprecated 'pid' Extended protocol for 'sync' MIT/X11 License Drag & Drop file upload Generic 'lisp' C-callbacks 'native' fixpoint handling OpenGL (64-bit) in "lib/openGl.l" Faster bignum division (64-bit) * 29jun10 picoLisp-3.0.3 'assert' function 'round' function 'co', 'yield' and 'stack' coroutine functions 'sigio' function 'sqrt' optionally rounds 'format' also accepts 'lst' argument 'adr' function 'dir' can also return '.'-files * 30mar10 picoLisp-3.0.2 Simple incrementing form of 'for' Changed 'scl' to set '*Scl' globally 'acquire' and 'release' mutex functions Changed 'state' syntax 'version' function (64-bit) C 'lisp()' callback function (64-bit) Bug in 'member' for circular lists (64-bit) "lib/tags" for 'vi' source access Bug in 'next' and 'arg' (64-bit) Bug in comma read macro (64-bit) Bug in binary read functions (64-bit) 'hax' function Bug when deleting external symbols (64-bit) Bug in external symbol names (64-bit) Bug in '|' and 'x|' (32-bit) * 31dec09 picoLisp-3.0.1 '*Tsm' transient symbol markup 'range' function 'gcc' for 64-bit in "lib/native.l" 'flip' optional 'cnt' argument Up to four letters in 'c[ad]*ar' and 'c[ad]*dr' Fixed sporadic GUI errors GUI 'onchange' handling * 07oct09 picoLisp-3.0 64-bit version for x86-64 Allowed '.' in symbol names Changed GUI to Post/Redirect/Get pattern Changed event handling to non-blocking I/O Extension ".l" on localization country files Deprecated 'begin' and 'nagle' * 30jun09 picoLisp-2.3.7 'dbg' startup script Removed 'stk' function Bug in GUI history "back" handling Multi-line (block) comments Improved external hash table Transient characters no longer interned 'getd' loads shared library code * 31mar09 picoLisp-2.3.6 'lines' returns 'NIL' on failure Only numeric argument to 'hear' 'sort' optional 'fun' argument Bugs in 'evList()' and 'date' * 31dec08 picoLisp-2.3.5 Bug in 'pipe' Bug in 'later' Dialog and chart bugs in "lib/form.l" HTTP protocol bug in "lib/http.l" Bugs in 'inc' and 'bigCmp()' 'abort' function 'eval' and 'run' optional 'lst' argument * 30sep08 picoLisp-2.3.4 'once' function 'hex' and 'oct' negative arguments Bug in 'pool' 'cmd' function 'script' function Bug in 'idx' Bug in 'lit' 'extract' function * 29jun08 picoLisp-2.3.3 Removed '*Rst' global variable Catch error messages Remote Pilog queries DB extension with '*Ext' and 'ext' Extended 'put'-syntax to zero keys Wrong '@@' result in 'load' Handling of "#" in 'str' * 29mar08 picoLisp-2.3.2 Ctrl-D termination Improved termios restore 'file' function ';' function Changed (time T) semantics Bugs in 'idx' and 'lup' DB synchronous transaction log Handling of 'bind' in 'debug' * 30dec07 picoLisp-2.3.1 'str' extended to parse tokens '*Hup' global variable Changed/extended 'all' semantics Replaced 'die' with 'alarm' Bug in 'glue' Improved '@' handling Bug in 'bye()' 'eol' end-of-line function Escape delimiter characters in symbol names 'lint' also file contents 'noLint' function * 30sep07 picoLisp-2.3.0 Extended "lib/test.l" unit tests 'full' function Bug in 'wipe' Bug in 'digSub1()' Changed internal symbol structure 'pid' selector for 'tell' 'vi' and 'ld' source code access Restored 'in'/'out' negative channel offsets Abandoned 'stdio' in I/O functions Improved signal handling 'leaf' function Restored 'gc' unit to "megabytes" Changed 'heap' return values Bug in 'tell' 'chess' XBoard interface '*Sig1', '*Sig2' global variables 'ipid' and 'opid' functions Bug in writing blobs Timeout bug in 'httpGate' '*Zap' global variable '*OS' global variable * 30jun07 picoLisp-2.2.7 Extended "doc/ref.html" 'cons' multiple arguments 'yoke' function 'up' optional 'cnt' argument * 01apr07 picoLisp-2.2.6 'app' reference application Bug in 'text' Family IPC redesign Gave up 'in'/'out' negative channel offsets Changed 'keep>' and 'lose>' methods Gave up '*Tsm' transient symbol markup 'sect' and 'diff' in C 'gc' unit changed to "million cells" * 31dec06 picoLisp-2.2.5 Persistent HTTP Connections Extended 'tick' to count system time Chunked HTTP transfers Changed '*Key' to '*Run' 'fifo' function 'die' alarm function 'line' carriage return handling Pre- and post-arguments to 'commit' 'text' function 'glue' in C Ajax GUI in "lib/form.l", "lib/form.js" 'push1' function (deprecates '?push') Bug in 'ht:Fmt' * 30sep06 picoLisp-2.2.4 Cygwin/Win32 port (Doug Snead) Changed 'bind' argument 'fish' function 'rd' optional 'sym' argument Bug in 'lock' (unlock all) 'free' function Extended 'seq' to return first symbol Simple 'udp' function 'usec' function Bug in 'isLife()' '*PPid' global variable 'nagle' network function Extended 'get'-syntax to 'asoq' * 30jun06 picoLisp-2.2.3 "redefined" messages go to stderr Bug in 'argv' Deprecated "lib/tree.l" Restored '*Solo' global variable '(get lst 0)' returns 'NIL' Bug in 'extern' 'nond' (negated 'cond') function 'ge0' function Bug in 'lose>' and 'keep>' for '+Joint' '*Rst' global variable Bug in 'next'/'arg' Changed 'env' and 'job' Bug in B-Tree 'step' Changed 'mark' return value Changed 'close' return value * 29mar06 picoLisp-2.2.2 Mac OS X (Darwin) port (Rick Hanson) 'pwd' function 'if2' flow function 'rpc' function 'one' function Changed 'space' return value 'up' symbol binding lookup function Bug in 'eval' and 'run' environment offset 'onOff' function 'path' substitution function '*Tsm' transient symbol markup Underlining transient symbols * 30dec05 picoLisp-2.2.1 'eof' end-of-file function Changed 'line' EOF return value Deprecated 'whilst' and 'until=T' 'read' extended to parse tokens 'raw' console mode function 'later' multiprocessing function Bug in nested 'fork' and 'pipe' Extended 'gcc' arguments Bug in 'boxWord2()' 'id' external symbol function Extended 'dm' syntax for object argument 'size' changed to return bytes instead of blocks in DB Executable renamed to "picolisp" 'lieu' predicate function Bug in 'compare()' * 29sep05 picoLisp-2.2.0 FreeBSD port B-Trees Multi-file DB Configurable DB block size Generalized 'pipe' semantics Changed 'rank' to sorted lists Removed '*Solo' global variable Relaxed 'wipe' "modified" error condition DB-I/O changed to 'pread()' and 'pwrite()' Extended 'get'-syntax to zero and negative keys 'by' attribute map function Swing GUI in "java2/" and "lib/gui2.l" 'box?' predicate function Bug in 'compare()' 'balance' C-utility * 30jun05 picoLisp-2.1.2 GC non-recursive 'lup' lookup in 'idx' trees Applet colors 'try' to send messages 'x|' function Tooltips in applets Binding environment offset for 'eval' and 'run' XHTML/CSS support in "lib/xhtml.l" Separated "lib/html.l" from "lib/http.l" Removed "lib/http.l" from "ext.l" Bug in 'isa' Bug in 'lose>' and 'keep>' for '+Bag' Security hole in 'http' Bug in 'rel>' for '+Hook' * 30mar05 picoLisp-2.1.1 'protect' function DB journaling 'chess' demo Predicates return their argument instead of 'T', if possible Bug in 'fun?' Improved 'lint' heuristics I/O-Multiplexing also for plain stdin 'dir' in C Self-adjusting applet size Bug in 'pack()' * 30dec04 picoLisp-2.1.0 'pipe' function Bugs in bignum arithmetic 'arg' optional 'cnt' argument '+Aux' auxiliary index keys '*Solo' global variable 'flg?' predicate function 'fin' access function Bug in 'compare()' 'cd' returns old directory 'inc' and 'dec' numeric argument Next 'opt' command line arg 'finally' exception cleanup Implied 'upd' argument in transactions 'put!>', 'del!>' etc. Bug in 'idx' for empty trees 'curry' function Anonymous recursion with 'recur' and 'recurse' Extended 'env' to return bindings Second argument to 'fill' Optional comment character argument for 'skip' 'flip' destructive list reversal * 01oct04 picoLisp-2.0.14 '' HTML function Finite 'state' machine function Extended 'for' functionality 'rcsim' toy RC flight simulator Bug in 'sym', 'str' and '*/' Extended 'dbck' return value * 03aug04 picoLisp-2.0.13 Changed rounding and argument policy of '*/' Applet protocol revised Extended 'head' and 'tail' to predicate functionality Changed 'accu' default from 1 to 0 Dialog handling revised Multiple JAR files per applet Fixed "Last-Modified:" format in 'httpEcho' * 29may04 picoLisp-2.0.12 Fixed 'boss' mechanism 'del' delete-and-set function '*Fork' global variable Changed URL encoding of Lisp objects Removed traffic throttle from 'httpGate' Synchronized ".picoHistory" in "lib/led.l" Fixed exception handling in debug breakpoint Revised subclass handling in 'db' and 'collect' Applet font/size parameters * 07apr04 picoLisp-2.0.11 Bug in 'append' Modal dialogs revised Bug in 'lose>' and 'keep>' for '+Bag' 'poll' (no block-on-read-) check function Inline 'gcc' C-function compilation * 01feb04 picoLisp-2.0.10 'wr' raw byte output function Improved modal dialogs Comma ',' read-macro, replacing the '_' function 'let?' conditional flow/bind function 'accept' non-blocking, with timeout Optional method-defining arguments to '+Form's '+Bool' relation class '+Ref2' backing index prefix class 'size' returns number of DB blocks for external symbols '+ListTextField' split parameter * 06dec03 picoLisp-2.0.9 'Tele' java client Closed leaking file descriptors in 'fork' Changed applet protocol to individual server connections Decoupled applet init from HTML page load * 14oct03 picoLisp-2.0.8b Bug in 'put>', 'rel>', 'lose>' and 'keep>' for '+List' Bug in 'lose>' and 'keep>' for '+Bag' * 01oct03 picoLisp-2.0.8 '+Hook' handling in '+Bag' Unicode case conversions '+Hook' changed to prefix class Telephone number locales CR-LF in HTTP headers 'date' and 'time' return UTC for 'T' argument 'clk>' (doubleclick) for '+DrawField' Improved Hook support in Pilog Optional 'NIL' argument to 'html' for "no Cache-Control" * 03aug03 picoLisp-2.0.7 Extended 'in' and 'out' for negative channel offset arguments Changed internal database index tree function API Changed 'info' to return 'T' for the directory size Interrupt signal handling in 'ctty', 'psh' and "bin/psh" Generic 'help>' method for '+Form' class in "lib/gui.l" Fixed 'ht:Prin' bug (NULL-Bytes) 'argv' optional symbolic arguments Changed 'idx' return value Better tracing and profiling of C-functions * 08jun03 picoLisp-2.0.6 Allowed '#' in symbol names Changed 'eps' in "lib/ps.l" Interactive DB tools in "lib/sq.l" 'revise' line editor function 'circ' changed to individual arguments Moved code-libraries to "lib/" Moved *.jar-files to "java/" * 23apr03 picoLisp-2.0.5 'mail' changed to direct SMTP 'sys' environment access function Plain HTML-GUI "lib/htm.l" (experimental) Semantics of 'do NIL' changed from enless- to zero-loop * 03mar03 picoLisp-2.0.4 Changed and extended '+IndexChart' '=0', 'lt0' and 'gt0' return numeric argument instead of 'T' 'cut' changed to be non-desctructive 'ssl' replication mechanism 'ctl' file control primitives 'ext?' and 'extern' check for physical existence of external symbol * 01feb03 picoLisp-2.0.3 Extension and redesign of the HTML API 'loop' function as a synonym for 'do NIL' * 17jan03 picoLisp-2.0.2 The example files for the tutorial were in the wrong directory Bind '*Key' in debug breakpoint Localization bug in "misc/tax.l" * 27dec02 picoLisp-2.0.1 Default locale 'NIL' Pilog documentation Example family database * 16dec02 picoLisp-2.0 Initial release picolisp-3.1.5.2.orig/lib/0000755000000000000000000000000012265263724013716 5ustar rootrootpicolisp-3.1.5.2.orig/lib/math.l0000644000000000000000000000045412265263724015027 0ustar rootroot# 26jun10abu # (c) Software Lab. Alexander Burger (and (=0 *Scl) (scl 6)) # Default scale 6 (setq # Global constants pi 3.1415926535897932 pi/2 1.5707963267948966 ) (load (if (== 64 64) "@lib/math64.l" "@lib/math32.l")) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/math32.l0000644000000000000000000000067112265263724015175 0ustar rootroot# 18may10abu # (c) Software Lab. Alexander Burger (de pow (X Y) (ext:Pow X Y 1.0) ) (de exp (X) (ext:Exp X 1.0) ) (de log (X) (and (gt0 X) (ext:Log X 1.0)) ) (de sin (A) (ext:Sin A 1.0) ) (de cos (A) (ext:Cos A 1.0) ) (de tan (A) (ext:Tan A 1.0) ) (de asin (A) (ext:Asin A 1.0) ) (de acos (A) (ext:Acos A 1.0) ) (de atan (A) (ext:Atan A 1.0) ) (de atan2 (X Y) (ext:Atan2 X Y 1.0) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/math64.l0000644000000000000000000000151312265263724015176 0ustar rootroot# 02aug10abu # (c) Software Lab. Alexander Burger (setq "Dbl1" (0 . 1.0) "Dbl2" (0 . 1.0) ) (de pow (X Y) (set "Dbl1" X "Dbl2" Y) (native "@" "pow" 1.0 "Dbl1" "Dbl2") ) (de exp (X) (set "Dbl1" X) (native "@" "exp" 1.0 "Dbl1") ) (de log (X) (when (gt0 (set "Dbl1" X)) (native "@" "log" 1.0 "Dbl1") ) ) (de sin (A) (set "Dbl1" A) (native "@" "sin" 1.0 "Dbl1") ) (de cos (A) (set "Dbl1" A) (native "@" "cos" 1.0 "Dbl1") ) (de tan (A) (set "Dbl1" A) (native "@" "tan" 1.0 "Dbl1") ) (de asin (A) (set "Dbl1" A) (native "@" "asin" 1.0 "Dbl1") ) (de acos (A) (set "Dbl1" A) (native "@" "acos" 1.0 "Dbl1") ) (de atan (A) (set "Dbl1" A) (native "@" "atan" 1.0 "Dbl1") ) (de atan2 (X Y) (set "Dbl1" X "Dbl2" Y) (native "@" "atan2" 1.0 "Dbl1" "Dbl2") ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/misc.l0000644000000000000000000003252112265263724015031 0ustar rootroot# 02nov13abu # (c) Software Lab. Alexander Burger # *Allow *Tmp (de *Day . (Mon Tue Wed Thu Fri Sat Sun .)) (de *Mon . (Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec .)) (de *mon . (jan feb mar apr may jun jul aug sep oct nov dec .)) ### Locale ### (de *Ctry) (de *Lang) (de *Sep0 . ".") (de *Sep3 . ",") (de *CtryCode) (de *DateFmt @Y "-" @M "-" @D) (de *DayFmt "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") (de *MonFmt "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") (de locale (Ctry Lang . @) # "DE" "de" ["app/loc/" ..] (load (if (setq *Ctry Ctry) (pack "@loc/" @ ".l") "@loc/NIL.l")) (ifn (setq *Lang Lang) (for S (idx '*Uni) (set S S) ) (let L (sort (make ("loc" (pack "@loc/" Lang)) (while (args) ("loc" (pack (next) Lang)) ) ) ) (balance '*Uni L T) (for S L (set (car (idx '*Uni S)) (val S)) ) ) ) ) (de "loc" (F) (in F (use X (while (setq X (read)) (if (=T X) ("loc" (read)) (set (link @) (name (read))) ) ) ) ) ) ### String ### (de align (X . @) (pack (if (pair X) (mapcar '((X) (need X (chop (next)) " ")) X ) (need X (chop (next)) " ") ) ) ) (de center (X . @) (pack (if (pair X) (let R 0 (mapcar '((X) (let (S (chop (next)) N (>> 1 (+ X (length S)))) (prog1 (need (+ N R) S " ") (setq R (- X N)) ) ) ) X ) ) (let S (chop (next)) (need (>> 1 (+ X (length S))) S " ") ) ) ) ) (de wrap (Max Lst) (setq Lst (split Lst " " "^J")) (pack (make (while Lst (if (>= (length (car Lst)) Max) (link (pop 'Lst) "^J") (chain (make (link (pop 'Lst)) (loop (NIL Lst) (T (>= (+ (length (car Lst)) (sum length (made))) Max) (link "^J") ) (link " " (pop 'Lst)) ) ) ) ) ) ) ) ) ### Number ### (de pad (N Val) (pack (need N (chop Val) "0")) ) (de money (N Cur) (if Cur (pack (format N 2 *Sep0 *Sep3) " " Cur) (format N 2 *Sep0 *Sep3) ) ) (de round (N D) (if (> *Scl (default D 3)) (format (*/ N (** 10 (- *Scl D))) D *Sep0 *Sep3) (format N *Scl *Sep0 *Sep3) ) ) # Binary notation (de bin (X I) (cond ((num? X) (let (S (and (lt0 X) '-) L (& 1 X) A (cons 0 I)) (until (=0 (setq X (>> 1 X))) (at A (push 'L " ")) (push 'L (& 1 X)) ) (pack S L) ) ) ((setq X (filter '((C) (not (sp? C))) (chop X))) (let (S (and (= '- (car X)) (pop 'X)) N 0) (for C X (setq N (| (format C) (>> -1 N))) ) (if S (- N) N) ) ) ) ) # Octal notation (de oct (X I) (cond ((num? X) (let (S (and (lt0 X) '-) L (& 7 X) A (cons 0 I)) (until (=0 (setq X (>> 3 X))) (at A (push 'L " ")) (push 'L (& 7 X)) ) (pack S L) ) ) ((setq X (filter '((C) (not (sp? C))) (chop X))) (let (S (and (= '- (car X)) (pop 'X)) N 0) (for C X (setq N (| (format C) (>> -3 N))) ) (if S (- N) N) ) ) ) ) # Hexadecimal notation (de hex (X I) (cond ((num? X) (let (S (and (lt0 X) '-) L (hex1 X) A (cons 0 I)) (until (=0 (setq X (>> 4 X))) (at A (push 'L " ")) (push 'L (hex1 X)) ) (pack S L) ) ) ((setq X (filter '((C) (not (sp? C))) (chop X))) (let (S (and (= '- (car X)) (pop 'X)) N 0) (for C X (setq C (- (char C) `(char "0"))) (and (> C 9) (dec 'C 7)) (and (> C 22) (dec 'C 32)) (setq N (| C (>> -4 N))) ) (if S (- N) N) ) ) ) ) (de hex1 (N) (let C (& 15 N) (and (> C 9) (inc 'C 7)) (char (+ C `(char "0"))) ) ) # Hexadecimal/Alpha notation (de hax (X) (if (num? X) (pack (mapcar '((C) (when (> (setq C (- (char C) `(char "0"))) 9) (dec 'C 7) ) (char (+ `(char "@") C)) ) (chop (hex X)) ) ) (hex (mapcar '((C) (when (> (setq C (- (char C) `(char "@"))) 9) (inc 'C 7) ) (char (+ `(char "0") C)) ) (chop X) ) ) ) ) # Base 64 notation (de fmt64 (X) (if (num? X) (let L (_fmt64 X) (until (=0 (setq X (>> 6 X))) (push 'L (_fmt64 X)) ) (pack L) ) (let N 0 (for C (chop X) (setq C (- (char C) `(char "0"))) (and (> C 42) (dec 'C 6)) (and (> C 11) (dec 'C 5)) (setq N (+ C (>> -6 N))) ) N ) ) ) (de _fmt64 (N) (let C (& 63 N) (and (> C 11) (inc 'C 5)) (and (> C 42) (inc 'C 6)) (char (+ C `(char "0"))) ) ) ### Tree ### (de balance ("Var" "Lst" "Flg") (unless "Flg" (set "Var")) (let "Len" (length "Lst") (recur ("Lst" "Len") (unless (=0 "Len") (let ("N" (>> 1 (inc "Len")) "L" (nth "Lst" "N")) (idx "Var" (car "L") T) (recurse "Lst" (dec "N")) (recurse (cdr "L") (- "Len" "N")) ) ) ) ) ) (de depth (Idx) #> (max . average) (let (C 0 D 0 N 0) (cons (recur (Idx N) (ifn Idx 0 (inc 'C) (inc 'D (inc 'N)) (inc (max (recurse (cadr Idx) N) (recurse (cddr Idx) N) ) ) ) ) (or (=0 C) (*/ D C)) ) ) ) ### Allow ### (de allowed Lst (setq *Allow (cons NIL (car Lst))) (balance *Allow (sort (cdr Lst))) ) (de allow (X Flg) (nond (*Allow) (Flg (idx *Allow X T)) ((member X (cdr *Allow)) (queue '*Allow X)) ) X ) ### Telephone ### (de telStr (S) (cond ((not S)) ((and *CtryCode (pre? (pack *CtryCode " ") S)) (pack (unless (= 1 *CtryCode) 0) (cdr (member " " (chop S))) ) ) (T (pack "+" S)) ) ) (de expTel (S) (setq S (make (for (L (chop S) L) (ifn (sub? (car L) " -") (link (pop 'L)) (let F NIL (loop (and (= '- (pop 'L)) (on F)) (NIL L) (NIL (sub? (car L) " -") (link (if F '- " ")) ) ) ) ) ) ) ) (cond ((= "+" (car S)) (pack (cdr S))) ((head '("0" "0") S) (pack (cddr S))) ((and *CtryCode (= "0" (car S))) (pack *CtryCode " " (cdr S)) ) ((= 1 *CtryCode) (pack (and S (<> "1" (car S)) "1 ") S) ) ) ) ### Date ### # ISO date (de dat$ (Dat C) (when (date Dat) (pack (car @) C (pad 2 (cadr @)) C (pad 2 (caddr @))) ) ) (de $dat (S C) (if C (and (= 3 (length (setq S (split (chop S) C))) ) (date (format (car S)) # Year (or (format (cadr S)) 0) # Month (or (format (caddr S)) 0) ) ) # Day (and (format S) (date (/ @ 10000) # Year (% (/ @ 100) 100) # Month (% @ 100) ) ) ) ) (de datSym (Dat) (when (date Dat) (pack (pad 2 (caddr @)) (get *mon (cadr @)) (pad 2 (% (car @) 100)) ) ) ) # Localized (de datStr (D F) (when (setq D (date D)) (let (@Y (if F (pad 2 (% (car D) 100)) (pad 4 (car D))) @M (pad 2 (cadr D)) @D (pad 2 (caddr D)) ) (pack (fill *DateFmt)) ) ) ) (de strDat (S) (use (@Y @M @D) (and (match *DateFmt (chop S)) (date (format @Y) (or (format @M) 0) (or (format @D) 0) ) ) ) ) (de expDat (S) (use (@Y @M @D X) (unless (match *DateFmt (setq S (chop S))) (if (or (cdr (setq S (split S "."))) (>= 2 (length (car S))) ) (setq @D (car S) @M (cadr S) @Y (caddr S) ) (setq @D (head 2 (car S)) @M (head 2 (nth (car S) 3)) @Y (nth (car S) 5) ) ) ) (and (setq @D (format @D)) (date (nond (@Y (car (date (date)))) ((setq X (format @Y))) ((>= X 100) (+ X (* 100 (/ (car (date (date))) 100)) ) ) (NIL X) ) (nond (@M (cadr (date (date)))) ((setq X (format @M)) 0) ((n0 X) (cadr (date (date)))) (NIL X) ) @D ) ) ) ) # Day of the week (de day (Dat Lst) (get (or Lst *DayFmt) (inc (% (inc Dat) 7)) ) ) # Week of the year (de week (Dat) (let W (- (_week Dat) (_week (date (car (date Dat)) 1 4)) -1 ) (if (=0 W) 53 W) ) ) (de _week (Dat) (/ (- Dat (% (inc Dat) 7)) 7) ) # Last day of month (de ultimo (Y M) (dec (if (= 12 M) (date (inc Y) 1 1) (date Y (inc M) 1) ) ) ) ### Time ### (de tim$ (Tim F) (when Tim (setq Tim (time Tim)) (pack (pad 2 (car Tim)) ":" (pad 2 (cadr Tim)) (and F ":") (and F (pad 2 (caddr Tim))) ) ) ) (de $tim (S) (setq S (split (chop S) ":")) (unless (or (cdr S) (>= 2 (length (car S)))) (setq S (list (head 2 (car S)) (head 2 (nth (car S) 3)) (nth (car S) 5) ) ) ) (when (format (car S)) (time @ (or (format (cadr S)) 0) (or (format (caddr S)) 0) ) ) ) (de stamp (Dat Tim) (and (=T Dat) (setq Dat (date T))) (default Dat (date) Tim (time T)) (pack (dat$ Dat "-") " " (tim$ Tim T)) ) ### I/O ### (de chdir ("Dir" . "Prg") (let? "Old" (cd "Dir") (finally (cd "Old") (run "Prg") ) ) ) (de dirname (F) (pack (flip (member '/ (flip (chop F))))) ) (de basename (F) (pack (stem (chop F) '/)) ) # Print or eval (de prEval (Prg Ofs) (default Ofs 1) (for X Prg (if (atom X) (prinl (eval X Ofs)) (eval X Ofs) ) ) ) # Echo here-documents (de here (S) (line) (echo S) ) # Send mail (de mail (Host Port From To Sub Att . Prg) (let? S (connect Host Port) (let B (pack "==" (date) "-" (time T) "==") (prog1 (and (pre? "220 " (in S (line T))) (out S (prinl "HELO " (cdr (member "@" (chop From))) "^M")) (pre? "250 " (in S (line T))) (out S (prinl "MAIL FROM:" From "^M")) (pre? "250 " (in S (line T))) (if (atom To) (_rcpt To) (find bool (mapcar _rcpt To)) ) (out S (prinl "DATA^M")) (pre? "354 " (in S (line T))) (out S (prinl "From: " From "^M") (prinl "To: " (or (fin To) (glue "," To)) "^M") (prinl "Subject: " Sub "^M") (prinl "User-Agent: PicoLisp^M") (prinl "MIME-Version: 1.0^M") (when Att (prinl "Content-Type: multipart/mixed; boundary=\"" B "\"^M") (prinl "^M") (prinl "--" B "^M") ) (prinl "Content-Type: text/plain; charset=utf-8^M") (prinl "Content-Transfer-Encoding: 8bit^M") (prinl "^M") (prEval Prg 2) (prinl "^M") (when Att (loop (prinl "--" B "^M") (prinl "Content-Type: " (or (caddr Att) "application/octet-stream") "; name=\"" (cadr Att) "\"^M" ) (prinl "Content-Transfer-Encoding: base64^M") (prinl "^M") (in (car Att) (while (do 15 (NIL (ext:Base64 (rd 1) (rd 1) (rd 1))) T ) (prinl) ) ) (prinl) (prinl "^M") (NIL (setq Att (cdddr Att))) ) (prinl "--" B "--^M") ) (prinl ".^M") (prinl "QUIT^M") ) T ) (close S) ) ) ) ) (de _rcpt (To) (out S (prinl "RCPT TO:" To "^M")) (pre? "250 " (in S (line T))) ) ### Debug ### `*Dbg # Hex Dump (de hd (File Cnt) (in File (let Pos 0 (while (and (nand Cnt (lt0 (dec 'Cnt))) (make (do 16 (and (rd 1) (link @)))) ) (let L @ (prin (pad 8 (hex Pos)) " ") (inc 'Pos 16) (for N L (prin (pad 2 (hex N)) " ") ) (space (inc (* 3 (- 16 (length L))))) (for N L (prin (if (>= 126 N 32) (char N) ".")) ) (prinl) ) ) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/native.l0000644000000000000000000000220612265263724015361 0ustar rootroot# 05nov12abu # (c) Software Lab. Alexander Burger (de gcc (Nm L . Lst) (out (tmp Nm ".c") (here "/**/")) ~(case *OS (("Linux" "FreeBSD") (quote (apply call L 'gcc "-o" (tmp Nm) "-fPIC" "-shared" "-export-dynamic" "-O" "-falign-functions" "-fomit-frame-pointer" "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" "-Wuninitialized" "-Wstrict-prototypes" "-pipe" "-D_GNU_SOURCE" (tmp Nm ".c") ) ) ) ("SunOS" (quote (apply call L 'gcc "-o" (tmp Nm) "-fPIC" "-shared" "-O" "-falign-functions" "-fomit-frame-pointer" "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" "-Wuninitialized" "-Wstrict-prototypes" "-pipe" "-D_GNU_SOURCE" (tmp Nm ".c") ) ) ) ) (for L Lst (def (car L) (list (cadr L) (cons 'native (tmp Nm) (name (caddr L)) (cdddr L)) ) ) (when (== '@ (fin (cadr L))) (push (cdaar L) 'pass) ) ) ) (de unsigned (N) (& `(dec (** 2 32)) (+ N `(** 2 32))) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/openGl.l0000644000000000000000000002516112265263724015324 0ustar rootroot# 09nov12abu # 27jul10jk # (c) Software Lab. Alexander Burger ### OpenGL library interface ### (load "@lib/math.l") (if (= *OS "Darwin") (default *GluLib "OpenGL.framework/OpenGL" *GlutLib "GLUT.framework/GLUT" ) (default *GluLib "libGLU.so" *GlutLib "libglut.so" ) ) # Pre-consed fixpoint arguments (setq "Flt1" (0 . -1.0) "Flt2" (0 . -1.0) "Flt3" (0 . -1.0) "Flt4" (0 . -1.0) "Dbl1" (0 . 1.0) "Dbl2" (0 . 1.0) "Dbl3" (0 . 1.0) "Dbl4" (0 . 1.0) "Dbl5" (0 . 1.0) "Dbl6" (0 . 1.0) ) # Utilities (de ivect (Lst) (mapcar '((N) (- -4294967296 N)) Lst) ) (de fvect (Lst) (mapcar '((N) (- -4294967296 (*/ 2147483647 N 1.0))) Lst ) ) ### /usr/include/GL/gl.h ### ### Constant Definitions ### # Primitives (def 'GL_POINTS (hex "0000")) (def 'GL_LINES (hex "0001")) (def 'GL_LINE_LOOP (hex "0002")) (def 'GL_LINE_STRIP (hex "0003")) (def 'GL_TRIANGLES (hex "0004")) (def 'GL_TRIANGLE_STRIP (hex "0005")) (def 'GL_TRIANGLE_FAN (hex "0006")) (def 'GL_QUADS (hex "0007")) (def 'GL_QUAD_STRIP (hex "0008")) (def 'GL_POLYGON (hex "0009")) # Matrix Mode (def 'GL_MATRIX_MODE (hex "0BA0")) (def 'GL_MODELVIEW (hex "1700")) (def 'GL_PROJECTION (hex "1701")) (def 'GL_TEXTURE (hex "1702")) # Points # Lines (def 'GL_LINE_SMOOTH (hex "00000B20")) # Polygons (def 'GL_FRONT (hex "0404")) (def 'GL_CULL_FACE (hex "00000B44")) # Display Lists # Depth buffer (def 'GL_LESS (hex "00000201")) (def 'GL_DEPTH_TEST (hex "00000B71")) # Lighting (def 'GL_LIGHTING (hex "0B50")) (def 'GL_LIGHT0 (hex "4000")) (def 'GL_SPECULAR (hex "1202")) (def 'GL_SHININESS (hex "1601")) (def 'GL_POSITION (hex "1203")) (def 'GL_AMBIENT_AND_DIFFUSE (hex "1602")) (def 'GL_FRONT_AND_BACK (hex "0408")) (def 'GL_FLAT (hex "1D00")) (def 'GL_SMOOTH (hex "1D01")) (def 'GL_COLOR_MATERIAL (hex "0B57")) # User clipping planes # Accumulation buffer # Alpha testing # Blending (def 'GL_BLEND (hex "0BE2")) (def 'GL_SRC_ALPHA (hex "0302")) (def 'GL_ONE_MINUS_SRC_ALPHA (hex "0303")) # Render Mode # Feedback # Selection # Fog # Logic Ops # Stencil # Buffers, Pixel Drawing/Reading # Implementation limits # Gets # Evaluators # Hints (def 'GL_LINE_SMOOTH_HINT (hex "0C52")) (def 'GL_NICEST (hex "1102")) # Scissor box # Pixel Mode / Transfer # Texture mapping # Utility # Errors # glPush/PopAttrib bits (def 'GL_CURRENT_BIT (hex "00000001")) (def 'GL_POINT_BIT (hex "00000002")) (def 'GL_LINE_BIT (hex "00000004")) (def 'GL_POLYGON_BIT (hex "00000008")) (def 'GL_POLYGON_STIPPLE_BIT (hex "00000010")) (def 'GL_PIXEL_MODE_BIT (hex "00000020")) (def 'GL_LIGHTING_BIT (hex "00000040")) (def 'GL_FOG_BIT (hex "00000080")) (def 'GL_DEPTH_BUFFER_BIT (hex "00000100")) (def 'GL_ACCUM_BUFFER_BIT (hex "00000200")) (def 'GL_STENCIL_BUFFER_BIT (hex "00000400")) (def 'GL_VIEWPORT_BIT (hex "00000800")) (def 'GL_TRANSFORM_BIT (hex "00001000")) (def 'GL_ENABLE_BIT (hex "00002000")) (def 'GL_COLOR_BUFFER_BIT (hex "00004000")) (def 'GL_HINT_BIT (hex "00008000")) (def 'GL_EVAL_BIT (hex "00010000")) (def 'GL_LIST_BIT (hex "00020000")) (def 'GL_TEXTURE_BIT (hex "00040000")) (def 'GL_SCISSOR_BIT (hex "00080000")) (def 'GL_ALL_ATTRIB_BITS (hex "000FFFFF")) # Miscellaneous (de glClearColor (Red Green Blue Alpha) (set "Flt1" Red "Flt2" Green "Flt3" Blue "Flt4" Alpha) (native `*GlutLib "glClearColor" NIL "Flt1" "Flt2" "Flt3" "Flt4") ) (de glClear (Mask) (native `*GlutLib "glClear" NIL Mask) ) (de glBlendFunc (SFactor DFactor) (native `*GlutLib "glBlendFunc" NIL SFactor DFactor) ) (de glLineWidth (Width) (set "Flt1" Width) (native `*GlutLib "glLineWidth" NIL "Flt1") ) (de glEnable (Num) (native `*GlutLib "glEnable" NIL Num) ) (de glDisable (Num) (native `*GlutLib "glDisable" NIL Num) ) (de glFlush () (native `*GlutLib "glFlush") ) (de glHint (Target Mode) (native `*GlutLib "glHint" NIL Target Mode) ) # Depth Buffer (de glClearDepth (Depth) (set "Dbl1" Depth) (native `*GlutLib "glClearDepth" NIL "Dbl1") ) (de glDepthFunc (Num) (native `*GlutLib "glDepthFunc" NIL Num) ) # Accumulation Buffer # Transformation (de glMatrixMode (Mode) (native `*GlutLib "glMatrixMode" NIL Mode) ) (de glOrtho (Left Right Bottom Top Near Far) (set "Dbl1" Left "Dbl2" Right "Dbl3" Bottom "Dbl4" Top "Dbl5" Near "Dbl6" Far) (native `*GlutLib "glOrtho" NIL "Dbl1" "Dbl2" "Dbl3" "Dbl4" "Dbl5" "Dbl6") ) (de glViewport (X Y Width Height) (native `*GlutLib "glViewport" NIL X Y Width Height) ) (de glPushMatrix () (native `*GlutLib "glPushMatrix") ) (de glPopMatrix () (native `*GlutLib "glPopMatrix") ) (de glLoadIdentity () (native `*GlutLib "glLoadIdentity") ) (de glRotatef (A X Y Z) (set "Flt1" A "Flt2" X "Flt3" Y "Flt4" Z) (native `*GlutLib "glRotatef" NIL "Flt1" "Flt2" "Flt3" "Flt4") ) (de glTranslatef (X Y Z) (set "Flt1" X "Flt2" Y "Flt3" Z) (native `*GlutLib "glTranslatef" NIL "Flt1" "Flt2" "Flt3") ) # Display Lists # Drawing Functions (de glBegin (Mode) (native `*GlutLib "glBegin" NIL Mode) ) (de glEnd () (native `*GlutLib "glEnd") ) (de glVertex2f (X Y) (set "Flt1" X "Flt2" Y) (native `*GlutLib "glVertex2f" NIL "Flt1" "Flt2") ) (de glVertex3f (X Y Z) (set "Flt1" X "Flt2" Y "Flt3" Z) (native `*GlutLib "glVertex3f" NIL "Flt1" "Flt2" "Flt3") ) (de glNormal3f (X Y Z) (set "Flt1" X "Flt2" Y "Flt3" Z) (native `*GlutLib "glNormal3f" NIL "Flt1" "Flt2" "Flt3") ) (de glColor3f (Red Green Blue) (set "Flt1" Red "Flt2" Green "Flt3" Blue) (native `*GlutLib "glColor3f" NIL "Flt1" "Flt2" "Flt3") ) (de glColor4f (Red Green Blue Alpha) (set "Flt1" Red "Flt2" Green "Flt3" Blue "Flt4" Alpha) (native `*GlutLib "glColor4f" NIL "Flt1" "Flt2" "Flt3" "Flt4") ) # Vertex Arrays # Lighting (de glShadeModel (Num) (native `*GlutLib "glShadeModel" NIL Num) ) (de glLightiv (Light Pname Params) (native `*GlutLib "glLightiv" NIL Light Pname (cons NIL (16) (ivect Params)) ) ) (de glMaterialf (Face Pname Param) (set "Flt1" Param) (native `*GlutLib "glMaterialf" NIL Face Pname "Flt1") ) (de glMaterialfv (Face Pname Params) # Calls 'iv' internally! (native `*GlutLib "glMaterialiv" NIL Face Pname (cons NIL (16) (fvect Params)) ) ) (de glColorMaterial (Face Mode) (native `*GlutLib "glColorMaterial" NIL Face Mode) ) # Raster functions # Stenciling # Texture mapping # Evaluators # Fog # Selection and Feedback ### /usr/include/GL/glu.h ### (de gluPerspective (Fovy Aspect ZNear ZFar) (set "Dbl1" Fovy "Dbl2" Aspect "Dbl3" ZNear "Dbl4" ZFar) (native `*GluLib "gluPerspective" NIL "Dbl1" "Dbl2" "Dbl3" "Dbl4") ) ### /usr/include/GL/freeglut_std.h ### # Special key codes (def 'GLUT_KEY_F1 1) (def 'GLUT_KEY_F2 2) (def 'GLUT_KEY_F3 3) (def 'GLUT_KEY_F4 4) (def 'GLUT_KEY_F5 5) (def 'GLUT_KEY_F6 6) (def 'GLUT_KEY_F7 7) (def 'GLUT_KEY_F8 8) (def 'GLUT_KEY_F9 9) (def 'GLUT_KEY_F10 10) (def 'GLUT_KEY_F11 11) (def 'GLUT_KEY_F12 12) (def 'GLUT_KEY_LEFT 100) (def 'GLUT_KEY_UP 101) (def 'GLUT_KEY_RIGHT 102) (def 'GLUT_KEY_DOWN 103) (def 'GLUT_KEY_PAGE_UP 104) (def 'GLUT_KEY_PAGE_DOWN 105) (def 'GLUT_KEY_HOME 106) (def 'GLUT_KEY_END 107) (def 'GLUT_KEY_INSERT 108) # Mouse state definitions (def 'GLUT_LEFT_BUTTON 0) (def 'GLUT_MIDDLE_BUTTON 1) (def 'GLUT_RIGHT_BUTTON 2) # Display mode definitions (def 'GLUT_RGB (hex "0000")) (def 'GLUT_RGBA (hex "0000")) (def 'GLUT_INDEX (hex "0001")) (def 'GLUT_SINGLE (hex "0000")) (def 'GLUT_DOUBLE (hex "0002")) (def 'GLUT_ACCUM (hex "0004")) (def 'GLUT_ALPHA (hex "0008")) (def 'GLUT_DEPTH (hex "0010")) (def 'GLUT_STENCIL (hex "0020")) (def 'GLUT_MULTISAMPLE (hex "0080")) (def 'GLUT_STEREO (hex "0100")) (def 'GLUT_LUMINANCE (hex "0200")) ### Native functions ### # Initialization functions (de glutInit () (native `*GlutLib "glutInit" NIL '(NIL (8) . 0)) ) (de glutInitWindowPosition (Width Height) (native `*GlutLib "glutInitWindowPosition" NIL Width Height) ) (de glutInitWindowSize (Width Height) (native `*GlutLib "glutInitWindowSize" NIL Width Height) ) (de glutInitDisplayMode (N) (native `*GlutLib "glutInitDisplayMode" NIL N) ) # Process loop function (de glutMainLoop () (native `*GlutLib "glutMainLoop") ) # Window management functions (de glutCreateWindow (Name) (native `*GlutLib "glutCreateWindow" NIL Name) ) # Display-connected functions (de glutPostRedisplay () (native `*GlutLib "glutPostRedisplay") ) (de glutSwapBuffers () (native `*GlutLib "glutSwapBuffers") ) # Mouse cursor functions # Overlay stuff # Menu stuff (de createMenu (Fun) (native `*GlutLib "glutCreateMenu" NIL (lisp 'createMenu Fun)) ) (de glutAddMenuEntry (Name Val) (native `*GlutLib "glutAddMenuEntry" NIL Name Val) ) (de glutAttachMenu (Button) (native `*GlutLib "glutAttachMenu" NIL Button) ) # Global callback functions (de timerFunc (Msec Fun Val) (native `*GlutLib "glutTimerFunc" NIL Msec (lisp 'timerFunc Fun) Val) ) # Window-specific callback functions (de keyboardFunc (Fun) (native `*GlutLib "glutKeyboardFunc" NIL (lisp 'keyboardFunc Fun)) ) (de specialFunc (Fun) (native `*GlutLib "glutSpecialFunc" NIL (lisp 'specialFunc Fun)) ) (de reshapeFunc (Fun) (native `*GlutLib "glutReshapeFunc" NIL (lisp 'reshapeFunc Fun)) ) (de displayPrg Prg (native `*GlutLib "glutDisplayFunc" NIL (lisp 'displayPrg (cons NIL Prg))) ) (de mouseFunc (Fun) (native `*GlutLib "glutMouseFunc" NIL (lisp 'mouseFunc Fun)) ) (de motionFunc (Fun) (native `*GlutLib "glutMotionFunc" NIL (lisp 'motionFunc Fun)) ) # State setting and retrieval functions # Font stuff # Geometry functions (de glutWireCube (Size) (set "Dbl1" Size) (native `*GlutLib "glutWireCube" NIL "Dbl1") ) (de glutSolidCube (Size) (set "Dbl1" Size) (native `*GlutLib "glutSolidCube" NIL "Dbl1") ) (de glutWireSphere (Radius Slices Stacks) (set "Dbl1" Radius) (native `*GlutLib "glutWireSphere" NIL "Dbl1" Slices Stacks) ) (de glutSolidSphere (Radius Slices Stacks) (set "Dbl1" Radius) (native `*GlutLib "glutSolidSphere" NIL "Dbl1" Slices Stacks) ) # Teapot rendering functions # Game mode functions # Video resize functions # Colormap functions # Misc keyboard and joystick functions # Misc functions # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/phone.css0000644000000000000000000000066012265263724015543 0ustar rootroot/* 08dec13abu * (c) Software Lab. Alexander Burger */ .rel10 {width: 10%} .rel20 {width: 20%} .rel40 {width: 40%} .rel50 {width: 50%} .rel60 {width: 60%} .rel80 {width: 80%} .rel100 {width: 100%} body { font-size: larger; } caption { margin: 0; } #expires { font-size: smaller; } /* Form header */ .fh { margin: 2px 6px; } /* Main area */ .main { padding: 0; } /* Charts */ .chart { font-size: smaller; } picolisp-3.1.5.2.orig/lib/pilog.l0000644000000000000000000003652112265263724015214 0ustar rootroot# 05dec13abu # (c) Software Lab. Alexander Burger # *Rule (de be CL (clause CL) ) (de clause (CL) (with (car CL) (if (== *Rule This) (queue (:: T) (cdr CL)) (=: T (cons (cdr CL))) (setq *Rule This) ) This ) ) (de repeat () (conc (get *Rule T) (get *Rule T)) ) (de asserta (CL) (push (prop CL 1 T) (cdr CL)) ) (de assertz (CL) (queue (prop CL 1 T) (cdr CL)) ) (de retract (X) (if (sym? X) (put X T) (put (car X) T (delete (cdr X) (get (car X) T)) ) ) ) (de rules @ (while (args) (let S (next) (for ((N . L) (get S T) L) (prin N " (be ") (print S) (for X (pop 'L) (space) (print X) ) (prinl ")") (T (== L (get S T)) (println '(repeat)) ) ) S ) ) ) ### Pilog Interpreter ### (de goal ("CL" . @) (let "Env" '(T) (while (args) (push '"Env" (cons (cons 0 (next)) 1 (next)) ) ) (while (and "CL" (pat? (car "CL"))) (push '"Env" (cons (cons 0 (pop '"CL")) (cons 1 (eval (pop '"CL"))) ) ) ) (cons (cons (conc (list 1 (0) NIL "CL" NIL) "Env") ) ) ) ) (de fail () (goal '((NIL))) ) (de pilog ("CL" . "Prg") (for ("Q" (goal "CL") (prove "Q")) (bind @ (run "Prg")) ) ) (de solve ("CL" . "Prg") (make (if "Prg" (for ("Q" (goal "CL") (prove "Q")) (link (bind @ (run "Prg"))) ) (for ("Q" (goal "CL") (prove "Q")) (link @) ) ) ) ) (de query ("Q" "Dbg") (use "R" (loop (NIL (prove "Q" "Dbg")) (T (=T (setq "R" @)) T) (for X "R" (space) (print (car X)) (print '=) (print (cdr X)) (flush) ) (T (line)) ) ) ) (de ? "CL" (let "L" (make (while (nor (pat? (car "CL")) (lst? (car "CL"))) (link (pop '"CL")) ) ) (query (goal "CL") "L") ) ) ### Basic Rules ### (be repeat) (repeat) (be true) (be not @P (1 (-> @P)) T (fail)) (be not @P) (be call @P (2 (cons (-> @P))) ) (be or @L (^ @C (box (-> @L))) (_or @C)) (be _or (@C) (3 (pop (-> @C)))) (be _or (@C) (^ @ (not (val (-> @C)))) T (fail)) (repeat) (be nil (@X) (^ @ (not (-> @X)))) (be equal (@X @X)) (be different (@X @X) T (fail)) (be different (@ @)) (be append (NIL @X @X)) (be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) (be member (@X (@X . @))) (be member (@X (@ . @Y)) (member @X @Y)) (be delete (@A (@A . @Z) @Z)) (be delete (@A (@X . @Y) (@X . @Z)) (delete @A @Y @Z) ) (be permute ((@X) (@X))) (be permute (@L (@X . @Y)) (delete @X @L @D) (permute @D @Y) ) (be uniq (@B @X) (^ @ (not (idx (-> @B) (-> @X) T))) ) (be asserta (@C) (^ @ (asserta (-> @C)))) (be assertz (@C) (^ @ (assertz (-> @C)))) (be retract (@C) (2 (cons (-> @C))) (^ @ (retract (list (car (-> @C)) (cdr (-> @C))))) ) (be clause ("@H" "@B") (^ "@A" (get (-> "@H") T)) (member "@B" "@A") ) (be show (@X) (^ @ (show (-> @X)))) (be for (@N @End) (for @N 1 @End 1)) (be for (@N @Beg @End) (for @N @Beg @End 1)) (be for (@N @Beg @End @Step) (equal @N @Beg)) (be for (@N @Beg @End @Step) (^ @I (box (-> @Beg))) (_for @N @I @End @Step) ) (be _for (@N @I @End @Step) (^ @ (if (>= (-> @End) (val (-> @I))) (> (inc (-> @I) (-> @Step)) (-> @End)) (> (-> @End) (dec (-> @I) (-> @Step))) ) ) T (fail) ) (be _for (@N @I @End @Step) (^ @N (val (-> @I))) ) (repeat) ### DB ### (de initQuery (Var Cls Hook Val) (let (Tree (tree Var Cls Hook) Rel (get Cls Var)) (when (find '((B) (isa '+index B)) (get Rel 'bag)) (setq Rel @) ) (when (isa '+Fold Rel) (setq Val (fold Val)) ) (cond ((pair Val) (cond ((pair (cdr Val)) (cond ((not (; Rel aux)) (quit "No Aux")) ((atom (car Val)) (and (; Rel ub) (setq Val (ubZval Val))) (init Tree Val (append Val T)) ) ((; Rel ub) (init Tree (ubZval (car Val)) (ubZval (cdr Val) T) ) ) ((>= (cdr Val) (car Val)) (init Tree (car Val) (append (cdr Val) T)) ) (T (init Tree (append (car Val) T) (cdr Val))) ) ) ((isa '+Key Rel) (init Tree (car Val) (cdr Val)) ) ((>= (cdr Val) (car Val)) (init Tree (cons (car Val)) (cons (cdr Val) T) ) ) (T (init Tree (cons (car Val) T) (cons (cdr Val)) ) ) ) ) ((or (num? Val) (ext? Val)) (if (isa '+Key Rel) (init Tree Val Val) (init Tree (cons Val) (cons Val T)) ) ) ((=T Val) (init Tree)) ((isa '+Key Rel) (init Tree Val (pack Val `(char T))) ) ((isa '+Idx Rel) (let Q (init Tree (cons Val) (cons (pack Val `(char T)) T)) (if (cdr Q) Q (setq Val (pack (car (split (chop Val) " ")))) (init Tree (cons Val) (cons (pack Val `(char T)) T)) ) ) ) (T (init Tree (cons Val) (cons (pack Val `(char T)) T))) ) ) ) # (db var cls obj) (be db (@Var @Cls @Obj) (^ @Q (box (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) (initQuery (: var) (: cls) NIL '(NIL . T)) ) ) ) (_db @Obj) ) # (db var cls hook|val obj) (be db (@Var @Cls @X @Obj) (^ @Q (box (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) (if (: hook) (initQuery (: var) (: cls) (-> @X) '(NIL . T)) (initQuery (: var) (: cls) NIL (-> @X)) ) ) ) ) (_db @Obj) ) # (db var cls hook val obj) (be db (@Var @Cls @Hook @Val @Obj) (^ @Q (box (with (or (get (-> @Cls) (-> @Var)) (meta (-> @Cls) (-> @Var))) (initQuery (: var) (: cls) (-> @Hook) (-> @Val)) ) ) ) (_db @Obj) ) (be _db (@Obj) (^ @ (let (Q (val (-> @Q 2)) Cls (-> @Cls 2)) (loop (NIL (step Q (= '(NIL) (caaar Q))) T) (T (isa Cls (setq "R" @))) ) ) ) T (fail) ) (be _db (@Obj) (^ @Obj "R")) (repeat) (be val (@V . @L) (^ @V (apply get (-> @L))) T ) (be lst (@V . @L) (^ @Lst (box (apply get (-> @L)))) (_lst @V @Lst) ) (be _lst (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) (be _lst (@Val @Lst) (^ @Val (pop (-> @Lst)))) (repeat) (be map (@V . @L) (^ @Lst (box (apply get (-> @L)))) (_map @V @Lst) ) (be _map (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) (be _map (@Val @Lst) (^ @Val (prog1 (val (-> @Lst)) (pop (-> @Lst))))) (repeat) (be isa (@Typ . @L) (^ @ (or (not (-> @Typ)) (isa (-> @Typ) (apply get (-> @L))) ) ) ) (be same (@V . @L) (^ @ (let V (-> @V) (or (not V) (let L (-> @L) ("same" (car L) (cdr L)) ) ) ) ) ) (de "same" (X L) (cond ((not L) (if (atom X) (= V X) (member V X) ) ) ((atom X) ("same" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("same" (get Y (car L)) (cdr L))) X ) ) (T ("same" (apply get (car L) X) (cdr L))) ) ) (be bool (@F . @L) (^ @ (or (not (-> @F)) (bool (apply get (-> @L))) ) ) ) (be ub (@A @R . @L) (^ @ (let R (-> @R) (or (not R) (let X (apply get (-> @L)) (not (find '((K V1 V2) (not (>= V2 (get X K) V1)) ) (-> @A) (car R) (cdr R) ) ) ) ) ) ) ) (be range (@R . @L) (^ @ (let R (-> @R) (or (not R) (let L (-> @L) ("range" (car L) (cdr L)) ) ) ) ) ) (de "range" (X L) (cond ((not L) (if (atom X) (or (<= (car R) X (cdr R)) (>= (car R) X (cdr R)) ) (find '((Y) (or (<= (car R) Y (cdr R)) (>= (car R) Y (cdr R)) ) ) X ) ) ) ((atom X) ("range" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("range" (get Y (car L)) (cdr L))) X ) ) (T ("range" (apply get (car L) X) (cdr L))) ) ) (be head (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) ("head" (car L) (cdr L)) ) ) ) ) ) (de "head" (X L) (cond ((not L) (if (atom X) (pre? S X) (find '((Y) (pre? S Y)) X) ) ) ((atom X) ("head" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("head" (get Y (car L)) (cdr L))) X ) ) (T ("head" (apply get (car L) X) (cdr L))) ) ) (be hold (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) ("hold" (car L) (cdr L)) ) ) ) ) ) (de "hold" (X L) (cond ((not L) (if (atom X) (sub? S X) (find '((Y) (sub? S Y)) X) ) ) ((atom X) ("hold" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("hold" (get Y (car L)) (cdr L))) X ) ) (T ("hold" (apply get (car L) X) (cdr L))) ) ) (be fold (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) (setq S (fold S)) ("fold" (car L) (cdr L)) ) ) ) ) ) (de "fold" (X L) (cond ((not L) (if (atom X) (pre? S (fold X)) (find '((Y) (pre? S (fold Y))) X) ) ) ((atom X) ("fold" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("fold" (get Y (car L)) (cdr L))) X ) ) (T ("fold" (apply get (car L) X) (cdr L))) ) ) (be part (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) (setq S (fold S)) ("part" (car L) (cdr L)) ) ) ) ) ) (de "part" (X L) (cond ((not L) (if (atom X) (sub? S (fold X)) (find '((Y) (sub? S (fold Y))) X) ) ) ((atom X) ("part" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("part" (get Y (car L)) (cdr L))) X ) ) (T ("part" (apply get (car L) X) (cdr L))) ) ) (be tolr (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) ("tolr" (car L) (cdr L)) ) ) ) ) ) (de "tolr" (X L) (cond ((not L) (if (atom X) (or (sub? S X) (pre? (ext:Snx S) (ext:Snx X))) (let P (ext:Snx S) (find '((Y) (or (sub? S Y) (pre? P (ext:Snx Y))) ) X ) ) ) ) ((atom X) ("tolr" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("tolr" (get Y (car L)) (cdr L))) X ) ) (T ("tolr" (apply get (car L) X) (cdr L))) ) ) (de "select" (Lst Flg) (let? X (nond ((atom (car Lst)) (make (for (L (pop 'Lst) L) (let (Var (pop 'L) Cls (pop 'L) Hook (and (get Cls Var 'hook) (pop 'L)) Val (pop 'L) ) (and (or Val Flg) (chain ("initSel"))) ) ) ) ) ((pat? (car Lst)) (let (Var (pop 'Lst) Cls (pop 'Lst) Hook (and (get Cls Var 'hook) (pop 'Lst)) Val (pop 'Lst) ) (and (or Val Flg) ("initSel")) ) ) (NIL (let (Var (pop 'Lst) Val (pop 'Lst)) (and (or Flg (apply or Val)) (cons Var (goal (pop 'Lst))) ) ) ) ) (cons (cons (for (L NIL Lst) (push 'L (pop 'Lst) NIL) L ) X ) ) ) ) (de "initSel" () (with (treeRel Var Cls) (if (isa '+Sn This) (conc (initQuery Var (: cls) Hook Val) (initQuery Var (: cls) Hook (ext:Snx Val)) ) (initQuery Var (: cls) Hook Val) ) ) ) (de _gen (Lst Q) (cond (Lst (use X (loop (T (cond ((atom (car Lst)) (prog1 (car Lst) (set Lst)) ) ((atom (caar Lst)) (pop Lst)) (T (prog1 (step (car Lst) (= '(NIL) (caar (caar Lst)))) (or (cdaar Lst) (set Lst)) ) ) ) @ ) (NIL (setq X (_gen (cddr Lst) Q))) (set Lst (let Y (cadr Lst) (cond ((atom Y) (get X Y)) ((=T (caddr Y)) (initQuery (car Y) (cadr Y) X (cadddr Y)) ) # X = Hook (T (initQuery (car Y) (cadr Y) (caddr Y) (if (cadddr Y) (cons (cons X (car @)) (cons X (cdr @)) ) X ) ) ) ) ) ) ) ) ) ((pat? (car Q)) (get (prove (cdr Q)) @)) (T (step Q (= '(NIL) (caaar Q)))) ) ) (be select (("@Obj" . "@X") . "@Lst") (^ @ (unify (-> "@X"))) (^ "@P" (box (cdr (-> "@Lst")))) (^ "@C" (box # ((obj ..) curr . lst) (let L (car (-> "@Lst")) (setq L (or (mapcan "select" L) ("select" (car L) T) ) ) (cons NIL L L) ) ) ) (_gen "@Obj") (_sel) ) (be _gen (@Obj) (^ @ (let C (caadr (val (-> "@C" 2))) (not (setq "*R" (_gen (car C) (cdr C)))) ) ) T (fail) ) (be _gen (@Obj) (^ @Obj "*R")) (repeat) (be _sel () (2 (val (-> "@P" 2))) (^ @ (let C (val (-> "@C" 2)) (unless (idx C "*R" T) (rot (cddr C) (offset (cadr C) (cddr C))) (set (cdr C) (cddr C)) ) ) ) T ) (be _sel () (^ @ (let C (cdr (val (-> "@C" 2))) (set C (or (cdar C) (cdr C))) ) ) (fail) ) ### Remote queries ### (de rqry Args (for (Q (goal (cdr Args)) (prove Q)) (pr (get @ (car Args))) (NIL (flush)) ) (bye) ) (be remote ("@Lst" . "@CL") (^ @Sockets (box (prog1 (cdr (-> "@Lst")) (for X @ # (out . in) ((car X) (cons 'rqry (car (-> "@Lst")) (-> "@CL")) ) ) ) ) ) (^ @ (unify (car (-> "@Lst")))) (_remote "@Lst") ) (be _remote ((@Obj . @)) (^ @ (not (val (-> @Sockets 2)))) T (fail) ) (be _remote ((@Obj . @)) (^ @Obj (let (Box (-> @Sockets 2) Lst (val Box)) (rot Lst) (loop (T ((cdar Lst)) @) (NIL (set Box (setq Lst (cdr Lst)))) ) ) ) ) (repeat) ### Debug ### `*Dbg (load "@lib/sq.l") # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/plio.js0000644000000000000000000000305012265263724015215 0ustar rootroot/* 30oct13abu * (c) Software Lab. Alexander Burger */ function plio(lst) { var NIX = 0; var BEG = 1; var DOT = 2; var END = 3; var NUMBER = 0; var INTERN = 1; var TRANSIENT = 2; var PlioPos = 1; var PlioLst = lst; var PlioCnt, PlioMore; function byte() { if (PlioCnt == 0) { if (!PlioMore) return -1; PlioMore = (PlioCnt = PlioLst[PlioPos++]) == 255; } --PlioCnt; return PlioLst[PlioPos++]; } function expr(c) { if ((c & ~3) !== 0) { // Atom PlioMore = (PlioCnt = c >> 2) === 63; if ((c & 3) === NUMBER) { c = byte(); var n = c >> 1; var s = c & 1; var m = 128; while ((c = byte()) >= 0) { n += c * m; m *= 256; } return s == 0? n : -n; } var str = ""; // TRANSIENT while ((c = byte()) >= 0) { if ((c & 0x80) != 0) { if ((c & 0x20) == 0) c &= 0x1F; else c = (c & 0xF) << 6 | byte() & 0x3F; c = c << 6 | byte() & 0x3F; } str += String.fromCharCode(c); } return str; } if (c !== BEG) // NIX, DOT or END return null; var i = 0; var lst = new Array(); lst[0] = expr(PlioLst[PlioPos++]); while ((c = PlioLst[PlioPos++]) !== END && c !== DOT) lst[++i] = expr(c); return lst; } return expr(PlioLst[0]); } picolisp-3.1.5.2.orig/lib/prof.l0000644000000000000000000000240412265263724015041 0ustar rootroot# 15may07abu # (c) Software Lab. Alexander Burger # *Profile (de _prf? (Lst) (and (pair Lst) (== 'tick (caadr Lst))) ) (de _prf (Lst) (when (pair Lst) (if (_prf? Lst) (prog1 (cadr (cadr Lst)) (set (cdadr Lst) (cons (+ 0) (+ 0))) ) (con Lst (list (cons 'tick (cons (+ 0) (+ 0)) (cdr Lst))) ) T ) ) ) (de "uprf" (Lst) (when (_prf? Lst) (con Lst (cddr (cadr Lst))) T ) ) (de prof ("X" "C") (when (pair "X") (setq "C" (cdr "X") "X" (car "X")) ) (and (not "C") (num? (getd "X")) (expr "X")) (unless (and (_prf (if "C" (method "X" "C") (getd "X"))) (push1 '*Profile (cons "X" "C")) ) (quit "Can't profile" "X") ) ) (de unprof ("X" "C") (del (cons "X" "C") '*Profile) ("uprf" (if "C" (method "X" "C") (getd "X"))) ) (de profile () (mapc println (flip (by '((X) (+ (car X) (cadr X))) sort (mapcar '(("X") (let P (_prf (if (cdr "X") (method (car "X") (cdr "X")) (getd (car "X")) ) ) (cons (car P) (cdr P) "X") ) ) *Profile ) ) ) ) ) picolisp-3.1.5.2.orig/lib/ps.l0000644000000000000000000001715612265263724014527 0ustar rootroot# 10feb11abu # (c) Software Lab. Alexander Burger # "*Glyph" "*PgX" "*PgY" # "*DX" "*DY" "*Pos" "*Fonts" "*Size" "*Font" "*Pag" "*Lim" "*FF" "*UL" (once (balance '"*Glyph" (sort (make (in "@lib/glyphlist.txt" (use (L C) (while (setq L (line)) (unless (or (= "#" (car L)) (member " " L)) (setq L (split L ";") C (char (hex (pack (cadr L)))) ) (set (link C) (pack (car L))) ) ) ) ) ) ) ) ) (de glyph (C) (val (car (idx '"*Glyph" C))) ) (de pdf (Nm . Prg) (let (Ps (tmp Nm ".ps") Pdf (tmp Nm ".pdf")) (out Ps (run Prg 1)) (_pdf) Pdf ) ) (de psOut (How Nm . Prg) (ifn Nm (out (list "lpr" (pack "-P" How)) (run Prg 1)) (let (Ps (tmp Nm ".ps") Pdf (tmp Nm ".pdf")) (out Ps (run Prg 1)) (cond ((not How) (_pdf) (url Pdf "PDF")) ((=0 How) (_pdf) (url Pdf)) ((=T How) (_pdf) (httpEcho Pdf "application/pdf" 1)) ((fun? How) (How Ps) (_pdf)) (T (call 'lpr (pack "-P" How) Ps) (_pdf)) ) Pdf ) ) ) (de _pdf () (if (= *OS "Darwin") (call 'pstopdf Ps) (call 'ps2pdf (pack "-dDEVICEWIDTHPOINTS=" "*PgX") (pack "-dDEVICEHEIGHTPOINTS=" "*PgY") Ps Pdf ) ) ) (de psHead (DX DY Ttl) (prinl "%!PS-Adobe-2.0") (and Ttl (prinl "%%Title: " @)) (prinl "%%Creator: PicoLisp") (prinl "%%BoundingBox: 0 0 " (setq "*DX" DX "*PgX" DX) " " (setq "*DY" DY "*PgY" DY) ) (in "@lib/head.ps" (echo)) (zero "*Pos") (off "*Fonts" "*Lim" "*UL") (setq "*Size" 12) ) (de a4 (Ttl) (psHead 595 842 Ttl) ) (de a4L (Ttl) (psHead 842 595 Ttl) ) (de a5 (Ttl) (psHead 420 595 Ttl) ) (de a5L (Ttl) (psHead 595 420 Ttl) ) (de _font () (prinl "/" "*Font" " findfont " "*Size" " scalefont setfont") ) (de font ("F" . "Prg") (use "N" (cond ((pair "F") (setq "N" (pop '"F")) ) ((num? "F") (setq "N" "F" "F" "*Font") ) (T (setq "N" "*Size")) ) (unless (member "F" "*Fonts") (push '"*Fonts" "F") (prinl "/" "F" " isoLatin1 def") ) (ifn "Prg" (setq "*Size" "N" "*Font" "F") (let ("*Size" "N" "*Font" "F") (_font) (psEval "Prg") ) ) ) (_font) ) (de bold "Prg" (let "*Font" (pack "*Font" "-Bold") (_font) (psEval "Prg") ) (_font) ) (de width ("N" . "Prg") (and "Prg" (prinl "currentlinewidth")) (prinl "N" " setlinewidth") (when "Prg" (psEval "Prg") (prinl "setlinewidth") ) ) (de gray ("N" . "Prg") (and "Prg" (prinl "currentgray")) (prinl (- 100 "N") " 100 div setgray") (when "Prg" (psEval "Prg") (prinl "setgray") ) ) (de color ("R" "G" "B" . "Prg") (and "Prg" (prinl "currentrgbcolor")) (prinl "R" " 100 div " "G" " 100 div " "B" " 100 div setrgbcolor") (when "Prg" (psEval "Prg") (prinl "setrgbcolor") ) ) (de poly (F X Y . @) (prin "newpath " X " " (- "*PgY" Y) " moveto ") (while (args) (if (pair (next)) (for P (arg) (prin (car P) " " (- "*PgY" (cdr P)) " lineto ") ) (prin (arg) " " (- "*PgY" (next)) " lineto ") ) ) (prinl (if F "fill" "stroke")) ) (de rect (X1 Y1 X2 Y2 F) (poly F X1 Y1 X2 Y1 X2 Y2 X1 Y2 X1 Y1) ) (de arc (X Y R F A B) (prinl "newpath " X " " (- "*PgY" Y) " " R " " (or A 0) " " (or B 360) " arc " (if F "fill" "stroke") ) ) (de ellipse (X Y DX DY F A B) (prinl "matrix currentmatrix") (prinl "newpath " X " " (- "*PgY" Y) " translate " DX " " DY " scale 0 0 1 " (or A 0) " " (or B 360) " arc" ) (prinl "setmatrix " (if F "fill" "stroke")) ) (de indent (X DX) (prinl X " 0 translate") (dec '"*DX" X) (and DX (dec '"*DX" DX)) ) (de window ("*X" "*Y" "*DX" "*DY" . "Prg") ("?ff") (prinl "gsave") (prinl "*X" " " (- "*Y") " translate") (let "*Pos" 0 (psEval "Prg") ) (prinl "grestore") ) (de ?ps ("X" "H" "V") (and "X" (ps "X" "H" "V")) ) (de ps ("X" "H" "V") (cond ((not "X") (inc '"*Pos" "*Size")) ((num? "X") (_ps (chop "X"))) ((pair "X") (_ps "X")) (T (mapc _ps (split (chop "X") "^J"))) ) ) (de ps+ ("X") (fmtPs (chop "X")) (?ul1) (prinl " glyphArrayShow") (?ul2) ) (de _ps ("L") ("?ff") (fmtPs "L") (ifn "H" (prin " 0") (prin " dup glyphArrayWidth " "*DX" " exch sub") (and (=0 "H") (prin " 2 div")) ) (prin " " (- "*PgY" (cond ((not "V") (inc '"*Pos" "*Size") ) ((=0 "V") (setq "*Pos" (+ (/ "*Size" 4) (/ "*DY" 2))) ) (T (setq "*Pos" "*DY")) ) ) ) (prin " moveto") (?ul1) (prinl " glyphArrayShow") (?ul2) ) (de escPs (C) (and (sub? C "\\()") (prin "\\")) (prin C) ) (de fmtPs (Lst) (prin "[") (while Lst (if (>= (car Lst) `(char 128)) (prin "/" (or (glyph (pop 'Lst)) ".notdef")) (prin "(") (escPs (pop 'Lst)) (while (and Lst (>= `(char 127) (car Lst))) (escPs (pop 'Lst)) ) (prin ")") ) (and Lst (space)) ) (prin "]") ) (de ?ul1 () (and "*UL" (prin " currentpoint " "*UL" " sub 3 -1 roll")) ) (de ?ul2 () (when "*UL" (prinl "currentpoint " "*UL" " sub") (prinl "gsave newpath 4 -2 roll moveto lineto stroke grestore") ) ) (de pos (N) (if N (+ N "*Pos") "*Pos") ) (de down (N) (inc '"*Pos" (or N "*Size")) ) (de table ("Lst" . "Prg") #> Y ("?ff") (let ("PosX" 0 "Max" "*Size") (mapc '(("N" "X") (window "PosX" "*Pos" "N" "Max" (if (atom "X") (ps (eval "X")) (eval "X")) (inc '"PosX" "N") (setq "Max" (max "*Pos" "Max")) ) ) "Lst" "Prg" ) (inc '"*Pos" "Max") ) ) (de underline ("*UL" . "Prg") (psEval "Prg") ) (de hline (Y X2 X1) (inc 'Y "*Pos") (poly NIL (or X2 "*DX") Y (or X1 0) Y) ) (de vline (X Y2 Y1) (poly NIL X (or Y2 "*DY") X (or Y1 0)) ) (de border (Y Y2) (rect 0 (or Y 0) "*DX" (or Y2 "*DY")) ) (de psEval ("Prg") (while "Prg" (if (atom (car "Prg")) (ps (eval (pop '"Prg"))) (eval (pop '"Prg")) ) ) ) (de page (Flg) (when (=T Flg) (prinl "gsave") ) (prinl "showpage") (zero "*Pos") (cond ((=T Flg) (prinl "grestore") ) ((=0 Flg) (setq "*DX" "*PgX" "*DY" "*PgY" "*Lim") ) (T (prin "%%DocumentFonts:") (while "*Fonts" (prin " " (pop '"*Fonts")) ) (prinl) (prinl "%%EOF") ) ) ) (de pages (Lst . Prg) (setq "*Pag" Lst "*Lim" (pop '"*Pag") "*FF" Prg) ) (de "?ff" () (when (and "*Lim" (>= "*Pos" "*Lim")) (off "*Lim") (run "*FF") (setq "*Lim" (pop '"*Pag")) ) ) (de noff "Prg" (let "*Lim" NIL (psEval "Prg") ) ) (de eps (Eps X Y DX DY) (prinl "save " (or X 0) " " (- "*PgY" (or Y 0)) " translate") (when DX (prinl DX " 100. div " (or DY DX) " 100. div scale") ) (in Eps (echo)) (prinl "restore") ) (====) (de brief ("F" "Fnt" "Abs" . "Prg") (when "F" (poly NIL 10 265 19 265) # Faltmarken (poly NIL 10 421 19 421) ) (poly NIL 50 106 50 103 53 103) # Fenstermarken (poly NIL 50 222 50 225 53 225) (poly NIL 288 103 291 103 291 106) (poly NIL 288 225 291 225 291 222) (poly NIL 50 114 291 114) # Absender (window 60 102 220 10 (font "Fnt" (ps "Abs" 0)) ) (window 65 125 210 90 (psEval "Prg") ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/readline.l0000644000000000000000000000066412265263724015664 0ustar rootroot# 05dec08abu # (c) Software Lab. Alexander Burger (load "@lib/gcc.l") (gcc "readline" '("-lreadline") '_led) #include #include any _led(any ex __attribute__((unused))) { char *p; any x; rl_already_prompted = YES; if ((p = readline(": ")) && *p) add_history(p); x = mkStr(p); free(p); return x; } /**/ # Enable line editing (de *Led (_led)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/rsa.l0000644000000000000000000000507512265263724014667 0ustar rootroot# 10nov04abu # (c) Software Lab. Alexander Burger # *InND # Generate long random number (de longRand (N) (use (R D) (while (=0 (setq R (abs (rand))))) (until (> R N) (unless (=0 (setq D (abs (rand)))) (setq R (* R D)) ) ) (% R N) ) ) # X power Y modulus N (de **Mod (X Y N) (let M 1 (loop (when (bit? 1 Y) (setq M (% (* M X) N)) ) (T (=0 (setq Y (>> 1 Y))) M ) (setq X (% (* X X) N)) ) ) ) # Probabilistic prime check (de prime? (N) (and (> N 1) (bit? 1 N) (let (Q (dec N) K 0) (until (bit? 1 Q) (setq Q (>> 1 Q) K (inc K) ) ) (do 50 (NIL (_prim? N Q K)) T ) ) ) ) # (Knuth Vol.2, p.379) (de _prim? (N Q K) (use (X J Y) (while (> 2 (setq X (longRand N)))) (setq J 0 Y (**Mod X Q N) ) (loop (T (or (and (=0 J) (= 1 Y)) (= Y (dec N)) ) T ) (T (or (and (> J 0) (= 1 Y)) (<= K (inc 'J)) ) NIL ) (setq Y (% (* Y Y) N)) ) ) ) # Find a prime number with `Len' digits (de prime (Len) (let P (longRand (** 10 (*/ Len 2 3))) (unless (bit? 1 P) (inc 'P) ) (until (prime? P) # P: Prime number of size 2/3 Len (inc 'P 2) ) # R: Random number of size 1/3 Len (let (R (longRand (** 10 (/ Len 3))) K (+ R (% (- P R) 3))) (when (bit? 1 K) (inc 'K 3) ) (until (prime? (setq R (inc (* K P)))) (inc 'K 6) ) R ) ) ) # Generate RSA key (de rsaKey (N) #> (Encrypt . Decrypt) (let (P (prime (*/ N 5 10)) Q (prime (*/ N 6 10))) (cons (* P Q) (/ (inc (* 2 (dec P) (dec Q))) 3 ) ) ) ) # Encrypt a list of characters (de encrypt (Key Lst) (let Siz (>> 1 (size Key)) (make (while Lst (let N (char (pop 'Lst)) (while (> Siz (size N)) (setq N (>> -16 N)) (inc 'N (char (pop 'Lst))) ) (link (**Mod N 3 Key)) ) ) ) ) ) # Decrypt a list of numbers (de decrypt (Keys Lst) (mapcan '((N) (let Res NIL (setq N (**Mod N (cdr Keys) (car Keys))) (until (=0 N) (push 'Res (char (& `(dec (** 2 16)) N))) (setq N (>> 16 N)) ) Res ) ) Lst ) ) # Init crypt (de rsa (N) (seed (in "/dev/urandom" (rd 20))) (setq *InND (rsaKey N)) ) picolisp-3.1.5.2.orig/lib/scrape.l0000644000000000000000000001341712265263724015356 0ustar rootroot# 31jul13abu # (c) Software Lab. Alexander Burger # *ScrHost *ScrPort *ScrGate *Title *Expect *Found # *Links *Forms *Buttons *Fields *Errors # Scrape HTML form(s) (de scrape (Host Port How) (client (setq *ScrHost Host) (setq *ScrPort Port) How (off *ScrGate *Links *Forms *Buttons *Fields *Errors) (while (from "303 See Other" "" "<base href=\"http://" "<a href=\"" " action=\"" "<input type=\"submit\" name=\"" "<input type=\"hidden\" name=\"" "<input type=\"text\" name=\"" "<input type=\"password\" name=\"" "<select name=\"" "<option selected=\"selected\">" "<textarea name=\"" "<span id=\"" "<div class=\"error\">" *Expect ) (casq @ ("303 See Other" (when (from "Location: http://") (let L (split (line) ':) (if (cdr L) (scrape (pack (pop 'L)) (ifn (format (car (setq L (split (car L) '/)))) 80 (pop 'L) @ ) (glue '/ L) ) (setq L (split (car L) '/)) (scrape (pack (pop 'L)) 80 (glue '/ L)) ) ) ) ) ("<title>" (setq *Title (ht:Pack (till "<"))) ) ("<base href=\"http://" (let L (split (till "\"") ':) (if (cdr L) (setq *ScrHost (pack (pop 'L)) *ScrPort (format (cdr (rot (car L)))) ) (setq *ScrGate (pack (cdr (member '/ (car L))))) ) ) ) ("<a href=\"" (let Url (pack *ScrGate (till "\"" T)) (from ">") (cond ((till "<") (queue '*Links (cons (ht:Pack @) Url)) ) ((= "<img" (till " " T)) (from "alt=\"") (queue '*Links (cons (ht:Pack (till "\"")) Url)) ) ) ) ) (" action=\"" (queue '*Forms # (action . fields) (list (pack *ScrGate (till "\"" T))) ) ) ("<input type=\"submit\" name=\"" (let Nm (till "\"" T) (from "value=\"") (queue '*Buttons # (label field . form) (cons (ht:Pack (till "\"")) (cons Nm T) (last *Forms) ) ) ) ) ("<input type=\"hidden\" name=\"" (conc (last *Forms) (cons (cons (till "\"" T) (prog (from "value=\"") (ht:Pack (till "\"")))) ) ) ) (("<input type=\"text\" name=\"" "<input type=\"password\" name=\"") (conc (last *Forms) (cons (queue '*Fields (cons (till "\"" T) (prog (from "value=\"") (ht:Pack (till "\"")))) ) ) ) ) ("<select name=\"" (conc (last *Forms) (cons (queue '*Fields (cons (till "\"" T))) ) ) ) ("<option selected=\"selected\">" (con (last *Fields) (ht:Pack (till "<"))) ) ("<textarea name=\"" (conc (last *Forms) (cons (queue '*Fields (cons (till "\"" T) (prog (from ">") (ht:Pack (till "<"))) ) ) ) ) ) ("<span id=\"" (from ">") (queue '*Fields (ht:Pack (till "<"))) ) ("<div class=\"error\">" (queue '*Errors (ht:Pack (till "<"))) ) (T (on *Found)) ) ) (or *Errors *Title) ) ) # Expect content (de expect (*Expect . "Prg") (let *Found NIL (run "Prg") (unless *Found (quit "Content not found" *Expect) ) ) ) # Click on a link (de click (Lbl Cnt) (let L (cdr (target *Links Lbl Cnt)) (when (pre? "http://" L) (setq L (split (nth (chop L) 8) '/ ':) *ScrHost (pack (pop 'L)) *ScrPort (ifn (format (car L)) 80 (pop 'L) @) L (glue '/ L) ) ) (scrape *ScrHost *ScrPort L) ) ) # Press a button (de press (Lbl Cnt) (let B (target *Buttons Lbl Cnt) (scrape *ScrHost *ScrPort (cons (caddr B) (glue "&" (mapcar '((X) (list (car X) '= (ht:Fmt (cdr X))) ) (cons (cadr B) (cdddr B)) ) ) ) ) ) ) # Retrieve a field's value (de value (Fld Cnt) (fin (field Fld Cnt)) ) # Set a field's value (de enter (Fld Str Cnt) (con (field Fld Cnt) Str) ) # Inspect current page (de display () (prinl "###############") (apply println (mapcar car *Links) 'click) (prinl) (apply println (mapcar car *Buttons) 'press) (prinl) (apply println (trim (mapcar fin *Fields)) 'value) (prinl) *Title ) ### Utility functions ### (de target (Lst Lbl Cnt) (cond ((num? Lbl) (get Lst Lbl) ) ((pair Lbl) Lbl) (T (default Cnt 1) (or (find '((L) (and (pre? Lbl (car L)) (=0 (dec 'Cnt)) ) ) Lst ) (quit "Target not found" Lbl) ) ) ) ) (de field (Fld Cnt) (or (cond ((gt0 Fld) (get *Fields Fld) ) ((lt0 Fld) (get *Fields (+ (length *Fields) Fld 1)) ) (T (assoc Fld (cdr (get *Forms (or Cnt 1))))) ) (quit "Field not found" Fld) ) ) # vi:et:ts=3:sw=3 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/simul.l�������������������������������������������������������������������0000644�0000000�0000000�00000011722�12265263724�015227� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 11dec13abu # (c) Software Lab. Alexander Burger (de permute (Lst) (ifn (cdr Lst) (cons Lst) (mapcan '((X) (mapcar '((Y) (cons X Y)) (permute (delete X Lst)) ) ) Lst ) ) ) (de subsets (N Lst) (cond ((=0 N) '(NIL)) ((not Lst)) (T (conc (mapcar '((X) (cons (car Lst) X)) (subsets (dec N) (cdr Lst)) ) (subsets N (cdr Lst)) ) ) ) ) (de shuffle (Lst) (by '(NIL (rand)) sort Lst) ) (de samples (Cnt Lst) (make (until (=0 Cnt) (when (>= Cnt (rand 1 (length Lst))) (link (car Lst)) (dec 'Cnt) ) (pop 'Lst) ) ) ) # Genetic Algorithm (de gen ("Pop" "Cond" "Re" "Mu" "Se") (until ("Cond" "Pop") (for ("P" "Pop" "P" (cdr "P")) (set "P" (maxi "Se" # Selection (make (for ("P" "Pop" "P") (rot "P" (rand 1 (length "P"))) (link # Recombination + Mutation ("Mu" ("Re" (pop '"P") (pop '"P"))) ) ) ) ) ) ) ) (maxi "Se" "Pop") ) # Alpha-Beta tree search (de game ("Flg" "Cnt" "Moves" "Move" "Cost") (let ("Alpha" '(1000000) "Beta" -1000000) (recur ("Flg" "Cnt" "Alpha" "Beta") (let? "Lst" ("Moves" "Flg") (if (=0 (dec '"Cnt")) (loop ("Move" (caar "Lst")) (setq "*Val" (list ("Cost" "Flg") (car "Lst"))) ("Move" (cdar "Lst")) (T (>= "Beta" (car "*Val")) (cons "Beta" (car "Lst") (cdr "Alpha")) ) (when (> (car "Alpha") (car "*Val")) (setq "Alpha" "*Val") ) (NIL (setq "Lst" (cdr "Lst")) "Alpha") ) (setq "Lst" (sort (mapcar '(("Mov") (prog2 ("Move" (car "Mov")) (cons ("Cost" "Flg") "Mov") ("Move" (cdr "Mov")) ) ) "Lst" ) ) ) (loop ("Move" (cadar "Lst")) (setq "*Val" (if (recurse (not "Flg") "Cnt" (cons (- "Beta")) (- (car "Alpha"))) (cons (- (car @)) (cdar "Lst") (cdr @)) (list (caar "Lst") (cdar "Lst")) ) ) ("Move" (cddar "Lst")) (T (>= "Beta" (car "*Val")) (cons "Beta" (cdar "Lst") (cdr "Alpha")) ) (when (> (car "Alpha") (car "*Val")) (setq "Alpha" "*Val") ) (NIL (setq "Lst" (cdr "Lst")) "Alpha") ) ) ) ) ) ) ### Grids ### (de grid (DX DY FX FY) (let Grid (make (for X DX (link (make (for Y DY (set (link (if (> DX 26) (box) (intern (pack (char (+ X 96)) Y)) ) ) (cons (cons) (cons)) ) ) ) ) ) ) (let West (and FX (last Grid)) (for (Lst Grid Lst) (let (Col (pop 'Lst) East (or (car Lst) (and FX (car Grid))) South (and FY (last Col)) ) (for (L Col L) (with (pop 'L) (set (: 0 1) (pop 'West)) # west (con (: 0 1) (pop 'East)) # east (set (: 0 -1) South) # south (con (: 0 -1) # north (or (car L) (and FY (car Col))) ) (setq South This) ) ) (setq West Col) ) ) ) Grid ) ) (de west (This) (: 0 1 1) ) (de east (This) (: 0 1 -1) ) (de south (This) (: 0 -1 1) ) (de north (This) (: 0 -1 -1) ) (de disp ("Grid" "How" "Fun" "X" "Y" "DX" "DY") (setq "Grid" (if "X" (mapcar '((L) (flip (head "DY" (nth L "Y")))) (head "DX" (nth "Grid" "X")) ) (mapcar reverse "Grid") ) ) (let (N (+ (length (cdar "Grid")) (or "Y" 1)) Sp (length N)) ("border" north) (while (caar "Grid") (prin " " (align Sp N) " " (and "How" (if (and (nT "How") (west (caar "Grid"))) " " '|)) ) (for L "Grid" (prin ("Fun" (car L)) (and "How" (if (and (nT "How") (east (car L))) " " '|)) ) ) (prinl) ("border" south) (map pop "Grid") (dec 'N) ) (unless (> (default "X" 1) 26) (space (inc Sp)) (for @ "Grid" (prin " " (and "How" " ") (char (+ 96 "X"))) (T (> (inc '"X") 26)) ) (prinl) ) ) ) (de "border" (Dir) (when "How" (space Sp) (prin " +") (for L "Grid" (prin (if (and (nT "How") (Dir (car L))) " +" "---+")) ) (prinl) ) ) ����������������������������������������������picolisp-3.1.5.2.orig/lib/sq.l����������������������������������������������������������������������0000644�0000000�0000000�00000007642�12265263724�014527� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 29sep13abu # (c) Software Lab. Alexander Burger # (select [var ..] cls [hook|T] [var val ..]) (de select Lst (let (Vars (make (until (or (atom Lst) (and (sym? (car Lst)) (= `(char "+") (char (car Lst))) ) ) (link (pop 'Lst)) ) ) Cls (pop 'Lst) Hook (cond ((ext? (car Lst)) (pop 'Lst)) ((=T (car Lst)) (pop 'Lst) *DB) ) ) (default Lst (cons (or (car Vars) (and (find '((X) (isa '(+Need +index) (car X))) (getl Cls) ) (get (car @) 'var) ) (cdr (maxi caar (getl (get (or Hook *DB) Cls)) ) ) ) ) ) (let Q (goal (cons (make (link 'select '(@@) (make (for (L Lst L) (link (make (link (pop 'L) Cls) (and Hook (link Hook)) (link (if L (pop 'L) '(NIL . T))) ) ) ) ) ) (link (list 'isa Cls '@@)) (while Lst (let (Var (pop 'Lst) Val (if Lst (pop 'Lst) '(NIL . T))) (link (list (cond ((pair Val) 'range) ((or (num? Val) (ext? Val)) 'same) ((=T Val) 'bool) ((isa '+Sn (get Cls Var)) 'tolr) ((isa '(+IdxFold) (get Cls Var)) 'part) ((isa '(+Fold +Idx) (get Cls Var)) 'part) ((isa '+Fold (get Cls Var)) 'fold) ((isa '+Idx (get Cls Var)) 'hold) (T 'head) ) Val '@@ Var ) ) ) ) ) ) ) (use Obj (loop (NIL (setq Obj (cdr (asoq '@@ (prove Q))))) (ifn Vars (show Obj) (for Var Vars (cond ((pair Var) (print (apply get Var Obj)) ) ((meta Obj Var) (print> @ (get Obj Var)) ) (T (print (get Obj Var))) ) (space) ) (print Obj) ) (T (line) Obj) ) ) ) ) ) (dm (print> . +relation) (Val) (print Val) ) (dm (print> . +Number) (Val) (prin (format Val (: scl))) ) (dm (print> . +Date) (Val) (print (datStr Val)) ) # (update 'obj ['var]) (de update (Obj Var) (let *Dbg NIL (printsp Obj) (if Var (_update (get Obj Var) Var) (set!> Obj (any (revise (sym (val Obj)))) ) (for X (getl Obj) (_update (or (atom X) (pop 'X)) X) ) ) Obj ) ) (de _update (Val Var) (printsp Var) (let New (if (meta Obj Var) (revise> @ Val) (any (revise (sym Val))) ) (unless (= New Val) (if (mis> Obj Var New) (quit "mismatch" @) (put!> Obj Var New) ) ) ) ) (dm (revise> . +relation) (Val) (any (revise (sym Val))) ) (dm (revise> . +Bag) (Lst) (mapcar '((V B) (space 6) (revise> B V)) (any (revise (sym Lst))) (: bag) ) ) (dm (revise> . +Number) (Val) (format (revise (format Val (: scl))) (: scl) ) ) (dm (revise> . +Date) (Val) (expDat (revise (datStr Val) '((S) (list (datStr (expDat S)))) ) ) ) (dm (revise> . +List) (Val) (mapcar '((X) (space 3) (extra X)) (any (revise (sym Val))) ) ) ����������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/term.l��������������������������������������������������������������������0000644�0000000�0000000�00000002433�12265263724�015044� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 16mar10abu # (c) Software Lab. Alexander Burger ### Key codes ### (setq *XtF1 (in '("tput" "kf1") (line T)) *XtF2 (in '("tput" "kf2") (line T)) *XtF3 (in '("tput" "kf3") (line T)) *XtF4 (in '("tput" "kf4") (line T)) *XtF5 (in '("tput" "kf5") (line T)) *XtF6 (in '("tput" "kf6") (line T)) *XtF7 (in '("tput" "kf7") (line T)) *XtF8 (in '("tput" "kf8") (line T)) *XtF9 (in '("tput" "kf9") (line T)) *XtF10 (in '("tput" "kf10") (line T)) *XtF11 (in '("tput" "kf11") (line T)) *XtF12 (in '("tput" "kf12") (line T)) *XtMenu "^[[29~" #? *XtIns (in '("tput" "kich1") (line T)) *XtDel (in '("tput" "kdch1") (line T)) *XtPgUp (in '("tput" "kpp") (line T)) *XtPgDn (in '("tput" "knp") (line T)) *XtUp (in '("tput" "cuu1") (line T)) *XtDown "^[[B" #? *XtRight (in '("tput" "cuf1") (line T)) *XtLeft "^[[D" #? *XtEnd "^[[F" #? *XtHome (in '("tput" "home") (line T)) ) ### Cursor movements ### (de xtUp (N) (do N (prin *XtUp)) ) (de xtDown (N) (do N (prin *XtDown)) ) (de xtRight (N) (do N (prin *XtRight)) ) (de xtLeft (N) (do N (prin *XtLeft)) ) # vi:et:ts=3:sw=3 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/test.l��������������������������������������������������������������������0000644�0000000�0000000�00000001150�12265263724�015047� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 11jul11abu # (c) Software Lab. Alexander Burger ### Unit Tests ### # Local usage: # ./pil lib/test.l $(/bin/pwd) -bye + # Global usage: # pil @lib/test.l $(/bin/pwd) -bye + (setq *CMD (cmd) *PWD (opt) ) (test T (pool (tmp "db"))) (load "@test/src/main.l" "@test/src/apply.l" "@test/src/flow.l" "@test/src/sym.l" "@test/src/subr.l" "@test/src/big.l" "@test/src/io.l" "@test/src/db.l" "@test/src/net.l" "@test/src/ext.l" "@test/src/ht.l" ) (load "@test/lib.l") (load "@test/lib/misc.l") (load "@test/lib/lint.l") (load "@test/lib/math.l") (msg 'OK) # vi:et:ts=3:sw=3 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/tex.l���������������������������������������������������������������������0000644�0000000�0000000�00000006575�12265263724�014710� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 29jul11abu # (c) Software Lab. Alexander Burger # Convert to PDF document (de dviPdf (Doc) (prog1 (tmp Doc ".pdf") (call "/usr/bin/dvips" "-q" (pack Doc ".dvi")) (call "ps2pdf" (pack Doc ".ps") @) (call 'rm "-f" (pack Doc ".tex") (pack Doc ".dvi") (pack Doc ".ps") ) ) ) # Tex Formatting (de tex (S . @) (prin "\\" (or S (next))) (when (args) (prin "{") (texPrin (next)) (while (args) (when (next) (prin "\\\\") (texPrin (arg)) ) ) (prin "}") ) (and S (prinl)) ) (de texl (S . @) (prin "\\" (or S (next)) "{") (loop (let Lst (next) (texPrin (pop 'Lst)) (while Lst (when (pop 'Lst) (prin "\\\\") (texPrin @) ) ) ) (NIL (args)) (prin (next)) ) (prin "}") (and S (prinl)) ) (de texPrin (X) (let Q NIL (for C (chop X) (cond ((sub? C "#$%&_{}") (prin "\\" C) ) ((sub? C "<²>") (prin "$" C "$") ) (T (prin (case C (`(char 8364) "\\EUR") ("\"" (if (onOff Q) "``" "''")) ("\\" "$\\backslash$") ("\^" "\\char94") ("~" "\\char126") (T C) ) ) ) ) ) ) ) ### TeX Document ### (de document (Doc Cls Typ Use . Prg) (out (list "@bin/lat1" (pack Doc ".tex")) (prinl "\\documentclass[" Cls "]{" Typ "}") (while Use (if (atom (car Use)) (prinl "\\usepackage{" (pop 'Use) "}") (prinl "\\usepackage[" (caar Use) "]{" (cdr (pop 'Use)) "}") ) ) (prinl "\\begin{document}") (prEval Prg 2) (prinl "\\end{document}") ) (call 'sh "-c" (pack "latex -interaction=batchmode " Doc ".tex >/dev/null") ) (call 'rm (pack Doc ".aux") (pack Doc ".log")) ) (de \\block (S . Prg) (prinl "\\begin{" S "}") (prEval Prg 2) (prinl "\\end{" S "}") ) (de \\figure (S . Prg) (prinl "\\begin{figure}" S) (prEval Prg 2) (prinl "\\end{figure}") ) ### Tabular environment ### (de \\table (Fmt . Prg) (prinl "\\begin{tabular}[c]{" Fmt "}") (prEval Prg 2) (prinl "\\end{tabular}") ) (de \\carry () (prinl "\\end{tabular}") (prinl) (prinl "\\begin{tabular}[c]{" "Fmt" "}") ) (de \\head @ (prin "\\textbf{" (next) "}") (while (args) (prin " & \\textbf{") (texPrin (next)) (prin "}") ) (prinl "\\\\") ) (de \\row @ (when (=0 (next)) (next) (prin "\\raggedleft ") ) (ifn (=T (arg)) (texPrin (arg)) (prin "\\textbf{") (texPrin (next)) (prin "}") ) (while (args) (prin " & ") (when (=0 (next)) (next) (prin "\\raggedleft ") ) (ifn (=T (arg)) (texPrin (arg)) (prin "\\textbf{") (texPrin (next)) (prin "}") ) ) (prinl "\\\\") ) (de \\hline () (prinl "\\hline") ) (de \\cline (C1 C2) (prinl "\\cline{" C1 "-" C2 "}") ) ### Letter Document Class ### (de \\letter (Lst . Prg) (prin "\\begin{letter}{" (pop 'Lst)) (while Lst (when (pop 'Lst) (prin "\\\\" @) ) ) (prinl "}") (prEval Prg 2) (prinl "\\end{letter}") ) (de \\signature (S) (tex "signature" S) ) (de \\opening (S) (tex "opening" S) ) (de \\closing (S) (tex "closing" S) ) �����������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/too.l���������������������������������������������������������������������0000644�0000000�0000000�00000043547�12265263724�014711� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 14dec13abu # (c) Software Lab. Alexander Burger ### Local Backup ### (de snapshot (Dst . @) (for (L (flip (sort (mapcar format (dir Dst)))) L) (let N (pop 'L) (call 'mv (pack Dst '/ N) (pack Dst '/ (inc N))) (when (> (car L) (*/ N 9 10)) (call 'rm "-rf" (pack Dst '/ (pop 'L))) ) ) ) (when (call 'mkdir (pack Dst "/1")) (while (args) (let (Lst (filter bool (split (chop (next)) '/)) Src (car Lst) Old (pack Dst "/2/" Src) New (pack Dst "/1/" Src) ) (recur (Lst Src Old New) (ifn (cdr Lst) (recur (Src Old New) (cond ((=T (car (info Src T))) # Directory (call 'mkdir "-p" New) (for F (dir Src T) (unless (member F '("." "..")) (recurse (pack Src '/ F) (pack Old '/ F) (pack New '/ F) ) ) ) (call 'touch "-r" Src New) ) ((= (info Src T) (info Old T)) # Same `(if (== 64 64) '(native "@" "link" 'I Old New) '(call 'ln Old New) ) ) (T (call 'cp "-a" Src New)) ) ) # Changed or new (call 'mkdir "-p" New) (recurse (cdr Lst) (pack Src '/ (cadr Lst)) (pack Old '/ (cadr Lst)) (pack New '/ (cadr Lst)) ) (call 'touch "-r" Src New) ) ) ) ) ) ) ### DB Garbage Collection ### (de dbgc () (markExt *DB) (let Cnt 0 (finally (mark 0) (for (F . @) (or *Dbs (2)) (for (S (seq F) S (seq S)) (unless (mark S) (inc 'Cnt) (and (isa '+Entity S) (zap> S)) (zap S) ) ) ) ) (commit) (when *Blob (use (@S @R F S) (let Pat (conc (chop *Blob) '(@S "." @R)) (in (list 'find *Blob "-type" "f") (while (setq F (line)) (when (match Pat F) (unless (and (setq S (extern (pack (replace @S '/)))) (get S (intern (pack @R))) ) (inc 'Cnt) (call 'rm (pack F)) ) (wipe S) ) ) ) ) ) ) (gt0 Cnt) ) ) (de markExt (S) (unless (mark S T) (markData (val S)) (maps markData S) (wipe S) ) ) (de markData (X) (while (pair X) (markData (pop 'X)) ) (and (ext? X) (markExt X)) ) ### DB Mapping ### (de dbMap ("ObjFun" "TreeFun") (default "ObjFun" quote "TreeFun" quote) (finally (mark 0) (_dbMap *DB) (dbMapT *DB) ) ) (de _dbMap ("Hook") (unless (mark "Hook" T) ("ObjFun" "Hook") (for "X" (getl "Hook") (when (pair "X") (if (and (ext? (car "X")) (not (isa '+Entity (car "X"))) (sym? (cdr "X")) (find '(("X") (isa '+relation (car "X"))) (getl (cdr "X")) ) ) (let ("Base" (car "X") "Cls" (cdr "X")) (dbMapT "Base") (for "X" (getl "Base") (when (and (pair "X") (sym? (cdr "X")) (pair (car "X")) (num? (caar "X")) (ext? (cdar "X")) ) ("TreeFun" "Base" (car "X") (cdr "X") "Cls" "Hook") (iter (tree (cdr "X") "Cls" "Hook") _dbMap) ) ) (wipe "Base") ) (dbMapV (car "X")) ) ) ) (wipe "Hook") ) ) (de dbMapT ("Base") (let "X" (val "Base") (when (and (pair "X") (num? (car "X")) (ext? (cdr "X")) ) ("TreeFun" "Base" "X") (iter "Base" dbMapV) ) ) ) (de dbMapV ("X") (while (pair "X") (dbMapV (pop '"X")) ) (and (ext? "X") (_dbMap "X")) ) ### DB Check ### (de dbCheck () (and (lock) (quit 'lock @)) # Lock whole database (for (F . N) (or *Dbs (2)) # Low-level integrity check (unless (pair (println F N (dbck F T))) (quit 'dbck @) ) ) (dbMap # Check tree structures NIL '((Base Root Var Cls Hook) (println Base Root Var Cls Hook) (unless (= (car Root) (chkTree (cdr Root))) (quit "Tree size mismatch") ) (when Var (scan (tree Var Cls Hook) '((K V) (or (isa Cls V) (isa '+Alt (meta V Var)) (quit "Bad Type" V) ) (unless (has> V Var (if (pair K) (car K) K)) (quit "Bad Value" K) ) ) NIL T T ) ) ) ) (and *Dbs (dbfCheck)) # Check DB file assignments (and (dangling) (println 'dangling @)) # Show dangling index references T ) (de dangling () (make (dbMap '((This) (and (not (: T)) (dangle This) (link @) ) ) ) ) ) # Check Index References (de dangle (Obj) (and (make (for X (getl Obj) (let V (or (atom X) (pop 'X)) (with (meta Obj X) (cond ((isa '+Joint This) (if (isa '+List This) (when (find '((Y) (if (atom (setq Y (get Y (: slot)))) (n== Obj Y) (not (memq Obj Y)) ) ) V ) (link X) ) (let Y (get V (: slot)) (if (atom Y) (unless (== Obj Y) (link X)) (unless (memq Obj Y) (link X)) ) ) ) ) ((isa '+Key This) (and (<> Obj (fetch (tree X (: cls) (get Obj (: hook))) V ) ) (link X) ) ) ((isa '+Ref This) (let (Tree (tree X (: cls) (get Obj (: hook))) Aux (conc (mapcar '((S) (get Obj S)) (: aux)) Obj) ) (cond ((isa '+UB This) (unless (= Obj (fetch Tree (ubZval (cons V Aux) Obj))) (link X) ) ) ((isa '+List This) (when (find '((Y) (and (or (not (isa '+Fold This)) (setq Y (fold Y)) ) (<> Obj (fetch Tree (cons Y Aux))) ) ) V ) (link X) ) ) (T (and (or (not (isa '+Fold This)) (setq V (fold V)) ) (<> Obj (fetch Tree (cons V Aux))) (link X) ) ) ) ) ) (T (for (N . B) (: bag) (cond ((isa '+Key B) (with B (when (find '((L) (let? Val (get L N) (<> Obj (fetch (tree (: var) (: cls) (get (if (sym? (: hook)) Obj L) (: hook) ) ) Val ) ) ) ) V ) (link X) ) ) ) ((isa '+Ref B) (with B (when (find '((L) (let? Val (get L N) (when (isa '+Fold This) (setq Val (fold Val)) ) (<> Obj (fetch (tree (: var) (: cls) (get (if (sym? (: hook)) Obj L) (: hook) ) ) (cons Val Obj) ) ) ) ) V ) (link X) ) ) ) ) ) ) ) ) ) ) ) (cons Obj @) ) ) ### Rebuild tree ### (de rebuild (X Var Cls Hook) (let Lst NIL (let? Base (get (or Hook *DB) Cls) (unless X (setq Lst (if (; (treeRel Var Cls) hook) (collect Var Cls Hook) (collect Var Cls) ) ) ) (zapTree (get Base Var -1)) (put Base Var NIL) (commit) ) (nond (X (let Len (length Lst) (recur (Lst Len) (unless (=0 Len) (let (N (>> 1 (inc Len)) L (nth Lst N)) (re-index (car L) Var Hook) (recurse Lst (dec N)) (recurse (cdr L) (- Len N)) ) ) ) ) ) ((atom X) (for Obj X (re-index Obj Var Hook) ) ) (NIL (for (Obj X Obj (seq Obj)) (and (isa Cls Obj) (re-index Obj Var Hook)) ) ) ) (commit) ) ) (de re-index (Obj Var Hook) (unless (get Obj T) (when (get Obj Var) (rel> (meta Obj Var) Obj NIL (put> (meta Obj Var) Obj NIL @) Hook ) (at (0 . 10000) (commit)) ) ) ) ### Database file management ### (de dbfCheck () (for "Cls" (all) (when (and (= `(char "+") (char "Cls")) (isa '+Entity "Cls")) (or (get "Cls" 'Dbf) (meta "Cls" 'Dbf) (println 'dbfCheck "Cls") ) (for Rel (getl "Cls") (and (pair Rel) (or (isa '+index (car Rel)) (find '((B) (isa '+index B)) (; Rel 1 bag)) ) (unless (; Rel 1 dbf) (println 'dbfCheck (cdr Rel) "Cls") ) ) ) ) ) ) (de dbfMigrate (Pool Dbs) (let (scan '(("Tree" "Fun") (let "Node" (cdr (root "Tree")) (if (ext? (fin (val "Node"))) (recur ("Node") (let? "X" (val "Node") (recurse (cadr "X")) ("Fun" (car "X") (cdddr "X")) (recurse (caddr "X")) (wipe "Node") ) ) (recur ("Node") (let? "X" (val "Node") (recurse (car "X")) (for "Y" (cdr "X") ("Fun" (car "Y") (or (cddr "Y") (fin (car "Y")))) (recurse (cadr "Y")) ) (wipe "Node") ) ) ) ) ) iter '(("Tree" "Bar") (scan "Tree" '(("K" "V") ("Bar" "V"))) ) zapTree '((Node) (let? X (val Node) (zapTree (cadr X)) (zapTree (caddr X)) (zap Node) ) ) ) (dbfUpdate) ) (let Lst (make (for (S *DB S (seq S)) (link (cons S (val S) (getl S))) ) ) (pool) (call 'rm (pack Pool 1)) (pool Pool Dbs) (set *DB (cadar Lst)) (putl *DB (cddr (pop 'Lst))) (for L Lst (let New (new T) (set New (cadr L)) (putl New (cddr L)) (con L New) ) ) (set *DB (dbfReloc0 (val *DB) Lst)) (for X Lst (set (cdr X) (dbfReloc0 (val (cdr X)) Lst)) (putl (cdr X) (dbfReloc0 (getl (cdr X)) Lst)) ) (commit) (dbMap # Relocate base symbols '((Obj) (putl Obj (dbfReloc0 (getl Obj) Lst)) (commit) ) '((Base Root Var Cls Hook) (when (asoq (cdr Root) Lst) (con Root (cdr @)) (touch Base) (commit) ) ) ) ) ) (de dbfUpdate () (dbMap # Move '((Obj) (let N (or (meta Obj 'Dbf 1) 1) (unless (= N (car (id Obj T))) (let New (new N) (set New (val Obj)) (putl New (getl Obj)) (set Obj (cons T New)) ) (commit) ) ) ) ) (when *Blob (for X (make (use (@S @R F S) (let Pat (conc (chop *Blob) '(@S "." @R)) (in (list 'find *Blob "-type" "f") (while (setq F (line)) (and (match Pat F) (setq S (extern (pack (replace @S '/)))) (=T (car (pair (val S)))) (link (cons (pack F) (blob (cdr (val S)) @R)) ) ) ) ) ) ) ) (and (dirname (cdr X)) (call 'mkdir "-p" @)) (call 'mv (car X) (cdr X)) ) ) (dbMap # Relocate '((Obj) (when (=T (car (pair (val Obj)))) (setq Obj (cdr (val Obj))) ) (when (isa '+Entity Obj) (putl Obj (dbfReloc (getl Obj))) (commit) ) ) '((Base Root Var Cls Hook) (if Var (dbfRelocTree Base Root (tree Var Cls Hook) (get Cls Var 'dbf)) (dbfRelocTree Base Root Base) ) ) ) (dbgc) ) (de dbfReloc (X) (cond ((pair X) (cons (dbfReloc (car X)) (dbfReloc (cdr X))) ) ((and (ext? X) (=T (car (pair (val X))))) (cdr (val X)) ) (T X) ) ) (de dbfReloc0 (X Lst) (cond ((pair X) (cons (dbfReloc0 (car X) Lst) (dbfReloc0 (cdr X) Lst)) ) ((asoq X Lst) (cdr @)) (T X) ) ) (de dbfRelocTree (Base Root Tree Dbf) (let? Lst (make (scan Tree '((K V) (link (cons K V))))) (zapTree (cdr Root)) (touch Base) (set Root 0) (con Root) (commit) (for X (make (for (Lst (cons Lst) Lst (mapcan '((L) (let (N (/ (inc (length L)) 2) X (nth L N)) (link (car X)) (make (and (>= N 2) (link (head (dec N) L))) (and (cdr X) (link @)) ) ) ) Lst ) ) ) ) (store Tree (dbfReloc (car X)) (dbfReloc (cdr X)) Dbf ) ) (commit) ) ) ### Dump Objects ### (de dump CL (let B 0 (for ("Q" (goal CL) (asoq '@@ (prove "Q"))) (let (Obj (cdr @) Lst) (prin "(obj ") (_dmp Obj) (maps '((X) (unless (or (member X Lst) (= `(char "+") (char (fin X)))) (prinl) (space 3) (cond ((pair X) (printsp (cdr X)) (_dmp (car X) T) ) ((isa '+Blob (meta Obj X)) (prin X " `(tmp " (inc 'B) ")") (out (tmp B) (in (blob Obj X) (echo)) ) ) (T (print X T)) ) ) ) Obj ) (prinl " )") Obj ) ) ) ) (de _dmp (Obj Flg) (cond ((pair Obj) (prin "(") (_dmp (pop 'Obj) T) (while (pair Obj) (space) (_dmp (pop 'Obj) T) ) (when Obj (prin " . ") (_dmp Obj T) ) (prin ")") ) ((ext? Obj) (when Flg (prin "`(obj ") ) (prin "(") (catch NIL (maps '((X) (with (and (pair X) (meta Obj (cdr X))) (when (isa '+Key This) (or Flg (push 'Lst X)) (printsp (type Obj) (: var)) (_dmp (car X) T) (throw) ) ) ) Obj ) (print (type Obj)) (maps '((X) (with (and (pair X) (meta Obj (cdr X))) (when (isa '+Ref This) (space) (or Flg (push 'Lst X)) (print (: var)) (space) (_dmp (car X) T) ) ) ) Obj ) ) (when Flg (prin ")") ) (prin ")") ) (T (print Obj)) ) ) ### Debug ### `*Dbg (noLint 'dbfMigrate 'iter) # vi:et:ts=3:sw=3 ���������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/tsm.l���������������������������������������������������������������������0000644�0000000�0000000�00000000311�12265263724�014671� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 18jan11abu # (c) Software Lab. Alexander Burger (when (sys "TERM") (setq *Tsm (cons (in '("tput" "smul") (line T)) (in '("tput" "rmul") (line T)) ) ) ) # vi:et:ts=3:sw=3 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/xhtml.l�������������������������������������������������������������������0000644�0000000�0000000�00000052670�12265263724�015241� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 02jan14abu # (c) Software Lab. Alexander Burger # *JS "*JS" *Style *Menu *Tab *ID (mapc allow '(*JS *Menu *Tab *ID)) (setq *Menu 0 *Tab 1) (off "*JS") (de htPrin (Prg Ofs) (default Ofs 1) (for X Prg (if (atom X) (ht:Prin (eval X Ofs)) (eval X Ofs) ) ) ) (de htJs () (for X "*JS" (prin " " (car X) "=\"") (ht:Prin (cdr X)) (prin "\"") ) ) (de htStyle (Attr) (cond ((atom Attr) (prin " class=\"") (ht:Prin Attr) (prin "\"") ) ((and (atom (car Attr)) (atom (cdr Attr))) (prin " " (car Attr) "=\"") (ht:Prin (cdr Attr)) (prin "\"") ) (T (mapc htStyle Attr)) ) ) (de dfltCss (Cls) (htStyle (cond ((not *Style) Cls) ((atom *Style) (pack *Style " " Cls)) ((and (atom (car *Style)) (atom (cdr *Style))) (list Cls *Style) ) ((find atom *Style) (replace *Style @ (pack @ " " Cls)) ) (T (cons Cls *Style)) ) ) ) (de tag (Nm Attr Ofs Prg) (prin "<" Nm) (and Attr (htStyle @)) (prin ">") (if (atom Prg) (ht:Prin (eval Prg Ofs)) (for X Prg (if (atom X) (ht:Prin (eval X Ofs)) (eval X Ofs) ) ) ) (prin "</" Nm ">") ) (de <tag> (Nm Attr . Prg) (tag Nm Attr 2 Prg) ) (de <js> ("JS" . "Prg") (let "*JS" (append "*JS" "JS") (run "Prg") ) ) (de style (X Prg) (let *Style (nond (X *Style) (*Style X) ((pair X) (cond ((atom *Style) (pack *Style " " X)) ((and (atom (car *Style)) (atom (cdr *Style))) (list X *Style) ) ((find atom *Style) (replace *Style @ (pack @ " " X)) ) (T (cons X *Style)) ) ) ((or (pair (car X)) (pair (cdr X))) (cond ((atom *Style) (list *Style X)) ((and (atom (car *Style)) (atom (cdr *Style))) (if (= (car X) (car *Style)) X (list *Style X) ) ) (T (cons X (delete (assoc (car X) *Style) *Style)) ) ) ) (NIL X) ) (run Prg 2 '(*Style)) ) ) (de <style> ("X" . "Prg") (style "X" "Prg") ) (de nonblank (Str) (or Str `(pack (char 160) (char 160))) ) ### XHTML output ### (de html (Upd Ttl Css Attr . Prg) (httpHead NIL Upd) (ht:Out *Chunked (prinl "<!DOCTYPE html>") (prinl "<html lang=\"" (or *Lang "en") "\">") (prinl "<head>") (prinl "<meta name=\"viewport\" content=\"width=device-width\"/>") (and (fin Ttl) (<tag> 'title NIL @) (prinl)) (mapc prinl Ttl) (and *Host *Port (prinl "<base href=\"" (baseHRef) "\"/>")) (when Css (if (atom Css) ("css" Css) (mapc "css" Css) (when (fin Css) (prinl "<style type=\"text/css\">") (prinl @) (prinl "</style>") ) ) ) (and *SesId (javascript NIL "SesId=\"" @ "\"")) (mapc javascript *JS) (prinl "</head>") (tag 'body Attr 2 Prg) (prinl "</html>") ) ) (de "css" (Css) (prinl "<link rel=\"stylesheet\" type=\"text/css\" href=\"" (srcUrl Css) "\"/>") ) (de javascript (JS . @) (when *JS (when JS (prinl "<script type=\"text/javascript\" src=\"" (srcUrl JS) "\"></script>") ) (when (rest) (prinl "<script type=\"text/javascript\">" @ "</script>") ) ) ) (de <div> (Attr . Prg) (tag 'div Attr 2 Prg) (prinl) ) (de <span> (Attr . Prg) (tag 'span Attr 2 Prg) ) (de <br> Prg (htPrin Prg 2) (prinl "<br/>") ) (de -- () (prinl "<br/>") ) (de ---- () (prinl "<br/><br/>") ) (de <hr> () (prinl "<hr/>") ) (de <nbsp> (N) (do (or N 1) (prin " ")) ) (de <small> Prg (tag 'small NIL 2 Prg) ) (de <big> Prg (tag 'big NIL 2 Prg) ) (de <em> Prg (tag 'em NIL 2 Prg) ) (de <strong> Prg (tag 'strong NIL 2 Prg) ) (de <h1> (Attr . Prg) (tag 'h1 Attr 2 Prg) (prinl) ) (de <h2> (Attr . Prg) (tag 'h2 Attr 2 Prg) (prinl) ) (de <h3> (Attr . Prg) (tag 'h3 Attr 2 Prg) (prinl) ) (de <h4> (Attr . Prg) (tag 'h4 Attr 2 Prg) (prinl) ) (de <h5> (Attr . Prg) (tag 'h5 Attr 2 Prg) (prinl) ) (de <h6> (Attr . Prg) (tag 'h6 Attr 2 Prg) (prinl) ) (de <p> (Attr . Prg) (tag 'p Attr 2 Prg) (prinl) ) (de <pre> (Attr . Prg) (tag 'pre Attr 2 Prg) (prinl) ) (de <ol> (Attr . Prg) (tag 'ol Attr 2 Prg) (prinl) ) (de <ul> (Attr . Prg) (tag 'ul Attr 2 Prg) (prinl) ) (de <li> (Attr . Prg) (tag 'li Attr 2 Prg) (prinl) ) (de <href> (Str Url Tar) (prin "<a href=\"" (sesId (ifn (pre? "+" Url) Url (setq Tar "_blank") (pack (cdr (chop Url))) ) ) "\"" ) (and Tar (prin " target=\"" Tar "\"")) (and *Style (htStyle @)) (prin ">") (ht:Prin Str) (prin "</a>") ) (de <img> (Src Alt Url DX DY) (when Url (prin "<a href=\"" (sesId (ifn (pre? "+" Url) Url (pack (cdr (chop Url)) "\" target=\"_blank") ) ) "\">" ) ) (prin "<img src=\"" (sesId Src) "\"") (when Alt (prin " alt=\"") (ht:Prin Alt) (prin "\"") ) (and DX (prin " width=\"" DX "\"")) (and DY (prin " height=\"" DY "\"")) (and *Style (htStyle @)) (prin "/>") (and Url (prin "</a>")) ) (de <this> (Var Val . Prg) (prin "<a href=\"" (sesId *Url) "?" Var "=" (ht:Fmt Val) "\"") (and *Style (htStyle @)) (prin ">") (htPrin Prg 2) (prin "</a>") ) (de <table> (Attr Ttl "Head" . Prg) (tag 'table Attr 1 (quote (and Ttl (tag 'caption NIL 1 Ttl)) (when (find cdr "Head") (tag 'tr NIL 1 (quote (for X "Head" (tag 'th (car X) 2 (cdr X)) ) ) ) ) (htPrin Prg 2) ) ) (prinl) ) (de <row> (Cls . Prg) (tag 'tr NIL 1 (quote (let (L Prg H (up "Head")) (while L (let (X (pop 'L) C (pack Cls (and Cls (caar H) " ") (caar H)) N 1) (while (== '- (car L)) (inc 'N) (pop 'L) (pop 'H) ) (setq C (if2 C (> N 1) (list C (cons 'colspan N)) C (cons 'colspan N) ) ) (tag 'td (if (== 'align (car (pop 'H))) (list '(align . right) C) C ) 1 (quote (if (atom X) (ht:Prin (eval X 1)) (eval X 1) ) ) ) ) ) ) ) ) ) (de <th> (Attr . Prg) (tag 'th Attr 2 Prg) ) (de <tr> (Attr . Prg) (tag 'tr Attr 2 Prg) ) (de <td> (Attr . Prg) (tag 'td Attr 2 Prg) ) (de <grid> (X . Lst) (tag 'table 'grid 1 (quote (while Lst (tag 'tr NIL 1 (quote (use X (let L (and (sym? X) (chop X)) (do (or (num? X) (length X)) (tag 'td (cond ((pair X) (pop 'X)) ((= "." (pop 'L)) 'align) ) 1 (quote (if (atom (car Lst)) (ht:Prin (eval (pop 'Lst) 1)) (eval (pop 'Lst) 1) ) ) ) ) ) ) ) ) ) ) ) (prinl) ) (de <trident> Lst (<table> '(width . "100%") NIL NIL (<tr> NIL (<td> '((width . "33%") (align . left)) (eval (car Lst) 1) ) (<td> '((width . "34%") (align . center)) (eval (cadr Lst) 1) ) (<td> '((width . "33%") (align . right)) (eval (caddr Lst) 1) ) ) ) ) (de <spread> Lst (<table> '(width . "100%") NIL '((norm) (align)) (<row> NIL (eval (car Lst) 1) (run (cdr Lst) 1) ) ) ) (de tip ("Str" "Txt") (<span> (cons 'title "Str") "Txt") ) (de <tip> ("Str" . "Prg") (style (cons 'title "Str") "Prg") ) # Layout (de <layout> "Lst" (let ("X" 0 "Y" 0) (recur ("Lst" "Y") (for "L" "Lst" (let ("Args" (mapcar eval (cddar "L")) "DX" (eval (caar "L")) "DY" (eval (cadar "L")) "Cls" (unless (sub? ":" (car "Args")) (pop '"Args")) "Style" (cons 'style (glue "; " (cons "position:absolute" (pack "top:" (abs "Y") (if (ge0 "Y") "px" "%")) (pack "left:" (abs "X") (if (ge0 "X") "px" "%")) (cond ((=0 "DX") "min-width:100%") ("DX" (pack "width:" (abs @) (if (ge0 "DX") "px" "%")) ) ) (cond ((=0 "DY") "min-height:100%") ("DY" (pack "height:" (abs @ ) (if (ge0 "DY")"px" "%")) ) ) "Args" ) ) ) ) (prog1 (if "Cls" (list "Cls" "Style") "Style") # -> '@' (eval (cadr "L")) ) (let "X" (+ "X" "DX") (recurse (cddr "L") "Y") ) (inc '"Y" "DY") ) ) ) ) ) # Menus (de urlMT (Url Menu Tab Id Str) (pack Url "?" "*Menu=+" Menu "&*Tab=+" Tab "&*ID=" (ht:Fmt Id) Str) ) (de <menu> Lst (let (M 1 N 1 E 2 U) (recur (Lst N E) (<ul> NIL (for L Lst (nond ((car L) (<li> NIL (htPrin (cdr L) 2))) ((=T (car L)) (if (setq U (eval (cadr L) E)) (<li> (pack (if (= U *Url) 'act 'cmd) N) (<tip> "-->" (<href> (eval (car L) E) (urlMT U *Menu (if (= U *Url) *Tab 1) (eval (caddr L)) (eval (cadddr L)) ) ) ) ) (<li> (pack 'cmd N) (ht:Prin (eval (car L) E)) ) ) ) ((bit? M *Menu) (<li> (pack 'sub N) (<tip> ,"Open submenu" (<href> (eval (cadr L) E) (urlMT *Url (| M *Menu) *Tab *ID) ) ) ) (setq M (>> -1 M)) (recur (L) (for X (cddr L) (when (=T (car X)) (recurse X) (setq M (>> -1 M)) ) ) ) ) (NIL (<li> (pack 'top N) (<tip> ,"Close submenu" (<href> (eval (cadr L) E) (urlMT *Url (x| M *Menu) *Tab *ID) ) ) (setq M (>> -1 M)) (recurse (cddr L) (inc N) (inc E)) ) ) ) ) ) ) ) ) (de <bar> Lst (use U (<ul> NIL (for (I . M) Lst (if (= I *Menu) (<li> "top" (<href> (eval (car M) 1) (urlMT *Url 0 *Tab *ID) ) (<ul> NIL (for L (cdr M) (if (setq U (eval (cadr L) 1)) (<li> (if (= U *Url) "act" "cmd") (<href> (eval (car L) 1) (urlMT U 0 (if (= U *Url) *Tab 1) (eval (caddr L)) (eval (cadddr L)) ) ) ) (<li> "cmd" (ht:Prin (eval (car L) 1)) ) ) ) ) ) (<li> "sub" (<href> (eval (car M) 1) (urlMT *Url I *Tab *ID) ) ) ) ) ) ) ) # Update link (de updLink () (<tip> ,"Update" (<span> 'step (<href> "@" (urlMT *Url *Menu *Tab *ID))) ) ) # Tabs (de <tab> Lst (<table> 'tab NIL NIL (for (N . L) Lst (if (= N *Tab) (<td> 'top (ht:Prin (eval (car L) 1))) (<td> 'sub (<href> (eval (car L) 1) (urlMT *Url *Menu N *ID)) ) ) ) ) (htPrin (get Lst *Tab -1) 2) ) ### DB Linkage ### (de mkUrl (Lst) (pack (pop 'Lst) "?" (make (while Lst (and (sym? (car Lst)) (= `(char '*) (char (car Lst))) (link (pop 'Lst) "=") ) (link (ht:Fmt (pop 'Lst))) (and Lst (link "&")) ) ) ) ) (de <$> (Str Obj Msg Tab) (cond ((not Obj) (ht:Prin Str)) ((=T Obj) (<href> Str (pack Msg Str))) ((send (or Msg 'url>) Obj (or Tab 1)) (<href> Str (mkUrl @)) ) (T (ht:Prin Str)) ) ) # Links to previous and next object (de stepBtn (Var Cls Hook Msg) (default Msg 'url>) (<span> 'step (use (Rel S1 S2) (if (isa '+Joint (setq Rel (meta *ID Var))) (let Lst (get *ID Var (; Rel slot)) (setq S2 (lit (cadr (memq *ID Lst))) S1 (lit (car (seek '((L) (== *ID (cadr L))) Lst))) ) ) (let (K (cond ((isa '+Key Rel) (get *ID Var) ) ((isa '+Fold Rel) (cons (fold (get *ID Var)) *ID) ) (T (cons (get *ID Var) (conc (mapcar '((S) (get *ID S)) (; Rel aux)) *ID ) ) ) ) Q1 (init (tree Var Cls Hook) K NIL) Q2 (init (tree Var Cls Hook) K T) ) (unless (get *ID T) (step Q1 T) (step Q2 T) ) (setq S1 (list 'step (lit Q1) T) S2 (list 'step (lit Q2) T) ) ) ) (if (and (eval S1) (send Msg @ *Tab)) (<tip> ,"Next object of the same type" (<href> "<<<" (mkUrl @)) ) (prin "<<<") ) (prin " -- ") (if (and (eval S2) (send Msg @ *Tab)) (<tip> ,"Next object of the same type" (<href> ">>>" (mkUrl @)) ) (prin ">>>") ) ) ) ) # Character Separated Values (off "*CSV") (de csv ("Nm" . "Prg") (call 'rm "-f" (tmp "Nm" ".csv")) (let "*CSV" (pack "+" (tmp "Nm" ".csv")) (run "Prg") ) (<href> "CSV" (tmp "Nm" ".csv")) ) (de <0> @ (when "*CSV" (out @ (prin (next)) (while (args) (prin "^I" (next)) ) (prinl "^M") ) ) ) (de <%> @ (prog1 (pass pack) (ht:Prin @) (prinl "<br/>") (<0> @) ) ) (de <!> ("Lst") (when "*CSV" (out @ (prin (eval (cadar "Lst"))) (for "S" (cdr "Lst") (prin "^I" (eval (cadr "S"))) ) (prinl "^M") ) ) "Lst" ) (de <+> (Str Obj Msg Tab) (<$> Str Obj Msg Tab) (and "*CSV" (out @ (prin Str "^I"))) ) (de <-> (Str Obj Msg Tab) (<$> Str Obj Msg Tab) (<0> Str) ) # Interactive tree (de <tree> ("Url" "Path" "Tree" "Able?" "Excl?" "Expand" "Print") (default "Print" 'ht:Prin) (let ("Pos" "Tree" "F" (pop '"Path") "A" 0) (when "Path" (loop (and "F" (not (cdr "Path")) (map '((L) (when (pair (car L)) (set L (caar L))) ) "Pos" ) ) (T (atom (car (setq "Pos" (nth "Pos" (abs (pop '"Path"))))))) (NIL "Path") (setq "Pos" (cdar "Pos")) ) (set "Pos" (if (atom (car "Pos")) (cons (car "Pos") ("Expand" (car "Pos"))) (caar "Pos") ) ) ) (setq "Pos" (car "Pos")) ("tree" "Tree") "Tree" ) ) (de "tree" ("Tree" "Lst") (prinl "<ul>") (for ("N" . "X") "Tree" (prin "<li><a id=\"T" (inc '"A") "\"></a>") (cond ((pair "X") (let "L" (append "Lst" (cons "N")) (<href> (if (== "X" "Pos") "<+>" "[+]") (pack "Url" "?" (ht:Fmt (cons NIL "L")) "#T" (max 1 (- "A" 12)) ) ) (space) ("Print" (car "X")) (and (cdr "X") ("tree" @ "L")) ) ) (("Able?" "X") (let "L" (append "Lst" (cons (- "N"))) (<href> (if (== "X" "Pos") "< >" "[ ]") (pack "Url" "?" (ht:Fmt (cons ("Excl?" "X") "L")) "#T" (max 1 (- "A" 12)) ) ) (space) ("Print" "X") ) ) (T ("Print" "X")) ) (prin "</li>") ) (prinl "</ul>") ) ### HTML form ### (de <post> (Attr Url . Prg) (prin "<form enctype=\"multipart/form-data\" action=\"" (sesId Url) (and *JS "\" onkeydown=\"return formKey(event)\" onkeypress=\"return formKey(event)\" onsubmit=\"return doPost(this)") "\" method=\"post\">" ) (prin "<noscript><input type=\"hidden\" name=\"*JS\" value=\"\"/></noscript>") (tag 'fieldset Attr 2 Prg) (prinl "</form>") ) (de htmlVar ("Var") (prin "name=\"") (if (pair "Var") (prin (car "Var") ":" (cdr "Var")) (prin "Var") ) (prin "\"") ) (de htmlVal ("Var") (if (pair "Var") (cdr (assoc (cdr "Var") (val (car "Var")))) (val "Var") ) ) (de <label> (Attr . Prg) (tag 'label Attr 2 Prg) ) (de <field> (N "Var" Max Flg) (prin "<input type=\"text\" ") (htmlVar "Var") (prin " value=\"") (ht:Prin (htmlVal "Var")) (prin "\" size=\"") (if (lt0 N) (prin (- N) "\" style=\"text-align: right;\"") (prin N "\"") ) (and Max (prin " maxlength=\"" Max "\"")) (when *JS (prin " onchange=\"return fldChg(this)\"") (htJs) ) (dfltCss "field") (and Flg (prin " disabled=\"disabled\"")) (prinl "/>") ) (de <hidden> ("Var" Val) (prin "<input type=\"hidden\" ") (htmlVar "Var") (prin " value=\"") (ht:Prin Val) (prinl "\"/>") ) (de <passwd> (N "Var" Max Flg) (prin "<input type=\"password\" ") (htmlVar "Var") (prin " value=\"") (ht:Prin (htmlVal "Var")) (prin "\" size=\"" N "\"") (and Max (prin " maxlength=\"" Max "\"")) (when *JS (prin " onchange=\"return fldChg(this)\"") (htJs) ) (dfltCss "passwd") (and Flg (prin " disabled=\"disabled\"")) (prinl "/>") ) (de <upload> (N "Var" Flg) (prin "<input type=\"file\" ") (htmlVar "Var") (prin " value=\"") (ht:Prin (htmlVal "Var")) (prin "\" size=\"" N "\"") (when *JS (prin " onchange=\"return fldChg(this)\"") (htJs) ) (dfltCss "upload") (and Flg (prin " disabled=\"disabled\"")) (prinl "/>") ) (de <area> (Cols Rows "Var" Flg) (prin "<textarea ") (htmlVar "Var") (prin " cols=\"" Cols "\" rows=\"" Rows "\" wrap=\"off\"") (when *JS (prin " onchange=\"return fldChg(this)\"") (htJs) ) (dfltCss "area") (and Flg (prin " disabled=\"disabled\"")) (prin ">") (ht:Prin (htmlVal "Var")) (prinl "</textarea>") ) (de <select> (Lst "Var" Flg) (prin "<select ") (htmlVar "Var") (when *JS (prin " onchange=\"return fldChg(this)\"") (htJs) ) (dfltCss "select") (prin ">") (for "X" Lst (let "V" (if (atom "X") "X" (car "X")) (prin "<option" (and (pair "X") (pack " title=\"" (cdr "X") "\"")) (cond ((= "V" (htmlVal "Var")) " selected=\"selected\"") (Flg " disabled=\"disabled\"") ) ">" ) (ht:Prin "V") ) (prin "</option>") ) (prinl "</select>") ) (de <check> ("Var" Flg) (let Val (htmlVal "Var") (prin "<input type=\"hidden\" ") (htmlVar "Var") (prin " value=\"" (and Flg Val T) "\">") (prin "<input type=\"checkbox\" ") (htmlVar "Var") (prin " value=\"T\"" (and Val " checked=\"checked\"")) (when *JS (prin " onchange=\"return fldChg(this)\"") (htJs) ) (dfltCss "check") (and Flg (prin " disabled=\"disabled\"")) (prinl "/>") ) ) (de <radio> ("Var" Val Flg) (prin "<input type=\"radio\" ") (htmlVar "Var") (prin " value=\"") (ht:Prin Val) (prin "\"" (and (= Val (htmlVal "Var")) " checked=\"checked\"")) (when *JS (prin " onchange=\"return fldChg(this)\"") (htJs) ) (dfltCss "radio") (and Flg (prin " disabled=\"disabled\"")) (prinl "/>") ) (de <submit> (S "Var" Flg JS) (prin "<input type=\"submit\"") (and "Var" (space) (htmlVar "Var")) (prin " value=\"") (ht:Prin S) (prin "\"") (when *JS (prin " onmousedown=\"inBtn(this,1)\" onblur=\"inBtn(this,0)\"") (and JS (prin " onclick=\"return doBtn(this)\"")) (htJs) ) (dfltCss "submit") (and Flg (prin " disabled=\"disabled\"")) (prinl "/>") ) (de <image> (Src "Var" Flg JS) (prin "<input type=\"image\"") (and "Var" (space) (htmlVar "Var")) (prin " src=\"" (sesId Src) "\"") (when *JS (prin " onmousedown=\"inBtn(this,1)\" onblur=\"inBtn(this,0)\"") (and JS (prin " onclick=\"return doBtn(this)\"")) (htJs) ) (dfltCss "image") (and Flg (prin " disabled=\"disabled\"")) (prinl "/>") ) (de <reset> (S Flg) (prin "<input type=\"reset\" value=\"") (ht:Prin S) (prin "\"") (dfltCss "reset") (and Flg (prin " disabled=\"disabled\"")) (prinl "/>") ) # vi:et:ts=3:sw=3 ������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/xm.l����������������������������������������������������������������������0000644�0000000�0000000�00000006433�12265263724�014525� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 25sep13abu # (c) Software Lab. Alexander Burger # Check or write header (de xml? (Flg) (if Flg (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>") (skip) (prog1 (head '("<" "?" "x" "m" "l") (till ">")) (char) ) ) ) # Generate/Parse XML data (de xml (Lst N) (if Lst (let Tag (pop 'Lst) (space (default N 0)) (prin "<" Tag) (for X (pop 'Lst) (prin " " (car X) "=\"") (escXml (cdr X)) (prin "\"") ) (nond (Lst (prinl "/>")) ((or (cdr Lst) (pair (car Lst))) (prin ">") (escXml (car Lst)) (prinl "</" Tag ">") ) (NIL (prinl ">") (for X Lst (if (pair X) (xml X (+ 3 N)) (space (+ 3 N)) (escXml X) (prinl) ) ) (space N) (prinl "</" Tag ">") ) ) ) (skip) (unless (= "<" (char)) (quit "Bad XML") ) (_xml (till " /<>" T)) ) ) (de _xml (Tok) (use X (make (link (intern Tok)) (let L (make (loop (NIL (skip) (quit "XML parse error")) (T (member @ '`(chop "/>"))) (NIL (setq X (intern (till "=" T)))) (char) (unless (= "\"" (char)) (quit "XML parse error" X) ) (link (cons X (pack (xmlEsc (till "\""))))) (char) ) ) (if (= "/" (char)) (prog (char) (and L (link L))) (link L) (loop (NIL (skip) (quit "XML parse error" Tok)) (T (and (= "<" (setq X (char))) (= "/" (peek))) (char) (unless (= Tok (till " /<>" T)) (quit "Unbalanced XML" Tok) ) (char) ) (if (= "<" X) (and (_xml (till " /<>" T)) (link @)) (link (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) ) (de xmlEsc (L) (use (@X @Z) (make (while L (ifn (match '("&" @X ";" @Z) L) (link (pop 'L)) (link (cond ((= @X '`(chop "quot")) "\"") ((= @X '`(chop "amp")) "&") ((= @X '`(chop "lt")) "<") ((= @X '`(chop "gt")) ">") ((= @X '`(chop "apos")) "'") ((= "#" (car @X)) (char (if (= "x" (cadr @X)) (hex (cddr @X)) (format (cdr @X)) ) ) ) (T @X) ) ) (setq L @Z) ) ) ) ) ) (de escXml (X) (for C (chop X) (if (member C '`(chop "\"&<")) (prin "&#" (char C) ";") (prin C) ) ) ) # Access functions (de body (Lst . @) (while (and (setq Lst (cddr Lst)) (args)) (setq Lst (asoq (next) Lst)) ) Lst ) (de attr (Lst Key . @) (while (args) (setq Lst (asoq Key (cddr Lst)) Key (next) ) ) (cdr (asoq Key (cadr Lst))) ) # vi:et:ts=3:sw=3 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/xml.l���������������������������������������������������������������������0000644�0000000�0000000�00000022272�12265263724�014700� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 25sep13abu # 21jan09 Tomas Hlavaty <kvietaag@seznam.cz> # Check or write header (de xml? (Flg) (if Flg (prinl "<?xml version=\"1.0\" encoding=\"utf-8\"?>") (skip) (prog1 (head '("<" "?" "x" "m" "l") (till ">")) (char) ) ) ) # Generate/Parse XML data # expects well formed XML # encoding by picolisp (utf8 "only", no utf16 etc.) # trim whitespace except in cdata # ignore <? <!-- <!DOCTYPE # non-builtin entities as normal text: &ent; => ent (de xml (Lst N) (if Lst (let (Nn NIL Nl NIL Pre NIL) (when N (do (abs N) (push 'Nn (if (lt0 N) "^I" " ")) ) ) (_xml_ Lst) ) (_xml) ) ) (de _xml_ (Lst) (let Tag (pop 'Lst) (when Nl (prinl) (when Pre (prin Pre) ) ) (prin "<" Tag) (for X (pop 'Lst) (prin " " (car X) "=\"") (escXml (cdr X)) (prin "\"") ) (ifn Lst (prin "/>") (prin ">") (use Nlx (let (Nl N Pre (cons Pre Nn) ) (for X Lst (if (pair X) (_xml_ X) (off Nl) (escXml X) ) ) (setq Nlx Nl) ) (when Nlx (prinl) (when Pre (prin Pre) ) ) ) (prin "</" Tag ">") ) ) ) (de _xml (In Char) (unless Char (skip) (unless (= "<" (char)) (quit "Bad XML") ) ) (case (peek) ("?" (from "?>") (unless In (_xml In)) ) ("!" (char) (case (peek) ("-" (ifn (= "-" (char) (char)) (quit "XML comment expected") (from "-->") (unless In (_xml In)) ) ) ("D" (if (find '((C) (<> C (char))) '`(chop "DOCTYPE")) (quit "XML DOCTYPE expected") (when (= "[" (from "[" ">")) (use X (loop (T (= "]" (setq X (from "]" "\"" "'" "<!--")))) (case X ("\"" (from "\"")) ("'" (from "'")) ("<!--" (from "-->")) (NIL (quit "Unbalanced XML DOCTYPE")) ) ) ) (from ">") ) (unless In (_xml In)) ) ) ("[" (if (find '((C) (<> C (char))) '`(chop "[CDATA[")) (quit "XML CDATA expected") (pack (head -3 (make (loop (NIL (link (char)) (quit "Unbalanced XML CDATA")) (T (= '`(chop "]]>") (tail 3 (made)))) ) ) ) ) ) ) (T (quit "Unhandled XML tag")) ) ) (T (let Tok (till " ^I^M^J/>" T) (use X (make (link (intern (pack Tok))) (let L (make (loop (NIL (skip) (quit "Unexpected end of XML" Tok)) (T (member @ '("/" ">"))) (NIL (setq X (intern (pack (trim (till "=")))))) (char) (skip) (let C (char) (unless (member C '("\"" "'")) (quit "XML attribute quote expected" X) ) (link (cons X (pack (xmlEsc (till C))))) ) (char) ) ) (if (= "/" (char)) (prog (char) (and L (link L))) (link L) (loop (NIL (if *XmlKeepBlanks (peek) (skip)) (quit "Unexpected end of XML" Tok) ) (T (and (= "<" (setq X (char))) (= "/" (peek))) (char) (unless (= Tok (till " ^I^M^J/>" T)) (quit "Unbalanced XML" Tok) ) (skip) (char) ) (if (= "<" X) (when (_xml T "<") (link @) ) (link (pack (xmlEsc ((if *XmlKeepBlanks prog trim) (cons X (till "<")) ) ) ) ) ) ) ) ) ) ) ) ) ) ) (de xmlEsc (L) (use (@X @Z) (make (while L (ifn (match '("&" @X ";" @Z) L) (link (pop 'L)) (link (cond ((= @X '`(chop "quot")) "\"") ((= @X '`(chop "amp")) "&") ((= @X '`(chop "lt")) "<") ((= @X '`(chop "gt")) ">") ((= @X '`(chop "apos")) "'") ((= "#" (car @X)) (char (if (= "x" (cadr @X)) (hex (cddr @X)) (format (cdr @X)) ) ) ) (T @X) ) ) (setq L @Z) ) ) ) ) ) (de escXml (X) (for C (chop X) (prin (case C ("\"" """) ("&" "&") ("<" "<") (">" ">") (T C) ) ) ) ) # Simple XML string (de xml$ (Lst) (pack (make (recur (Lst) (let Tag (pop 'Lst) (link "<" Tag) (for X (pop 'Lst) (link " " (car X) "=\"" (cdr X) "\"") ) (ifn Lst (link "/>") (link ">") (for X Lst (if (pair X) (recurse X (+ 3 N)) (link X) ) ) (link "</" Tag ">") ) ) ) ) ) ) # Access functions (de body (Lst . @) (while (and (setq Lst (cddr Lst)) (args)) (setq Lst (asoq (next) Lst)) ) Lst ) (de attr (Lst Key . @) (while (args) (setq Lst (asoq Key (cddr Lst)) Key (next) ) ) (cdr (asoq Key (cadr Lst))) ) # <xml> output (de "xmlL" Lst (push '"Xml" (make (link (pop 'Lst)) (let Att (make (while (and Lst (car Lst) (atom (car Lst))) (let K (pop 'Lst) (if (=T K) (for X (eval (pop 'Lst) 1) (if (=T (car X)) (link (cons (cdr X) NIL)) (when (cdr X) (link X) ) ) ) (when (eval (pop 'Lst) 1) (link (cons K @)) ) ) ) ) ) (let "Xml" NIL (xrun Lst) (ifn "Xml" (when Att (link Att) ) (link Att) (chain (flip "Xml")) ) ) ) ) ) ) (de "xmlO" Lst (let Tag (pop 'Lst) (when "Nl" (prinl) (when "Pre" (prin "Pre") ) ) (prin "<" Tag) (while (and Lst (car Lst) (atom (car Lst))) (let K (pop 'Lst) (if (=T K) (for X (eval (pop 'Lst) 1) (if (=T (car X)) (prin " " (cdr X) "=\"\"") (when (cdr X) (prin " " (car X) "=\"") (escXml (cdr X)) (prin "\"") ) ) ) (when (eval (pop 'Lst) 1) (prin " " K "=\"") (escXml @) (prin "\"") ) ) ) ) (ifn Lst (prin "/>") (prin ">") (use Nl (let ("Nl" "N" "Pre" (cons "Pre" "Nn") ) (xrun Lst) (setq Nl "Nl") ) (when Nl (prinl) (when "Pre" (prin "Pre") ) ) ) (prin "</" Tag ">") ) ) ) (de <xml> ("N" . Lst) (if (=T "N") (let (<xml> "xmlL" xprin '(@ (push '"Xml" (pass pack))) xrun '((Lst Ofs) (default Ofs 2) (for X Lst (if (pair X) (eval X Ofs '("Xml")) (when (eval X Ofs '("Xml")) (xprin @) ) ) ) ) "Xml" NIL ) (run Lst 1 '(<xml> xprin xrun "Xml")) (car (flip "Xml")) ) (let (<xml> "xmlO" xprin '(@ (off "Nl") (mapc escXml (rest))) xrun '((Lst Ofs) (default Ofs 2) (for X Lst (if (pair X) (eval X Ofs '("Nl" "Pre")) (when (eval X Ofs '("Nl" "Pre")) (xprin @) ) ) ) ) "Nn" NIL "Nl" NIL "Pre" NIL ) (when "N" (do (abs "N") (push '"Nn" (if (lt0 "N") "^I" " ")) ) ) (run Lst 1 '(<xml> xprin xrun "N" "Nn" "Nl" "Pre")) ) ) ) # vi:et:ts=3:sw=3 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/xmlrpc.l������������������������������������������������������������������0000644�0000000�0000000�00000005471�12265263724�015407� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 31jul13abu # (c) Software Lab. Alexander Burger # (xmlrpc "localhost" 8080 "foo.bar" 'int 41 'string "abc" ..) (de xmlrpc (Host Port Meth . @) (let? Sock (connect Host Port) (let Xml (tmp 'xmlrpc) (out Xml (xml? T) (xml (list 'methodCall NIL (list 'methodName NIL Meth) (make (link 'params NIL) (while (args) (link (list 'param NIL (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) ) (prog1 (out Sock (prinl "POST /RPC2 HTTP/1.0^M") (prinl "Host: " Host "^M") (prinl "User-Agent: PicoLisp^M") (prinl "Content-Type: text/xml^M") (prinl "Accept-Charset: utf-8^M") (prinl "Content-Length: " (car (info Xml)) "^M") (prinl "^M") (in Xml (echo)) (flush) (in Sock (while (line)) (let? L (and (xml?) (xml)) (when (== 'methodResponse (car L)) (xmlrpcValue (car (body L 'params 'param 'value)) ) ) ) ) ) (close Sock) ) ) ) ) (de xmlrpcKey (Str) (or (format Str) (intern Str)) ) (de xmlrpcValue (Lst) (let X (caddr Lst) (casq (car Lst) (string X) ((i4 int) (format X)) (boolean (= "1" X)) (double (format X *Scl)) (array (when (== 'data (car X)) (mapcar '((L) (and (== 'value (car L)) (xmlrpcValue (caddr L))) ) (cddr X) ) ) ) (struct (extract '((L) (when (== 'member (car L)) (cons (xmlrpcKey (caddr (assoc 'name L))) (xmlrpcValue (caddr (assoc 'value L))) ) ) ) (cddr Lst) ) ) ) ) ) # SSL transactions # By meingbg <meingbg@gmail.com> (de xmlrpcssl (Url Meth . @) (let Xml (tmp "xmlrpcssl") (out Xml (xml? T) (xml (list 'methodCall NIL (list 'methodName NIL Meth) (make (link 'params NIL) (while (args) (link (list 'param NIL (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) ) (in (list "wget" "--no-http-keep-alive" "--no-check-certificate" (pack "--post-file=" Xml) "-O" "-" "-o" "/dev/null" Url) (let? L (and (xml?) (xml)) (when (== 'methodResponse (car L)) (xmlrpcValue (car (body L 'params 'param 'value)) ) ) ) ) ) ) # vi:et:ts=3:sw=3 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/z3d.l���������������������������������������������������������������������0000644�0000000�0000000�00000045774�12265263724�014614� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 03sep13abu # (c) Software Lab. Alexander Burger (load "@lib/native.l") ### Z-Buffer 3D library ### (gcc "z3d" '("-L/usr/X11R6/lib" "-lXext" "-lX11") (z3dX (M X) z3dX NIL M (cons X 1.0)) (z3dY (M Y) z3dY NIL M (cons Y 1.0)) (z3dZ (M Z) z3dZ NIL M (cons Z 1.0)) (z3dDX (M DX) z3dDX NIL M (cons DX 1.0)) (z3dDY (M DY) z3dDY NIL M (cons DY 1.0)) (z3dDZ (M DZ) z3dDZ NIL M (cons DZ 1.0)) (z3dXrot (M A) z3dXrot NIL M (cons A 1.0)) (z3dYrot (M A) z3dYrot NIL M (cons A 1.0)) (z3dZrot (M A) z3dZrot NIL M (cons A 1.0)) (z3dArot (M A) z3dArot NIL M (cons A 1.0)) (z3dRotate (M X Y Z VarX VarY VarZ Flg) z3dRotate NIL M (cons X 1.0) (cons Y 1.0) (cons Z 1.0) (if VarX (list @ (8 . 1.0)) 0) (if VarY (list @ (8 . 1.0)) 0) (if VarZ (list @ (8 . 1.0)) 0) (if Flg 1 0) ) (z3dSpot (VarX VarY X Y Z) z3dSpot NIL (list VarX (8 . 1.0)) (list VarY (8 . 1.0)) (cons X 1.0) (cons Y 1.0) (cons Z 1.0) ) (z3dWindow (Ttl DX DY) z3dWindow 'S Ttl DX DY) (z3dCamera (Foc Yaw Pitch X Y Z Sky Gnd) z3dCamera NIL (cons Foc 1.0) (cons Yaw 1.0) (cons Pitch 1.0) (cons X 1.0) (cons Y 1.0) (cons Z 1.0) Sky Gnd ) (z3dDraw (M) z3dDraw NIL M) (z3dPut () z3dPut) (z3dText (X Y S) z3dText NIL X Y S) (z3dSync () z3dSync) ) #include <stdint.h> #include <stdlib.h> #include <unistd.h> #include <string.h> #include <math.h> #include <X11/Xlib.h> #include <X11/Xutil.h> #include <sys/shm.h> #include <X11/extensions/XShm.h> #define SCL 1000000.0 typedef struct {double x, y, z;} vector; typedef struct {vector a, b, c;} matrix; typedef struct face { int col1, col2; // Foreground and background color int cnt, _x_; // Number of points vector pt[1]; // Points } face; typedef struct model { vector pos; // Position matrix rot; // Orientation void *lst[1]; // List of faces and submodels } model; typedef struct { int h[2]; // Horizontal unsigned z[2]; // Depth } edge; static double FocLen, PosX, PosY, PosZ, Pos6, Pos9; static double Coeff1, Coeff2, Coeff4, Coeff5, Coeff6, Coeff7, Coeff8, Coeff9; static Display *Disp; static int Scrn; static Colormap Cmap; static int Dpth; static int PixSize; static GC Gc; static Window Win; static int SizX, SizY, OrgX, OrgY; static unsigned *Zbuff; static edge *Edges; static XImage *Img; static XShmSegmentInfo Info; // (z3dX 'model 'x) void z3dX(model *p, double x) { p->pos.x = x; } // (z3dY 'model 'y) void z3dY(model *p, double y) { p->pos.y = y; } // (z3dZ 'model 'z) void z3dZ(model *p, double z) { p->pos.z = z; } // (z3dDX 'model 'dx) void z3dDX(model *p, double dx) { p->pos.x += dx; } // (z3dDY 'model 'dy) void z3dDY(model *p, double dy) { p->pos.y += dy; } // (z3dDZ 'model 'dz) void z3dDZ(model *p, double dz) { p->pos.z += dz; } static void xrot(matrix *p, double ca, double sa) { matrix m = *p; p->b.x = ca * m.b.x - sa * m.c.x; p->b.y = ca * m.b.y - sa * m.c.y; p->b.z = ca * m.b.z - sa * m.c.z; p->c.x = sa * m.b.x + ca * m.c.x; p->c.y = sa * m.b.y + ca * m.c.y; p->c.z = sa * m.b.z + ca * m.c.z; } static void yrot(matrix *p, double ca, double sa) { matrix m = *p; p->a.x = ca * m.a.x + sa * m.c.x; p->a.y = ca * m.a.y + sa * m.c.y; p->a.z = ca * m.a.z + sa * m.c.z; p->c.x = ca * m.c.x - sa * m.a.x; p->c.y = ca * m.c.y - sa * m.a.y; p->c.z = ca * m.c.z - sa * m.a.z; } static void zrot(matrix *p, double ca, double sa) { matrix m = *p; p->a.x = ca * m.a.x + sa * m.b.x; p->a.y = ca * m.a.y + sa * m.b.y; p->a.z = ca * m.a.z + sa * m.b.z; p->b.x = ca * m.b.x - sa * m.a.x; p->b.y = ca * m.b.y - sa * m.a.y; p->b.z = ca * m.b.z - sa * m.a.z; } // (z3dXrot 'model 'angle) void z3dXrot(model *p, double a) { xrot(&p->rot, cos(a), sin(a)); } // (z3dYrot 'model 'angle) void z3dYrot(model *p, double a) { yrot(&p->rot, cos(a), sin(a)); } // (z3dZrot 'model 'angle) void z3dZrot(model *p, double a) { zrot(&p->rot, cos(a), sin(a)); } // (z3dArot 'model 'angle) void z3dArot(model *p, double a) { double n; vector *v; v = ((face*)p->lst[0])->pt; n = sqrt(v->x * v->x + v->y * v->y + v->z * v->z); v->x /= n, v->y /= n, v->z /= n; // Axis unit vector if ((n = sqrt(v->y * v->y + v->z * v->z)) < 1.0/SCL) // Axis parallel to x-axis a *= v->x, xrot(&p->rot, cos(a), sin(a)); else { xrot(&p->rot, v->z / n, -v->y / n); yrot(&p->rot, n, v->x); zrot(&p->rot, cos(a), sin(a)); yrot(&p->rot, n, -v->x); xrot(&p->rot, v->z / n, v->y / n); } } // (z3dRotate 'model 'X 'Y 'Z 'varX 'varY 'varZ ['flg]) void z3dRotate(model *p, double vx, double vy, double vz, double *xp, double *yp, double *zp, int flg) { if (!flg) { if (xp) *xp = vx * p->rot.a.x + vy * p->rot.b.x + vz * p->rot.c.x; if (yp) *yp = vx * p->rot.a.y + vy * p->rot.b.y + vz * p->rot.c.y; if (zp) *zp = vx * p->rot.a.z + vy * p->rot.b.z + vz * p->rot.c.z; } else { if (xp) *xp = vx * p->rot.a.x + vy * p->rot.a.y + vz * p->rot.a.z; if (yp) *yp = vx * p->rot.b.x + vy * p->rot.b.y + vz * p->rot.b.z; if (zp) *zp = vx * p->rot.c.x + vy * p->rot.c.y + vz * p->rot.c.z; } } // (z3dSpot 'varX 'varY 'dx 'dy 'dz) void z3dSpot(double *xp, double *yp, double dx, double dy, double dz) { double d = sqrt(dx*dx + dy*dy + dz*dz); *xp = atan2(dy,dx); *yp = d < 1.0/SCL? 0.0 : asin(dz/d); } // (z3dWindow 'ttl 'dx 'dy) -> str char *z3dWindow(char *ttl, int dx, int dy) { XPixmapFormatValues *pmFormat; int n, i; if ((Disp = XOpenDisplay(NULL)) == NULL) return "Can't open Display"; Scrn = DefaultScreen(Disp); Cmap = DefaultColormap(Disp,Scrn); Dpth = PixSize = 0; pmFormat = XListPixmapFormats(Disp, &n); for (i = 0; i < n; i++) { if (pmFormat[i].depth == 24) { Dpth = 24; if (PixSize != 4) PixSize = (pmFormat[i].bits_per_pixel + 7) / 8 & ~8; } else if (pmFormat[i].depth == 16 && (PixSize < 3 || PixSize > 4)) { Dpth = 16; PixSize = (pmFormat[i].bits_per_pixel + 7) / 8 & ~8; } else if (pmFormat[i].depth == 8 && (PixSize < 2 || PixSize > 4)) { Dpth = 8; PixSize = (pmFormat[i].bits_per_pixel + 7) / 8 & ~8; } } if (!Dpth) return "Bad Display Depth"; Gc = XCreateGC(Disp,RootWindow(Disp,Scrn), 0, NULL); OrgX = (SizX = dx) / 2; OrgY = (SizY = dy) / 2; /* Create Window */ Win = XCreateSimpleWindow(Disp, RootWindow(Disp,Scrn), 0, 0, SizX, SizY, 1, BlackPixel(Disp,Scrn), WhitePixel(Disp,Scrn) ); XStoreName(Disp, Win, ttl); XMapWindow(Disp, Win); /* Create Image */ SizX = SizX + 3 & ~3; SizY = SizY + 3 & ~3; if ((Zbuff = malloc(SizX * SizY * sizeof(unsigned))) == NULL || (Edges = malloc(SizY * sizeof(edge))) == NULL ) return "No memory"; if (!XShmQueryExtension(Disp) || !(Img = XShmCreateImage(Disp, DefaultVisual(Disp, Scrn), Dpth, ZPixmap, NULL, &Info, SizX, SizY )) || (Info.shmid = shmget(IPC_PRIVATE, SizX * SizY * PixSize, IPC_CREAT | 0777 )) < 0 || (Info.shmaddr = Img->data = shmat(Info.shmid, 0, 0) ) == (char*)-1 || !XShmAttach(Disp, &Info) ) return "Can't create XImage"; return NULL; } // (z3dCamera 'foc 'yaw 'pitch 'x 'y 'z 'sky 'gnd ['h 'v]) void z3dCamera(double foc, double yaw, double pitch, double x, double y, double z, int sky, int gnd) { double a, sinY, cosY, sinP, cosP; int i, v, hor, pix; char *frame; FocLen = foc; sinY = sin(yaw), cosY = cos(yaw); sinP = sin(pitch), cosP = cos(pitch); Coeff1 = -sinY; Coeff2 = cosY; Coeff4 = cosY * sinP; Coeff5 = sinY * sinP; Coeff6 = -cosP; Coeff7 = cosY * cosP; Coeff8 = sinY * cosP; Coeff9 = sinP; PosX = x; PosY = y; PosZ = z; Pos6 = Coeff6 * PosZ; Pos9 = Coeff9 * PosZ; if (cosP > - 1.0/SCL && cosP < 1.0/SCL) hor = sinP > 0.0? +16383 : -16384; else if ((a = FocLen * sinP/cosP) > +16383.0) hor = +16383; else if (a < -16384.0) hor = -16384; else hor = (int)a; for (v = 0; v < SizY; ++v) { pix = v < hor? sky : gnd; frame = Img->data + v * SizX * PixSize; switch (PixSize) { case 1: memset(frame, pix, SizX); break; case 2: pix |= pix<<16; i = 0; do *(int*)frame = pix, frame += 4; while ((i+=2) < SizX); break; case 3: i = 0; do { frame[0] = pix; frame[1] = (pix >> 8); frame[2] = (pix >> 16); frame += 3; } while (++i < SizX); break; case 4: i = 0; do *(int*)frame = pix, frame += 4; while (++i < SizX); break; } } memset(Zbuff, 0xFF, SizX * SizY * sizeof(unsigned)); } static void rotate(vector *src, matrix *p, vector *dst) { dst->x = src->x * p->a.x + src->y * p->b.x + src->z * p->c.x; dst->y = src->x * p->a.y + src->y * p->b.y + src->z * p->c.y; dst->z = src->x * p->a.z + src->y * p->b.z + src->z * p->c.z; } static void shadowPt(double vx, double vy, int *xp, int *yp, int *zp) { double z; z = Coeff7 * vx + Coeff8 * vy - Pos9; *xp = (int)(FocLen * (Coeff1 * vx + Coeff2 * vy) / z); *yp = (int)(FocLen * (Coeff4 * vx + Coeff5 * vy - Pos6) / z); *zp = (int)(1000.0 * z); } static void transPt(double vx, double vy, double vz, int *xp, int *yp, int *zp) { double z; z = Coeff7 * vx + Coeff8 * vy + Coeff9 * vz; *xp = (int)(FocLen * (Coeff1 * vx + Coeff2 * vy) / z); *yp = (int)(FocLen * (Coeff4 * vx + Coeff5 * vy + Coeff6 * vz) / z); *zp = (int)(1000.0 * z); } static int getColor(int c) { XColor col; col.red = c >> 8 & 0xFF00; col.green = c & 0xFF00; col.blue = (c & 0xFF) << 8; col.flags = DoRed | DoGreen | DoBlue; XAllocColor(Disp, Cmap, &col); return col.pixel; } static void mkEdge(int x1, int y1, int z1, int x2, int y2, int z2) { int a, dx, dy, dz, sx, xd, xe, sz, zd, ze; edge *p; if (y2 < y1) { a = x1, x1 = x2, x2 = a; a = y1, y1 = y2, y2 = a; a = z1, z1 = z2, z2 = a; } if (y1 > OrgY || ((y2 += OrgY) <= 0)) return; if ((dy = y2 - (y1 += OrgY)) == 0) return; dx = x2 - x1, dz = z2 - z1; if (y1 < 0) { x1 += -y1 * dx / dy; z1 += -y1 * dz / dy; y1 = 0; if ((dy = y2) == 0) return; dx = x2 - x1, dz = z2 - z1; } if (y2 > SizY) { x2 += (SizY - y2) * dx / dy; z2 += (SizY - y2) * dz / dy; y2 = SizY; if ((dy = y2 - y1) == 0) return; dx = x2 - x1, dz = z2 - z1; } sx = 0; if (dx > 0) sx = 1; else if (dx < 0) dx = -dx, sx = -1; xd = 0; if (dx > dy) xd = dx/dy, dx -= xd*dy, xd *= sx; xe = (dx *= 2) - dy; sz = 0; if (dz > 0) sz = 1; else if (dz < 0) dz = -dz, sz = -1; zd = 0; if (dz > dy) zd = dz/dy, dz -= zd*dy, zd *= sz; ze = (dz *= 2) - dy; dy *= 2; x1 += OrgX; p = Edges + y1; do { if ((a = x1) < 0) a = 0; else if (a > SizX) a = SizX; if (a < p->h[1]) { p->h[0] = a; p->z[0] = z1; } else { p->h[0] = p->h[1]; p->z[0] = p->z[1]; p->h[1] = a; p->z[1] = z1; } ++p; x1 += xd; if (xe >= 0) x1 += sx, xe -= dy; xe += dx; z1 += zd; if (ze >= 0) z1 += sz, ze -= dy; ze += dz; } while (++y1 < y2); } static void zDots(int i, int h, int h2, unsigned z, unsigned z2) { char *frame; unsigned *zbuff; i = i * SizX + h; frame = Img->data + i * PixSize; zbuff = Zbuff + i; i = h2 - h; switch (PixSize) { case 1: if (z < *zbuff) *zbuff = z, *frame = 0; if (z2 < *(zbuff += i)) *zbuff = z2, *(frame + i) = 0; break; case 2: if (z < *zbuff) *zbuff = z, *(short*)frame = (short)0; if (z2 < *(zbuff += i)) *zbuff = z2, *(short*)(frame + 2 * i) = (short)0; break; case 3: if (z < *zbuff) { *zbuff = z; frame[0] = 0; frame[1] = 0; frame[2] = 0; } if (z2 < *(zbuff += i)) { *zbuff = z2; frame += 3 * i; frame[0] = 0; frame[1] = 0; frame[2] = 0; } break; case 4: if (z < *zbuff) *zbuff = z, *(int*)frame = 0; if (z2 < *(zbuff += i)) *zbuff = z2, *(int*)(frame + 4 * i) = 0; break; } } static void zLine(int pix, int v, int h, int h2, unsigned z, unsigned z2) { char *frame; unsigned *zbuff; int d, e, dh, dz, sz; if (dh = h2 - h) { v = v * SizX + h; frame = Img->data + v * PixSize; zbuff = Zbuff + v; sz = 0; if ((dz = z2 - z) > 0) sz = 1; else if (dz < 0) dz = -dz, sz = -1; d = 0; if (dz > dh) d = dz/dh, dz -= d*dh, d *= sz; e = (dz *= 2) - dh; dh *= 2; switch (PixSize) { case 1: do { if (z < *zbuff) *zbuff = z, *frame = pix; z += d; if (e >= 0) z += sz, e -= dh; ++zbuff, ++frame; e += dz; } while (++h < h2); break; case 2: do { if (z < *zbuff) *zbuff = z, *(short*)frame = (short)pix; z += d; if (e >= 0) z += sz, e -= dh; ++zbuff, frame += 2; e += dz; } while (++h < h2); break; case 3: do { if (z < *zbuff) { *zbuff = z; frame[0] = pix; frame[1] = (pix >> 8); frame[2] = (pix >> 16); } z += d; if (e >= 0) z += sz, e -= dh; ++zbuff, frame += 3; e += dz; } while (++h < h2); break; case 4: do { if (z < *zbuff) *zbuff = z, *(int*)frame = pix; z += d; if (e >= 0) z += sz, e -= dh; ++zbuff, frame += 4; e += dz; } while (++h < h2); break; } } } static void doDraw(model *p, matrix *r, double x, double y, double z) { int i, n, pix, x0, y0, z0, x1, y1, z1, x2, y2, z2; double dx, dy, dz; vector pos, pt1, pt2, pt3, v, w, nv; matrix rot; void **q; edge *e; pos = p->pos; rot = p->rot; if (!r) r = &rot; else { v = pos, rotate(&v, r, &pos); pos.x += x, pos.y += y, pos.z += z; v = rot.a, rotate(&v, r, &rot.a); v = rot.b, rotate(&v, r, &rot.b); v = rot.c, rotate(&v, r, &rot.c); } dx = pos.x - PosX; dy = pos.y - PosY; dz = pos.z - PosZ; /* Rough clipping */ if ((z = Coeff7*dx + Coeff8*dy + Coeff9*dz) < 0.1) return; if (z < fabs(Coeff1*dx + Coeff2*dy)) return; if (z < fabs(Coeff4*dx + Coeff5*dy + Coeff6*dz)) return; /* Faces */ for (q = p->lst; *(face**)q; ++q) { face *f = *(face**)q; if ((f->pt[0].x || f->pt[0].y || f->pt[0].z) && (f->pt[1].x || f->pt[1].y || f->pt[1].z)) r = &rot, rotate(f->pt, r, &pt1), rotate(f->pt + 1, r, &pt2); else rotate(f->pt, r, &pt1), rotate(f->pt + 1, r, &pt2), r = &rot; rotate(f->pt + 2, r, &pt3); memset(Edges, 0, SizY * sizeof(edge)); if (f->col2 == 0x2000000) { shadowPt(pt1.x + dx + pt1.z + pos.z, pt1.y + dy, &x0, &y0, &z0); shadowPt(pt2.x + dx + pt2.z + pos.z, pt2.y + dy, &x1, &y1, &z1); mkEdge(x0, y0, z0, x1, y1, z1); for (i = 2;;) { shadowPt(pt3.x + dx + pt3.z + pos.z, pt3.y + dy, &x2, &y2, &z2); mkEdge(x1, y1, z1, x2, y2, z2); if (++i == f->cnt) break; rotate(f->pt + i, r, &pt3); x1 = x2, y1 = y2, z1 = z2; } mkEdge(x2, y2, z2, x0, y0, z0); i = 0, e = Edges; pix = getColor(0); // Face color black do if (e->h[1]) zLine(pix, i, e->h[0], e->h[1], e->z[0], e->z[1]); while (++e, ++i < SizY); } else { v.x = pt1.x - pt2.x; v.y = pt1.y - pt2.y; v.z = pt1.z - pt2.z; w.x = pt3.x - pt2.x; w.y = pt3.y - pt2.y; w.z = pt3.z - pt2.z; nv.x = v.y * w.z - v.z * w.y; nv.y = v.z * w.x - v.x * w.z; nv.z = v.x * w.y - v.y * w.x; pt1.x += dx, pt1.y += dy, pt1.z += dz; if (f->col1 == 0x1000000 && f->col2 == 0x1000000) pix = -1; // Transparent else { if (pt1.x * nv.x + pt1.y * nv.y + pt1.z * nv.z >= 0.0) { if (f->col1 == 0x1000000) continue; // Backface culling pix = f->col1; n = 80 - (int)(14.14 * (nv.z-nv.x) / sqrt(nv.x*nv.x + nv.y*nv.y + nv.z*nv.z)); } else { if (f->col2 == 0x1000000) continue; // Backface culling pix = f->col2; n = 80 + (int)(14.14 * (nv.z-nv.x) / sqrt(nv.x*nv.x + nv.y*nv.y + nv.z*nv.z)); } pix = ((pix >> 16) & 255) * n / 100 << 16 | ((pix >> 8) & 255) * n / 100 << 8 | (pix & 255) * n / 100; } transPt(pt1.x, pt1.y, pt1.z, &x0, &y0, &z0); transPt(pt2.x + dx, pt2.y + dy, pt2.z + dz, &x1, &y1, &z1); mkEdge(x0, y0, z0, x1, y1, z1); for (i = 2;;) { transPt(pt3.x + dx, pt3.y + dy, pt3.z + dz, &x2, &y2, &z2); mkEdge(x1, y1, z1, x2, y2, z2); if (++i == f->cnt) break; rotate(f->pt + i, r, &pt3); x1 = x2, y1 = y2, z1 = z2; } mkEdge(x2, y2, z2, x0, y0, z0); i = 0, e = Edges; if (pix < 0) { do // Transparent if (e->h[1]) zDots(i, e->h[0], e->h[1], e->z[0], e->z[1]); while (++e, ++i < SizY); } else { pix = getColor(pix); // Face color do if (e->h[1]) zLine(pix, i, e->h[0], e->h[1], e->z[0], e->z[1]); while (++e, ++i < SizY); } } } /* Submodels */ while (*(model**)++q) doDraw(*(model**)q, &rot, pos.x, pos.y, pos.z); } // (z3dDraw ['model]) void z3dDraw(model *p) { doDraw(p, NULL, 0.0, 0.0, 0.0); } // (z3dPut) void z3dPut(void) { XShmPutImage(Disp, Win, Gc, Img, 0, 0, 0, 0, SizX, SizY, False); } // (z3dText 'x 'y 'str) void z3dText(int x, int y, char *str) { XDrawString(Disp, Win, Gc, x, y, str, strlen(str)); } // (z3dSync) void z3dSync(void) { XSync(Disp,False); } /**/ # vi:et:ts=3:sw=3 ����picolisp-3.1.5.2.orig/lib/zahlwort.l����������������������������������������������������������������0000644�0000000�0000000�00000002603�12265263724�015746� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 26may06abu # (c) Software Lab. Alexander Burger (de zahlwort (N) (cond ((not N)) ((=0 N) "null") ((lt0 N) (pack "minus " (zahlw (- N)))) (T (zahlw N)) ) ) (de zahlw (N Flg) (cond ((=0 N)) ((= 1 N) (if Flg "ein" "eins")) ((= 2 N) "zwei") ((= 3 N) "drei") ((= 4 N) "vier") ((= 5 N) "fünf") ((= 6 N) "sechs") ((= 7 N) "sieben") ((= 8 N) "acht") ((= 9 N) "neun") ((= 10 N) "zehn") ((= 11 N) "elf") ((= 12 N) "zwölf") ((= 17 N) "siebzehn") ((> 20 N) (pack (zahlw (% N 10) T) "zehn") ) ((> 100 N) (pack (unless (=0 (% N 10)) (pack (zahlw (% N 10) T) "und") ) (get (quote "zehn" "zwanzig" "dreissig" "vierzig" "fünfzig" "sechzig" "siebzig" "achtzig" "neunzig" ) (/ N 10) ) ) ) ((> 1000 N) (pack (zahlw (/ N 100) T) "hundert" (zahlw (% N 100)) ) ) ((> 1000000 N) (pack (zahlw (/ N 1000) T) "tausend" (zahlw (% N 1000)) ) ) ((> 2000000 N) (pack "einemillion" (zahlw (% N 1000000))) ) ((> 1000000000000 N) (pack (zahlw (/ N 1000000) T) "millionen" (zahlw (% N 1000000)) ) ) (T "RIESIG") ) ) �����������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/adm.l���������������������������������������������������������������������0000644�0000000�0000000�00000005721�12265263724�014641� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 26dec13abu # (c) Software Lab. Alexander Burger # *Salt *Login *Users *Perms # crypt(3) algorithm, e.g. (setq *Salt (16 . "$6$@1$")) (de passwd (Str Salt) (if *Salt `(if (== 64 64) '(native "libcrypt.so" "crypt" 'S Str (or Salt (salt))) '(ext:Crypt Str (or Salt (salt))) ) Str ) ) (de salt () (text (cdr *Salt) (randpw (car *Salt))) ) (de randpw (Len) (make (in "/dev/urandom" (do Len (link (get '`(mapcar char (conc (range (char ".") (char "9")) (range (char "A") (char "Z")) (range (char "a") (char "z")) ) ) (inc (& 63 (rd 1))) ) ) ) ) ) ) (de auth (Nm Pw Cls) (with (db 'nm (or Cls '+User) Nm) (and (: pw 0) (= @ (passwd Pw @)) This ) ) ) ### Login ### (de login (Nm Pw Cls) (ifn (setq *Login (auth Nm Pw Cls)) (msg *Pid " ? " Nm) (msg *Pid " * " (stamp) " " Nm) (tell 'hi *Pid Nm *Adr) (push1 '*Bye '(logout)) (push1 '*Fork '(del '(logout) '*Bye)) (timeout (setq *Timeout `(* 3600 1000))) ) *Login ) (de logout () (when *Login (rollback) (off *Login) (tell 'hi *Pid) (msg *Pid " / " (stamp)) (timeout (setq *Timeout `(* 300 1000))) ) ) (de hi (Pid Nm Adr) (if (and Nm (= Nm (; *Login nm)) (= Adr *Adr)) (bye) (hi2 Pid Nm) (tell 'hi2 *Pid (; *Login nm)) ) ) (de hi2 (Pid Nm) (if2 Nm (lup *Users Pid) (con @ Nm) (idx '*Users (cons Pid Nm) T) (idx '*Users @ NIL) ) ) ### Role ### (class +Role +Entity) (rel nm (+Need +Key +String)) # Role name (rel perm (+List +Symbol)) # Permission list (rel usr (+List +Joint) role (+User)) # Associated users ### User ### (class +User +Entity) (rel nm (+Need +Key +String)) # User name (rel pw (+Swap +String)) # Password (rel role (+Joint) usr (+Role)) # User role ### Permission management ### (de permission Lst (while Lst (queue '*Perms (car Lst)) (def (pop 'Lst) (pop 'Lst)) ) ) (de may Args (mmeq Args (; *Login role perm)) ) (de must Args (unless (if (cdr Args) (mmeq @ (; *Login role perm)) *Login ) (msg *Pid " No permission: " (car Args)) (forbidden) ) ) ### GUI ### (de loginForm "Opt" (form NIL (htPrin "Opt") (<grid> 2 ,"Name" (gui 'nm '(+Focus +Able +TextField) '(not *Login) 20) ,"Password" (gui 'pw '(+Able +PwField) '(not *Login) 20) ) (--) (gui '(+Button) '(if *Login ,"logout" ,"login") '(cond (*Login (logout)) ((login (val> (: home nm)) (val> (: home pw))) (clr> (: home pw)) ) (T (error ,"Permission denied")) ) ) (when *Login (<nbsp> 4) (<span> "bold green" (ht:Prin "'" (; *Login nm) ,"' logged in") ) ) ) ) # vi:et:ts=3:sw=3 �����������������������������������������������picolisp-3.1.5.2.orig/lib/app.l���������������������������������������������������������������������0000644�0000000�0000000�00000001625�12265263724�014657� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 16nov12abu # (c) Software Lab. Alexander Burger # Exit on error (de *Err (and trail (println (trail T))) (prinl *Pid " ! " (stamp) " [" *Adr " " (host *Adr) "] " *Agent) (show This) (for "X" '(*Gate *Agent *Host *Port *PRG *Url *SesId *ConId *Tab *Gui *Btn *Get *ID) (println "X" (val "X")) ) (for "X" (env) (unless (== (car "X") (cdr "X")) (println (car "X") (cdr "X")) ) ) (rollback) ) # User identification (de user (Pid1 Pid2 Nm To) (nond (Pid1 (tell 'user *Pid)) (Pid2 (tell 'user Pid1 *Pid (get *Login 'nm) (/ (- *Timeout (cadr (assoc -1 *Run))) 60000) ) ) ((<> *Pid Pid1) (println Pid2 Nm To)) ) ) # Timestamp (msg *Pid " + " (stamp)) (flush) # Extend 'app' function (conc (last app) '((msg *Pid " + " (stamp) " [" *Adr " " (host *Adr) "] " *Agent)) ) # Bye message (push1 '*Bye '(and *SesId (msg *Pid " - " (stamp)))) �����������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/bash_completion�����������������������������������������������������������0000644�0000000�0000000�00000001010�12265263724�016777� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Bash completion for picolisp + pil # Alexander Burger <abu@software-lab.de> have pil && _pil() { local -a ARGS local IFS=$'\n' for A in "${COMP_WORDS[@]:1:$((COMP_CWORD-1))}" do test "${A:0:1}" = "-" || ARGS[${#ARGS[@]}]="${A//\\ / }" done COMPREPLY=($(${COMP_WORDS[0]} ${ARGS[@]} /usr/lib/picolisp/lib/complete.l "${COMP_WORDS[$COMP_CWORD]}" -bye + 2>&1)) return 0 } && complete -o nospace -F _pil picolisp && complete -o nospace -F _pil pil # ex: ts=4 sw=4 et filetype=sh ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/boss.l��������������������������������������������������������������������0000644�0000000�0000000�00000000500�12265263724�015034� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 04oct11abu # (c) Software Lab. Alexander Burger # "boss" *Boss (unless (info (tmp "+")) (call 'mkfifo (setq "boss" (tmp "+"))) (call 'mkfifo (setq *Boss (tmp "-"))) ) (hear (open "boss")) # (boss 'sym ['any ..]) (de boss @ (out "boss" (pr (rest))) ) (de reply Exe #> any (out *Boss (pr (eval Exe))) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/btree.l�������������������������������������������������������������������0000644�0000000�0000000�00000037715�12265263724�015211� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 23nov13abu # (c) Software Lab. Alexander Burger # *Prune (de root (Tree) (cond ((not Tree) (val *DB)) ((atom Tree) (val Tree)) ((ext? (cdr Tree)) (get @ (car Tree))) ((atom (cdr Tree)) (get *DB (cdr Tree) (car Tree)) ) (T (get (cddr Tree) (cadr Tree) (car Tree))) ) ) # Fetch (de fetch (Tree Key) (let? Node (cdr (root Tree)) (and *Prune (idx '*Prune Node T)) (use R (loop (and *Prune (set (prop Node NIL) 0)) (T (and (setq R (rank Key (cdr (val Node)))) (= Key (car R)) ) (or (cddr R) (fin (car R))) ) (NIL (setq Node (if R (cadr R) (car (val Node)))) ) ) ) ) ) # Store (de store (Tree Key Val Dbf) (default Dbf (1 . 256)) (if (atom Tree) (let Base (or Tree *DB) (_store (or (val Base) (set Base (cons 0)))) ) (let Base (if (atom (cdr Tree)) (or (ext? (cdr Tree)) (get *DB (cdr Tree)) (put *DB (cdr Tree) (new T)) ) (or (get (cddr Tree) (cadr Tree)) (put (cddr Tree) (cadr Tree) (new T)) ) ) (_store (or (get Base (car Tree)) (put Base (car Tree) (cons 0)) ) ) ) ) ) (de _store (Root) (and *Prune (cdr Root) (idx '*Prune @ T)) (ifn Val (when (and (cdr Root) (_del @)) (touch Base) (cond (*Solo (zap (cdr Root))) (*Zap (push @ (cdr Root))) ) (con Root) ) (and (= Val (fin Key)) (off Val)) (if (cdr Root) (when (_put @) (touch Base) (con Root (def (new (car Dbf)) (list (car @) (cdr @)))) ) (touch Base) (con Root (def (new (car Dbf)) (list NIL (cons Key NIL Val)) ) ) (and *Prune (set (prop (cdr Root) NIL) 0)) (inc Root) ) ) ) (de _put (Top) (and *Prune (set (prop Top NIL) 0)) (let (V (val Top) R (rank Key (cdr V))) (cond (R (if (= Key (car R)) (nil (touch Top) (con (cdr R) Val)) (let X (memq R V) (if (cadr R) (when (_put @) (touch Top) (set (cdr R) (car @)) (con X (cons (cdr @) (cdr X))) (_splitBt) ) (touch Top) (con X (cons (cons Key (cons NIL Val)) (cdr X)) ) (touch Base) (inc Root) (_splitBt) ) ) ) ) ((car V) (when (_put @) (touch Top) (set V (car @)) (con V (cons (cdr @) (cdr V))) (_splitBt) ) ) (T (touch Top) (con V (cons (cons Key (cons NIL Val)) (cdr V)) ) (touch Base) (inc Root) (_splitBt) ) ) ) ) (de _splitBt () (when (and (cddddr V) (> (size Top) (cdr Dbf))) (let (N (>> 1 (length V)) X (get V (inc N))) (set (cdr X) (def (new (car Dbf)) (cons (cadr X) (nth V (+ 2 N))) ) ) (cons (if *Solo (prog (set Top (head N V)) Top) (and *Zap (push @ Top)) (def (new (car Dbf)) (head N V)) ) X ) ) ) ) # Del (de _del (Top) (and *Prune (set (prop Top NIL) 0)) (let (V (val Top) R (rank Key (cdr V))) (cond ((not R) (when (and (car V) (_del @)) (touch Top) (cond (*Solo (zap (car V))) (*Zap (push @ (car V))) ) (set V) (not (cdr V)) ) ) ((= Key (car R)) (if (cadr R) (let X (val @) (while (car X) (setq X (val @))) (touch Top) (xchg R (cadr X)) (con (cdr R) (cddr (cadr X))) (when (_del (cadr R)) (cond (*Solo (zap (cadr R))) (*Zap (push @ (cadr R))) ) (set (cdr R)) ) ) (touch Base) (dec Root) (nand (or (con V (delq R (cdr V))) (car V) ) (touch Top) ) ) ) ((cadr R) (when (_del @) (touch Top) (cond (*Solo (zap (cadr R))) (*Zap (push @ (cadr R))) ) (set (cdr R)) ) ) ) ) ) # Delayed deletion (de zap_ () (let (F (cdr *Zap) Z (pack F "_")) (cond ((info Z) (in Z (while (rd) (zap @))) (if (info F) (call 'mv F Z) (call 'rm Z) ) ) ((info F) (call 'mv F Z)) ) ) ) # Tree node count (de count (Tree) (or (car (root Tree)) 0) ) # Return first leaf (de leaf (Tree) (let (Node (cdr (root Tree)) X) (while (val Node) (setq X (cadr @) Node (car @)) ) (cddr X) ) ) # Reverse node (de revNode (Node) (let? Lst (val Node) (let (L (car Lst) R) (for X (cdr Lst) (push 'R (cons (car X) L (cddr X))) (setq L (cadr X)) ) (cons L R) ) ) ) # Key management (de minKey (Tree Min Max) (default Max T) (let (Node (cdr (root Tree)) K) (use (V R X) (loop (NIL (setq V (val Node)) K) (T (and (setq R (rank Min (cdr V))) (= Min (car R)) ) Min ) (if R (prog (and (setq X (cdr (memq R V))) (>= Max (caar X)) (setq K (caar X)) ) (setq Node (cadr R)) ) (when (>= Max (caadr V)) (setq K (caadr V)) ) (setq Node (car V)) ) ) ) ) ) (de maxKey (Tree Min Max) (default Max T) (let (Node (cdr (root Tree)) K) (use (V R X) (loop (NIL (setq V (revNode Node)) K) (T (and (setq R (rank Max (cdr V) T)) (= Max (car R)) ) Max ) (if R (prog (and (setq X (cdr (memq R V))) (>= (caar X) Min) (setq K (caar X)) ) (setq Node (cadr R)) ) (when (>= (caadr V) Min) (setq K (caadr V)) ) (setq Node (car V)) ) ) ) ) ) # Step (de init (Tree Beg End) (or Beg End (on End)) (let (Node (cdr (root Tree)) Q) (use (V R X) (if (>= End Beg) (loop (NIL (setq V (val Node))) (T (and (setq R (rank Beg (cdr V))) (= Beg (car R)) ) (push 'Q (memq R V)) ) (if R (prog (and (setq X (cdr (memq R V))) (>= End (caar X)) (push 'Q X) ) (setq Node (cadr R)) ) (and (cdr V) (>= End (caadr V)) (push 'Q (cdr V)) ) (setq Node (car V)) ) ) (loop (NIL (setq V (revNode Node))) (T (and (setq R (rank Beg (cdr V) T)) (= Beg (car R)) ) (push 'Q (memq R V)) ) (if R (prog (and (setq X (cdr (memq R V))) (>= (caar X) End) (push 'Q X) ) (setq Node (cadr R)) ) (and (cdr V) (>= (caadr V) End) (push 'Q (cdr V)) ) (setq Node (car V)) ) ) ) ) (cons (cons (cons Beg End) Q)) ) ) (de step (Q Flg) (use (L F X) (catch NIL (loop (until (cdar Q) (or (cdr Q) (throw)) (set Q (cadr Q)) (con Q (cddr Q)) ) (setq L (car Q) F (>= (cdar L) (caar L)) X (pop (cdr L)) ) (or (cadr L) (con L (cddr L))) (if ((if F > <) (car X) (cdar L)) (con (car Q)) (for (V (cadr X) ((if F val revNode) V) (car @)) (con L (cons (cdr @) (cdr L))) ) (unless (and Flg (flg? (fin (car X)))) (throw NIL (or (cddr X) (fin (car X))) ) ) ) ) ) ) ) (====) # Scan tree nodes (de scan ("Tree" "Fun" "Beg" "End" "Flg") (default "Fun" println) (or "Beg" "End" (on "End")) (let "Node" (cdr (root "Tree")) ((if (>= "End" "Beg") _scan _nacs) "Node") ) ) (de _scan ("Node") (let? "V" (val "Node") (for "X" (if (rank "Beg" (cdr "V")) (let "R" @ (if (= "Beg" (car "R")) (memq "R" (cdr "V")) (_scan (cadr "R")) (cdr (memq "R" (cdr "V"))) ) ) (_scan (car "V")) (cdr "V") ) (T (> (car "X") "End")) (unless (and "Flg" (flg? (fin (car "X")))) ("Fun" (car "X") (or (cddr "X") (fin (car "X"))) ) ) (_scan (cadr "X")) ) ) ) (de _nacs ("Node") (let? "V" (revNode "Node") (for "X" (if (rank "Beg" (cdr "V") T) (let "R" @ (if (= "Beg" (car "R")) (memq "R" (cdr "V")) (_nacs (cadr "R")) (cdr (memq "R" (cdr "V"))) ) ) (_nacs (car "V")) (cdr "V") ) (T (> "End" (car "X"))) (unless (and "Flg" (flg? (fin (car "X")))) ("Fun" (car "X") (or (cddr "X") (fin (car "X"))) ) ) (_nacs (cadr "X")) ) ) ) (====) # Iterate tree values (de iter ("Tree" "Fun" "Beg" "End" "Flg") (default "Fun" println) (or "Beg" "End" (on "End")) (let "Node" (cdr (root "Tree")) ((if (>= "End" "Beg") _iter _reti) "Node") ) ) (de _iter ("Node") (let? "V" (val "Node") (for "X" (if (rank "Beg" (cdr "V")) (let "R" @ (if (= "Beg" (car "R")) (memq "R" (cdr "V")) (_iter (cadr "R")) (cdr (memq "R" (cdr "V"))) ) ) (_iter (car "V")) (cdr "V") ) (T (> (car "X") "End")) (unless (and "Flg" (flg? (fin (car "X")))) ("Fun" (or (cddr "X") (fin (car "X")))) ) (_iter (cadr "X")) ) ) ) (de _reti ("Node") (let? "V" (revNode "Node") (for "X" (if (rank "Beg" (cdr "V") T) (let "R" @ (if (= "Beg" (car "R")) (memq "R" (cdr "V")) (_reti (cadr "R")) (cdr (memq "R" (cdr "V"))) ) ) (_reti (car "V")) (cdr "V") ) (T (> "End" (car "X"))) (unless (and "Flg" (flg? (fin (car "X")))) ("Fun" (or (cddr "X") (fin (car "X")))) ) (_reti (cadr "X")) ) ) ) # UB-Trees (de ub>= (Dim End Val Beg) (let (D (>> (- 1 Dim) 1) Pat D) (while (> End Pat) (setq Pat (| D (>> (- Dim) Pat))) ) (do Dim (NIL (>= (& Pat End) (& Pat Val) (& Pat Beg) ) ) (setq Pat (>> 1 Pat)) ) ) ) (de ubIter ("Tree" "Dim" "Fun" "X1" "X2") (let ("Node" (cdr (root "Tree")) "Lst" (val "Node") "Left" (pop '"Lst") "Beg" (ubZval (copy "X1")) "End" (ubZval (copy "X2") T) "B" (car "Beg") "E" (car "End") ) (recur ("Left" "Lst" "Beg" "End" "X") (while (setq "X" (pop '"Lst")) (cond ((> (car "X") "End") (setq "Lst" (; "Left" 0 -1) "Left" (; "Left" 0 1)) ) ((> "Beg" (car "X")) (if "Lst" (setq "Left" (cadr "X")) (setq "Left" (; "X" 2 0 1) "Lst" (; "X" 2 0 -1)) ) ) ((ub>= "Dim" "E" (caar "X") "B") ("Fun" (cdar "X")) (recurse (; "Left" 0 1) (; "Left" 0 -1) "Beg" (car "X")) (setq "Beg" (car "X")) (if "Lst" (setq "Left" (cadr "X")) (setq "Left" (; "X" 2 0 1) "Lst" (; "X" 2 0 -1)) ) ) (T (let ("Msb" 1 "Pat" 0 "N" 0 "Min" "B" "Max" "E" "Lo" (caar "X") "Hi" "Lo") (while (>= "Max" "Msb") (setq "Msb" (>> -1 "Msb") "Pat" (>> -1 "Pat")) # Msb 100000000 (when (= "Dim" (inc '"N")) # Pat 000100100 (inc '"Pat") (zero "N") ) ) (catch "ub" # Clr 111..111011011 (let (Top "Msb" Clr (| Top (x| "Pat" (dec "Msb")))) (loop (T (=0 (setq "Msb" (>> 1 "Msb")))) (setq "Pat" (>> 1 "Pat") Clr (| Top (>> 1 Clr)) ) (ifn (bit? "Msb" (caar "X")) (when (bit? "Msb" "Max") (ifn (bit? "Msb" "Min") # 001 (setq "Max" (- (| "Pat" "Max") "Msb") # 0111(Max) "Lo" (| "Msb" (& "Min" Clr)) ) # 1000(Min) (setq "Lo" "Min") # 011 (throw "ub") ) ) (unless (bit? "Msb" "Min") (if (bit? "Msb" "Max") # 101 (setq "Hi" (- (| "Pat" "Max") "Msb") # 0111(Max) "Min" (| "Msb" (& "Min" Clr)) ) # 1000(Min) (setq "Hi" "Max") # 100 (throw "ub") ) ) ) ) ) ) (recurse (; "Left" 0 1) (; "Left" 0 -1) "Beg" (cons "Hi" T)) (setq "Beg" (cons "Lo")) (if "Lst" (setq "Left" (cadr "X")) (setq "Left" (; "X" 2 0 1) "Lst" (; "X" 2 0 -1)) ) ) ) ) ) ) ) ) (====) (de prune (N) (for Node (idx '*Prune) (recur (Node) (let? V (val (lieu Node)) (if (>= (inc (prop Node NIL)) N) (wipe Node) (recurse (car V)) (for X (cdr V) (recurse (cadr X)) ) ) ) ) ) (or (gt0 N) (setq *Prune N)) ) # Delete Tree (de zapTree (Node) (let? V (val Node) (zapTree (car V)) (for L (cdr V) (zapTree (cadr L)) ) (zap Node) ) ) # Check tree structure (de chkTree ("Node" "Fun") (let ("N" 0 "X") (when "Node" (recur ("Node") (let "V" (val "Node") (let "L" (car "V") (for "Y" (cdr "V") (when "L" (unless (ext? "L") (quit "Bad node link" "Node") ) (recurse "L") ) (when (>= "X" (car "Y")) (quit "Bad sequence" "Node") ) (setq "X" (car "Y")) (inc '"N") (and "Fun" (not ("Fun" (car "Y") (cddr "Y"))) (quit "Check fail" "Node") ) (setq "L" (cadr "Y")) ) (and "L" (recurse "L")) ) ) (wipe "Node") ) ) "N" ) ) # vi:et:ts=3:sw=3 ���������������������������������������������������picolisp-3.1.5.2.orig/lib/cal.l���������������������������������������������������������������������0000644�0000000�0000000�00000004625�12265263724�014641� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 01dec10abu # (c) Software Lab. Alexander Burger # Easter date algorithm from J.M. Oudin (1940) (de easter (Year) (let (C (/ Year 100) N (% Year 19) # Metonic cycle I (% (+ (- C (/ C 4) (/ (- C (/ (- C 17) 25)) 3)) (* 19 N) 15 ) 30 ) ) (dec 'I (* (/ I 28) (- 1 (* (/ I 28) (/ 29 (inc I)) (/ (- 21 N) 11))))) (let (L (- I (% (+ Year (/ Year 4) I 2 (- C) (/ C 4)) 7)) Mon (+ 3 (/ (+ L 40) 44)) ) (date Year Mon (+ L 28 (* (/ Mon 4) -31))) ) ) ) # Feiertage (de feier (X Year) (if (sym? X) (case X (Neujahr (date Year 1 1) ) ((Maifeiertag "1. Mai" "Tag der Arbeit") (date Year 5 1) ) (("Tag der deutschen Einheit" "Deutsche Einheit") (date Year 10 3) ) ((Weihnachten "1. Weihnachtstag") (date Year 12 25) ) ("2. Weihnachtstag" (date Year 12 26) ) (Rosenmontag (- (easter Year) 48) ) (Aschermittwoch (- (easter Year) 46) ) (Karfreitag (- (easter Year) 2) ) ((Ostern Ostersonntag) (easter Year) ) (Ostermontag (+ (easter Year) 1) ) ((Himmelfahrt "Christi Himmelfahrt") (+ (easter Year) 39) ) ((Pfingsten Pfingstsonntag) (+ (easter Year) 49) ) (Pfingstsmontag (+ (easter Year) 50) ) (Fronleichnam (+ (easter Year) 60) ) ) (let L (date X) (cdr (or (assoc (cdr L) (quote ((1 1) . Neujahr) ((5 1) . Maifeiertag) ((10 3) . "Tag der deutschen Einheit") ((12 25) . Weihnachten) ((12 26) . "2. Weihnachtstag") ) ) (assoc (- X (easter (car L))) (quote (-48 . Rosenmontag) (-46 . Aschermittwoch) (-2 . Karfreitag) (0 . Ostern) (1 . Ostermontag) (39 . Himmelfahrt) (49 . Pfingsten) (50 . Pfingstsmontag) (60 . Fronleichnam) ) ) ) ) ) ) ) # Werktag (de werktag (Dat) (nor (member (% Dat 7) (4 5)) # Sa So (feier Dat) ) ) �����������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/canvas.js�����������������������������������������������������������������0000644�0000000�0000000�00000010416�12265263724�015531� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 04jan14abu * (c) Software Lab. Alexander Burger */ function drawCanvas(id, dly, x, y) { var req = new XMLHttpRequest(); try { req.open("POST", document.getElementsByTagName("BASE")[0].href + SesId + "!jsDraw?" + id + "&+" + dly + (y? "&+" + x + "&+" + y : x? "&" + x : "") ); req.responseType = "arraybuffer"; } catch (e) {return true;} req.onload = function() { var lst = plio(new Uint8Array(req.response)); var ele = document.getElementById(id); var cmd, i, j; if (lst) { var ctx = ele.getContext("2d"); for (i = 0; i < lst.length; ++i) { switch ((cmd = lst[i])[0]) { // In sync with "@lib/canvas.l" /*** Functions ***/ case 1: ctx.fillText(cmd[1], cmd[2], cmd[3]); break; case 2: ctx.beginPath(); ctx.moveTo(cmd[1], cmd[2]); ctx.lineTo(cmd[3], cmd[4]); ctx.closePath(); ctx.stroke(); break; case 3: ctx.clearRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 4: ctx.strokeRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 5: ctx.fillRect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 6: ctx.beginPath(); break; case 7: ctx.closePath(); break; case 8: ctx.moveTo(cmd[1], cmd[2]); break; case 9: ctx.lineTo(cmd[1], cmd[2]); break; case 10: ctx.bezierCurveTo(cmd[1], cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]); break; case 11: ctx.moveTo(cmd[1], cmd[2]); ctx.lineTo(cmd[3], cmd[4]); break; case 12: ctx.rect(cmd[1], cmd[2], cmd[3], cmd[4]); break; case 13: ctx.arc(cmd[1], cmd[2], cmd[3], cmd[4], cmd[5], cmd[6]); break; case 14: ctx.stroke(); break; case 15: ctx.fill(); break; case 16: ctx.clip(); break; case 17: if (cmd[3]) for (j = 0; j < cmd[3].length; j += 2) ctx.fillRect(cmd[3][j], cmd[3][j+1], cmd[1], cmd[2]); break; case 18: ctx.drawImage(cmd[1], cmd[2], cmd[3]); break; case 19: ctx.translate(cmd[1], cmd[2]); break; case 20: ctx.rotate(cmd[1]); break; case 21: ctx.scale(cmd[1], cmd[2]); break; case 22: ctx.save(); break; case 23: ctx.restore(); break; /*** Variables ***/ case 24: ctx.fillStyle = cmd[1]; break; case 25: ctx.strokeStyle = cmd[1]; break; case 26: ctx.globalAlpha = cmd[1]; break; case 27: ctx.lineWidth = cmd[1]; break; case 28: ctx.lineCap = cmd[1]; break; case 29: ctx.lineJoin = cmd[1]; break; case 30: ctx.miterLimit = cmd[1]; break; case 31: ctx.globalCompositeOperation = cmd[1]; break; } } } if (y) while (ele = ele.parentNode) { if (ele.tagName == "FORM") { post(ele, false, null, null); break; } } // if (dly == 0) // requestAnimationFrame(function() {drawCanvas(id, dly)}); // else if (dly > 0) // setTimeout(function() {drawCanvas(id, dly)}, dly); if (dly >= 0) setTimeout(function() {drawCanvas(id, dly)}, dly); } try {req.send(null);} catch (e) { req.abort(); return true; } return false; } ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/canvas.l������������������������������������������������������������������0000644�0000000�0000000�00000003140�12265263724�015344� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 05nov13abu # (c) Software Lab. Alexander Burger (allow "!jsDraw" ) (push1 '*JS (allow "@lib/plio.js") (allow "@lib/canvas.js")) # Canvas Commands (for (Opc . L) (quote # In sync with "@lib/canvas.js" ### Functions ### (csFillText Str X Y) (csStrokeLine X1 Y1 X2 Y2) (csClearRect X Y DX DY) (csStrokeRect X Y DX DY) (csFillRect X Y DX DY) (csBeginPath) (csClosePath) (csMoveTo X Y) (csLineTo X Y) (csBezierCurveTo X1 Y1 X2 Y2 X Y) (csLine X1 Y1 X2 Y2) (csRect X Y DX DY) (csArc X Y R A B F) (csStroke) (csFill) (csClip) (csDrawDots DX DY Lst) (csDrawImage Img DX DY) (csTranslate X Y) (csRotate A) (csScale X Y) (csSave) (csRestore) ### Variables ### (csFillStyle V) (csStrokeStyle V) (csGlobalAlpha V) (csLineWidth V) (csLineCap V) (csLineJoin V) (csMiterLimit V) (csGlobalCompositeOperation V) ) (def (car L) (list (cdr L) (list 'link (if (cdr L) (cons 'list Opc @) (list Opc) ) ) ) ) ) (de <canvas> (Id DX DY Alt) (prin "<canvas id=\"" Id "\" width=\"" DX "\" height=\"" DY "\" onclick=\"drawCanvas(this.id, -128, event.layerX-this.offsetLeft, event.layerY-this.offsetTop)\"" ) (dfltCss "canvas") (prinl ">" Alt "</canvas>" ) ) (de jsDraw (Id Dly X Y) (http1 "application/octet-stream" 0) (let Lst (drawCanvas Id Dly X Y) (prinl "Content-Length: " (bytes Lst) "^M^J^M") (pr Lst) ) ) # vi:et:ts=3:sw=3 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/complete.l����������������������������������������������������������������0000644�0000000�0000000�00000001672�12265263724�015711� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 03apr12abu # (c) Software Lab. Alexander Burger (if (opt) (let "Lst" (chop @) (if (= "-" (car "Lst")) (let "Pre" (pop '"Lst") (when (member (car "Lst") '("\"" "'")) (setq "Pre" (pop '"Lst")) ) (let "Str" (pack "Lst") (for "Sym" (all) (and (pre? "Str" "Sym") (getd "Sym") (prinl "Pre" "Sym" (and (= "-" "Pre") " ")) ) ) ) ) (let ("Path" (rot (split "Lst" "/")) "Str" (pack (car "Path"))) (setq "Path" (and (cdr "Path") (pack (glue "/" @) "/"))) (for "Sym" (dir "Path" T) (when (pre? "Str" "Sym") (prinl "Path" (replace (chop "Sym") " " "\\ ") (if (=T (car (info (pack "Path" "Sym")))) "/" " " ) ) ) ) ) ) ) (prinl '+) ) # vi:et:ts=3:sw=3 ����������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/conDbgc.l�����������������������������������������������������������������0000644�0000000�0000000�00000003617�12265263724�015441� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 15nov10abu # (c) Software Lab. Alexander Burger ### Concurrent DB Garbage Collector ### # *DbgcDly *DbgcPid (default *DbgcDly 64) (if (fork) (setq *DbgcPid @) (wait 60000) (undef 'upd) (de upd Lst (wipe Lst) (let *DbgcDly (>> 1 *DbgcDly) (for S Lst (when (ext? S) (mark S T) (markData (val S)) (maps markData S) ) (wipe S) ) ) ) (de markExt (S) (unless (mark S T) (wait *DbgcDly) (markData (val S)) (maps markData S) (wipe S) ) ) (de markData (X) (while (pair X) (markData (pop 'X)) ) (and (ext? X) (markExt X)) ) (loop (let MS (+ (/ (usec) 1000) 86400000) (markExt *DB) (while (> MS (/ (usec) 1000)) (wait 60000) ) ) (let Cnt 0 (for (F . @) (or *Dbs (2)) (for (S (seq F) S (seq S)) (wait *DbgcDly) (unless (mark S) (sync) (if (mark S) (tell) (and (isa '+Entity S) (zap> S)) (zap S) (commit) (inc 'Cnt) ) ) ) ) (when *Blob (use (@S @R F S) (let Pat (conc (chop *Blob) '(@S "." @R)) (in (list 'find *Blob "-type" "f") (while (setq F (line)) (wait *DbgcDly) (when (match Pat F) (unless (and (setq S (extern (pack (replace @S '/)))) (get S (intern (pack @R))) ) (inc 'Cnt) (call 'rm (pack F)) ) (wipe S) ) ) ) ) ) ) (msg Cnt " conDbgc") ) (mark 0) ) ) # vi:et:ts=3:sw=3 �����������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/db.l����������������������������������������������������������������������0000644�0000000�0000000�00000070102�12265263724�014460� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 12oct13abu # (c) Software Lab. Alexander Burger # *Dbs *Jnl *Blob upd ### DB Sizes ### (de dbs Lst (default *Dbs (_dbs 1)) ) (de dbs+ (N . Lst) (unless (cdr (nth *Dbs N)) (conc *Dbs (_dbs N)) ) ) (de _dbs (N) (mapcar '((L) (let Dbf (cons N (>> (- (car L)) 64)) (for Cls (cdr L) (if (atom Cls) (put Cls 'Dbf Dbf) (for Var (cdr Cls) (unless (get Cls 1 Var) (quit "Bad relation" (cons Var (car Cls))) ) (put (get (car Cls) Var) 'dbf Dbf) ) ) ) ) (inc 'N) (car L) ) Lst ) ) (de db: Typ (or (meta Typ 'Dbf 1) 1) ) ### Tree Access ### (de tree (Var Cls Hook) (cons Var (if Hook (cons Cls Hook) Cls ) ) ) (de treeRel (Var Cls) (with (or (get Cls Var) (meta Cls Var)) (or (find '((B) (isa '+index B)) (: bag)) This ) ) ) # (db 'var 'cls ['hook] 'any ['var 'any ..]) -> sym (de db (Var Cls . @) (with (treeRel Var Cls) (let (Tree (tree (: var) (: cls) (and (: hook) (next))) Val (next)) (if (isa '+Key This) (if (args) (and (fetch Tree Val) (pass _db @)) (fetch Tree Val) ) (let Key (cons (if (isa '+Fold This) (fold Val) Val)) (let? A (: aux) (while (and (args) (== (pop 'A) (arg 1))) (next) (queue 'Key (next)) ) (and (: ub) (setq Key (ubZval Key))) ) (let Q (init Tree Key (append Key T)) (loop (NIL (step Q T)) (T (pass _db @ Var Val) @) ) ) ) ) ) ) ) (de _db (Obj . @) (when (isa Cls Obj) (loop (NIL (next) Obj) (NIL (has> Obj (arg) (next))) ) ) ) # (aux 'var 'cls ['hook] 'any ..) -> sym (de aux (Var Cls . @) (with (treeRel Var Cls) (let Key (if (: ub) (ubZval (rest)) (rest)) (step (init (tree (: var) (: cls) (and (: hook) (next))) Key (append Key T) ) ) ) ) ) # (collect 'var 'cls ['hook] ['any|beg ['end [var ..]]]) -> lst (de collect (Var Cls . @) (with (treeRel Var Cls) (let (Tree (tree (: var) (: cls) (and (: hook) (next))) X1 (next) X2 (if (args) (next) (or X1 T)) ) (make (cond ((isa '+Key This) (iter Tree '((X) (and (isa Cls X) (link (pass get X)))) X1 X2 ) ) ((: ub) (if X1 (ubIter Tree (inc (length (: aux))) '((X) (and (isa Cls X) (link (pass get X)))) X1 X2 ) (iter Tree '((X) (and (isa Cls X) (link (pass get X)))) ) ) ) (T (when (isa '+Fold This) (setq X1 (fold X1) X2 (or (=T X2) (fold X2))) ) (if (>= X2 X1) (if (pair X1) (setq X2 (append X2 T)) (setq X1 (cons X1) X2 (cons X2 T)) ) (if (pair X1) (setq X1 (append X1 T)) (setq X1 (cons X1 T) X2 (cons X2)) ) ) (iter Tree '((X) (and (isa Cls X) (link (pass get X))) ) X1 X2 (or (isa '+Idx This) (isa '+IdxFold This)) ) ) ) ) ) ) ) (de genKey (Var Cls Hook Min Max) (if (lt0 Max) (let K (minKey (tree Var Cls Hook) Min Max) (if (lt0 K) (dec K) (or Max -1)) ) (let K (maxKey (tree Var Cls Hook) Min Max) (if (gt0 K) (inc K) (or Min 1)) ) ) ) (de useKey (Var Cls Hook) (let (Tree (tree Var Cls Hook) Max (* 2 (inc (count Tree))) N) (while (fetch Tree (setq N (rand 1 Max)))) N ) ) (de genStrKey (Str Var Cls Hook) (while (fetch (tree Var Cls Hook) Str) (setq Str (pack "# " Str)) ) Str ) ### Relations ### (class +relation) # cls var (dm T (Var Lst) (=: cls *Class) (=: var Var) ) # Type check (dm mis> (Val Obj)) #> lst (dm ele> (Val)) # Value present? (dm has> (Val X) #> any | NIL (and (= Val X) X) ) # Set value (dm put> (Obj Old New) New ) # Delete value (dm del> (Obj Old Val) (and (<> Old Val) Val) ) # Maintain relations (dm rel> (Obj Old New)) (dm lose> (Obj Val)) (dm keep> (Obj Val)) # Finalizer (dm zap> (Obj Val)) (class +Any +relation) # (+Bag) (cls ..) (..) (..) (class +Bag +relation) # bag (dm T (Var Lst) (=: bag (mapcar '((L) (prog1 (new (car L) Var (cdr L)) (and (get @ 'hook) (=: hook T)) ) ) Lst ) ) (super Var) ) (dm mis> (Val Obj) (or (ifn (lst? Val) "Not a Bag") (pick '((This V) (mis> This V Obj (get (if (sym? (: hook)) Obj Val) (: hook) ) ) ) (: bag) Val ) ) ) (dm ele> (Val) (and Val (or (atom Val) (find 'ele> (: bag) Val) ) ) ) (dm has> (Val X) (and Val (or (super Val X) (pick 'has> (: bag) (circ Val) X) ) ) ) (dm put> (Obj Old New) (trim (mapcar '((X O N) (put> X Obj O N)) (: bag) Old New ) ) ) (dm rel> (Obj Old New) (when Old (mapc '((This O) (rel> This Obj O NIL (get (if (sym? (: hook)) Obj Old) (: hook) ) ) ) (: bag) Old ) ) (when New (mapc '((This N) (rel> This Obj NIL N (get (if (sym? (: hook)) Obj New) (: hook) ) ) ) (: bag) New ) ) ) (dm lose> (Obj Val) (mapc '((This V) (lose> This Obj V (get (if (sym? (: hook)) Obj Val) (: hook) ) ) ) (: bag) Val ) ) (dm keep> (Obj Val) (mapc '((This V) (keep> This Obj V (get (if (sym? (: hook)) Obj Val) (: hook) ) ) ) (: bag) Val ) ) (class +Bool +relation) (dm mis> (Val Obj) (and Val (nT Val) ,"Boolean input expected") ) # (+Number) [num] (class +Number +relation) # scl (dm T (Var Lst) (=: scl (car Lst)) (super Var (cdr Lst)) ) (dm mis> (Val Obj) (and Val (not (num? Val)) ,"Numeric input expected") ) # (+Date) (class +Date +Number) (dm T (Var Lst) (super Var (cons NIL Lst)) ) # (+Time) (class +Time +Number) (dm T (Var Lst) (super Var (cons NIL Lst)) ) # (+Symbol) (class +Symbol +relation) (dm mis> (Val Obj) (unless (sym? Val) ,"Symbolic type expected" ) ) # (+String) (class +String +Symbol) (dm mis> (Val Obj) (and Val (not (str? Val)) ,"String type expected") ) # (+Link) typ (class +Link +relation) # type (dm T (Var Lst) (unless (=: type (car Lst)) (quit "No Link" Var) ) (super Var (cdr Lst)) ) (de canQuery (Val) (and (pair Val) (pair (car Val)) (not (find '((L) (not (find '((Cls) (get Cls ((if (lst? (car L)) cadr car) L) ) ) (: type) ) ) ) Val ) ) ) ) (dm mis> (Val Obj) (and Val (nor (isa (: type) Val) (canQuery Val) ) ,"Type error" ) ) # (+Joint) var typ (class +Joint +Link) # slot (dm T (Var Lst) (=: slot (car Lst)) (super Var (cdr Lst)) ) (dm mis> (Val Obj) (and Val (nor (canQuery Val) (and (isa (: type) Val) (with (meta Val (: slot)) (or (isa '+Joint This) (find '((B) (isa '+Joint B)) (: bag) ) ) ) ) ) ,"Type error" ) ) (dm rel> (Obj Old New) (and Old (del> Old (: slot) Obj)) (and New (not (get Obj T)) (put> New (: slot) Obj) ) ) (dm lose> (Obj Val) (when Val (put Val (: slot) (del> (meta Val (: slot)) Obj (get Val (: slot)) Obj) ) ) ) (dm keep> (Obj Val) (when Val (put Val (: slot) (put> (meta Val (: slot)) Obj (get Val (: slot)) Obj) ) ) ) # +Link or +Joint prefix (class +Hook) (dm rel> (Obj Old New Hook) (let L (extract '((X) (and (atom X) (setq X (cons T X))) (and (or (== (: var) (meta Obj (cdr X) 'hook)) (find '((B) (== (: var) (get B 'hook))) (meta Obj (cdr X) 'bag) ) ) X ) ) (getl Obj) ) (for X L (rel> (meta Obj (cdr X)) Obj (car X) NIL (or Old *DB)) (rel> (meta Obj (cdr X)) Obj NIL (car X) (or New *DB)) ) ) (extra Obj Old New Hook) ) # +Index prefix (class +Hook2) (dm rel> (Obj Old New Hook) (extra Obj Old New *DB) (when (or (and Hook (n== Hook *DB)) (get Obj (: hook))) (extra Obj Old New Hook) ) ) (dm lose> (Obj Val Hook) (extra Obj Val *DB) (when (or (and Hook (n== Hook *DB)) (get Obj (: hook))) (extra Obj Val Hook) ) ) (dm keep> (Obj Val Hook) (extra Obj Val *DB) (when (or (and Hook (n== Hook *DB)) (get Obj (: hook))) (extra Obj Val Hook) ) ) # (+Blob) (class +Blob +relation) (de blob (Obj Var) (pack *Blob (glue "/" (chop Obj)) "." Var) ) (dm put> (Obj Old New) (and New (dirname (blob Obj)) (call 'mkdir "-p" @) ) (if (flg? New) New (in New (out (blob Obj (: var)) (echo))) T ) ) (dm zap> (Obj Val) (and Val (call 'rm "-f" (blob Obj (: var)))) ) ### Index classes ### (class +index) # hook dbf (dm T (Var Lst) (=: hook (car Lst)) (extra Var (cdr Lst)) ) # (+Key +relation) [hook] (class +Key +index) (dm mis> (Val Obj Hook) (or (extra Val Obj Hook) (and Val (not (has> Obj (: var) Val)) (fetch (tree (: var) (: cls) (or Hook (get Obj (: hook)))) Val ) ,"Not unique" ) ) ) (dm rel> (Obj Old New Hook) (let Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) (and Old (= Obj (fetch Tree Old)) (store Tree Old NIL (: dbf)) ) (and New (not (get Obj T)) (not (fetch Tree New)) (store Tree New Obj (: dbf)) ) ) (extra Obj Old New Hook) ) (dm lose> (Obj Val Hook) (store (tree (: var) (: cls) (or Hook (get Obj (: hook)))) Val NIL (: dbf) ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (store (tree (: var) (: cls) (or Hook (get Obj (: hook)))) Val Obj (: dbf) ) (extra Obj Val Hook) ) # (+Ref +relation) [hook] (class +Ref +index) # aux ub (dm rel> (Obj Old New Hook) (let (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) Aux (mapcar '((S) (get Obj S)) (: aux)) ) (when Old (let Key (cons Old Aux) (store Tree (if (: ub) (ubZval Key Obj) (append Key Obj) ) NIL (: dbf) ) ) ) (and New (not (get Obj T)) (let Key (cons New Aux) (store Tree (if (: ub) (ubZval Key Obj) (conc Key Obj) ) Obj (: dbf) ) ) ) ) (extra Obj Old New Hook) ) (dm lose> (Obj Val Hook) (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux))) (store (tree (: var) (: cls) (or Hook (get Obj (: hook)))) (if (: ub) (ubZval Key Obj) (conc Key Obj) ) NIL (: dbf) ) ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (let Key (cons Val (mapcar '((S) (get Obj S)) (: aux))) (store (tree (: var) (: cls) (or Hook (get Obj (: hook)))) (if (: ub) (ubZval Key Obj) (conc Key Obj) ) Obj (: dbf) ) ) (extra Obj Val Hook) ) # Backing index prefix (class +Ref2) (dm T (Var Lst) (unless (meta *Class Var) (quit "No Ref2" Var) ) (extra Var Lst) ) (dm rel> (Obj Old New Hook) (with (meta (: cls) (: var)) (let Tree (tree (: var) (: cls)) (when Old (store Tree (cons Old Obj) NIL (: dbf)) ) (and New (not (get Obj T)) (store Tree (cons New Obj) Obj (: dbf)) ) ) ) (extra Obj Old New Hook) ) (dm lose> (Obj Val Hook) (with (meta (: cls) (: var)) (store (tree (: var) (: cls)) (cons Val Obj) NIL (: dbf)) ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (with (meta (: cls) (: var)) (store (tree (: var) (: cls)) (cons Val Obj) Obj (: dbf)) ) (extra Obj Val Hook) ) # (+Idx +relation) [cnt [hook]] (class +Idx +Ref) # min (dm T (Var Lst) (=: min (or (car Lst) 3)) (super Var (cdr Lst)) ) (de idxRel (Obj Old Olds New News Hook) (let (Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) Aux (mapcar '((S) (get Obj S)) (: aux)) Aux2 (append Aux (cons Obj)) ) (setq Aux (conc Aux Obj)) (when Old (store Tree (cons Old Aux) NIL (: dbf)) (for S Olds (while (nth S (: min)) (store Tree (cons (pack S) Aux2) NIL (: dbf)) (pop 'S) ) ) ) (when (and New (not (get Obj T))) (store Tree (cons New Aux) Obj (: dbf)) (for S News (while (nth S (: min)) (store Tree (cons (pack S) Aux2) Obj (: dbf)) (pop 'S) ) ) ) ) ) (dm rel> (Obj Old New Hook) (idxRel Obj Old (split (cdr (chop Old)) " " "^J") New (split (cdr (chop New)) " " "^J") Hook ) (extra Obj Old New Hook) ) (dm lose> (Obj Val Hook) (idxRel Obj Val (split (cdr (chop Val)) " " "^J") NIL NIL Hook ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (idxRel Obj NIL NIL Val (split (cdr (chop Val)) " " "^J") Hook ) (extra Obj Val Hook) ) # (+Sn +index) [hook] (class +Sn) (dm rel> (Obj Old New Hook) (let Tree (tree (: var) (: cls) (or Hook (get Obj (: hook)))) (when Old (store Tree (cons (ext:Snx Old) Obj T) NIL (: dbf)) ) (and New (not (get Obj T)) (store Tree (cons (ext:Snx New) Obj T) Obj (: dbf)) ) ) (extra Obj Old New Hook) ) (dm lose> (Obj Val Hook) (store (tree (: var) (: cls) (or Hook (get Obj (: hook)))) (cons (ext:Snx Val) Obj T) NIL (: dbf) ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (store (tree (: var) (: cls) (or Hook (get Obj (: hook)))) (cons (ext:Snx Val) Obj T) Obj (: dbf) ) (extra Obj Val Hook) ) # (+Fold +index) [hook] (class +Fold) (dm has> (Val X) (extra Val (if (= Val (fold Val)) (fold X) X) ) ) (dm rel> (Obj Old New Hook) (extra Obj (fold Old) (fold New) Hook) ) (dm lose> (Obj Val Hook) (extra Obj (fold Val) Hook) ) (dm keep> (Obj Val Hook) (extra Obj (fold Val) Hook) ) # (+IdxFold +relation) [cnt [hook]] (class +IdxFold +Fold +Ref) (dm T (Var Lst) (=: min (or (car Lst) 3)) (super Var (cdr Lst)) ) (dm rel> (Obj Old New Hook) (idxRel Obj (fold Old) (extract '((L) (extract fold L)) (split (cdr (chop Old)) " " "^J") ) (fold New) (extract '((L) (extract fold L)) (split (cdr (chop New)) " " "^J") ) Hook ) (extra Obj Old New Hook) ) (dm lose> (Obj Val Hook) (idxRel Obj (fold Val) (extract '((L) (extract fold L)) (split (cdr (chop Val)) " " "^J") ) NIL NIL Hook ) (extra Obj Val Hook) ) (dm keep> (Obj Val Hook) (idxRel Obj NIL NIL (fold Val) (extract '((L) (extract fold L)) (split (cdr (chop Val)) " " "^J") ) Hook ) (extra Obj Val Hook) ) # (+Aux) lst (class +Aux) (dm T (Var Lst) (=: aux (car Lst)) (with *Class (for A (car Lst) (if (asoq A (: Aux)) (queue '@ Var) (queue (:: Aux) (list A Var)) ) ) ) (extra Var (cdr Lst)) ) (de relAux (Obj Var Old Lst) (let New (get Obj Var) (put Obj Var Old) (for A Lst (rel> (meta Obj A) Obj (get Obj A) NIL) ) (put Obj Var New) (for A Lst (rel> (meta Obj A) Obj NIL (get Obj A)) ) ) ) # UB-Tree (+Aux prefix) (class +UB) (dm T (Var Lst) (=: ub T) (extra Var Lst) ) (de ubZval (Lst X) (let (Res 0 P 1) (while (find n0 Lst) (map '((L) (and (bit? 1 (car L)) (setq Res (| Res P))) (setq P (>> -1 P)) (set L (>> 1 (car L))) ) Lst ) ) (cons Res X) ) ) (dm has> (Val X) (and Val (or (extra Val X) (extra (let (N (inc (length (: aux))) M 1 V 0) (until (=0 Val) (and (bit? 1 Val) (inc 'V M)) (setq M (>> -1 M) Val (>> N Val)) ) V ) X ) ) ) ) ### Relation prefix classes ### (class +Dep) # dep (dm T (Var Lst) (=: dep (car Lst)) (extra Var (cdr Lst)) ) (dm rel> (Obj Old New Hook) (unless New (for Var (: dep) (let? V (get Obj Var) (rel> (meta Obj Var) Obj V (put> (meta Obj Var) Obj V NIL) ) ) ) ) (extra Obj Old New Hook) ) (class +List) (dm mis> (Val Obj) (or (ifn (lst? Val) "Not a List") (pick '((V) (extra V Obj)) Val) ) ) (dm ele> (Val) (and Val (or (atom Val) (find extra Val))) ) (dm has> (Val X) (and Val (or (extra Val X) (find '((X) (extra Val X)) X) ) ) ) (dm put> (Obj Old New) (if (ele> This New) (cons (extra Obj Old New) Old) (mapcar '((N O) (extra Obj O N)) New Old ) ) ) (dm del> (Obj Old Val) (and (<> Old Val) (delete Val Old) ) ) (dm rel> (Obj Old New Hook) (if (or (ele> This Old) (ele> This New)) (extra Obj Old New Hook) (for O (diff Old New) (extra Obj O NIL Hook) ) (for N New (extra Obj NIL N Hook) ) ) ) (dm lose> (Obj Val Hook) (if (ele> This Val) (extra Obj Val Hook) (for V Val (extra Obj V Hook) ) ) ) (dm keep> (Obj Val Hook) (if (ele> This Val) (extra Obj Val Hook) (for V Val (extra Obj V Hook) ) ) ) (class +Need) (dm mis> (Val Obj) (ifn Val ,"Input required" (extra Val Obj) ) ) (class +Mis) # mis (dm T (Var Lst) (=: mis (car Lst)) (extra Var (cdr Lst)) ) (dm mis> (Val Obj) (or ((: mis) Val Obj) (extra Val Obj)) ) (class +Alt) (dm T (Var Lst) (extra Var (cdr Lst)) (=: cls (car Lst)) ) (class +Swap) # dbf (dm has> (Val X) (or (extra Val X) (extra Val (val X))) ) (dm put> (Obj Old New) (prog1 (or (ext? (get Obj (: var))) (new (or (: dbf 1) 1)) ) (set @ (extra Obj (val Old) New)) ) ) (dm del> (Obj Old Val) (ifn (ext? (get Obj (: var))) (extra Obj Old Val) (set @ (extra Obj (val Old) Val)) @ ) ) ### Entities ### (class +Entity) (var Dbf) (var Aux) (de dbSync (Obj) (let *Run NIL (while (lock (or Obj *DB)) (wait 40) ) (sync) ) ) (de new! ("Typ" . @) (prog2 (dbSync) (pass new (or (meta "Typ" 'Dbf 1) 1) "Typ") (commit 'upd) ) ) (de set! (Obj Val) (unless (= Val (val Obj)) (dbSync) (set Obj Val) (commit 'upd) ) Val ) (de put! (Obj Var Val) (unless (= Val (get Obj Var)) (dbSync) (put Obj Var Val) (commit 'upd) ) Val ) (de inc! (Obj Var Val) (when (num? (get Obj Var)) (dbSync) (prog1 (inc (prop Obj Var) (or Val 1)) (commit 'upd) ) ) ) (de blob! (Obj Var File) (put!> Obj Var File) (blob+ Obj Var) File ) (de blob+ (Obj Var) (when *Jnl (chdir *Blob (call 'ln "-sf" (pack (glue "/" (chop Obj)) "." Var) (pack (name Obj) "." Var) ) ) ) ) (dm T @ (while (args) (cond ((=T (next)) (put This T T)) ((atom (arg)) (put> This (arg) (next))) (T (put> This (car (arg)) (eval (cdr (arg))))) ) ) (upd> This (val This)) ) (dm zap> () (for X (getl This) (let V (or (atom X) (pop 'X)) (and (meta This X) (zap> @ This V)) ) ) ) (dm url> (Tab)) (dm upd> (X Old)) (dm has> (Var Val) (or (nor Val (get This Var)) (has> (meta This Var) Val (get This Var)) ) ) (dm put> (Var Val) (unless (has> This Var Val) (let Old (get This Var) (rel> (meta This Var) This Old (put This Var (put> (meta This Var) This Old Val)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) ) ) Val ) (dm put!> (Var Val) (unless (has> This Var Val) (dbSync) (let Old (get This Var) (rel> (meta This Var) This Old (put This Var (put> (meta This Var) This Old Val)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) (commit 'upd) ) ) Val ) (dm del> (Var Val) (when (and Val (has> (meta This Var) Val (get This Var))) (let Old (get This Var) (rel> (meta This Var) This Old (put This Var (del> (meta This Var) This Old @)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) ) ) ) (dm del!> (Var Val) (when (and Val (has> (meta This Var) Val (get This Var))) (dbSync) (let Old (get This Var) (rel> (meta This Var) This Old (put This Var (del> (meta This Var) This Old @)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) (commit 'upd) ) ) ) (dm inc> (Var Val) (let P (prop This Var) (when (num? (car P)) (let Old @ (rel> (meta This Var) This Old (inc P (or Val 1)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) ) (car P) ) ) ) (dm inc!> (Var Val) (when (num? (get This Var)) (dbSync) (let (P (prop This Var) Old (car P)) (rel> (meta This Var) This Old (inc P (or Val 1)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) (commit 'upd) (car P) ) ) ) (dm dec> (Var Val) (let P (prop This Var) (when (num? (car P)) (let Old @ (rel> (meta This Var) This Old (dec P (or Val 1)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) ) (car P) ) ) ) (dm dec!> (Var Val) (when (num? (get This Var)) (dbSync) (let (P (prop This Var) Old (car P)) (rel> (meta This Var) This Old (dec P (or Val 1)) ) (when (asoq Var (meta This 'Aux)) (relAux This Var Old (cdr @)) ) (upd> This Var Old) (commit 'upd) (car P) ) ) ) (dm mis> (Var Val) (mis> (meta This Var) Val This) ) (dm lose1> (Var) (when (meta This Var) (lose> @ This (get This Var)) ) ) (dm lose> (Lst) (unless (: T) (for X (getl This) (let V (or (atom X) (pop 'X)) (and (not (memq X Lst)) (meta This X) (lose> @ This V) ) ) ) (=: T T) (upd> This) ) ) (dm lose!> () (dbSync) (lose> This) (commit 'upd) ) (de lose "Prg" (let "Flg" (: T) (=: T T) (run "Prg") (=: T "Flg") ) ) (dm keep1> (Var) (when (meta This Var) (keep> @ This (get This Var)) ) ) (dm keep> (Lst) (when (: T) (=: T) (for X (getl This) (let V (or (atom X) (pop 'X)) (and (not (memq X Lst)) (meta This X) (keep> @ This V) ) ) ) (upd> This T) ) ) (dm keep?> (Lst) (extract '((X) (with (and (pair X) (meta This (cdr X))) (and (isa '+Key This) (fetch (tree (: var) (: cls) (get (up This) (: hook))) (car X)) (cons (car X) ,"Not unique") ) ) ) (getl This) ) ) (dm keep!> () (dbSync) (keep> This) (commit 'upd) ) (de keep "Prg" (let "Flg" (: T) (=: T) (run "Prg") (=: T "Flg") ) ) (dm set> (Val) (unless (= Val (val This)) (let Lst (make (maps '((X) (link (fin X))) This)) (for Var Lst (let? Rel (meta This Var) (unless (== Rel (meta Val Var)) (let V (get This Var) (rel> Rel This V (put> Rel This V NIL)) ) ) ) ) (xchg This 'Val) (for Var Lst (let? Rel (meta This Var) (unless (== Rel (meta Val Var)) (rel> Rel This NIL (put> Rel This NIL (get This Var)) ) ) ) ) ) (upd> This (val This) Val) ) (val This) ) (dm set!> (Val) (unless (= Val (val This)) (dbSync) (let Lst (make (maps '((X) (link (fin X))) This)) (for Var Lst (let? Rel (meta This Var) (unless (== Rel (meta Val Var)) (let V (get This Var) (rel> Rel This V (put> Rel This V NIL)) ) ) ) ) (xchg This 'Val) (for Var Lst (let? Rel (meta This Var) (unless (== Rel (meta Val Var)) (rel> Rel This NIL (put> Rel This NIL (get This Var)) ) ) ) ) ) (upd> This (val This) Val) (commit 'upd) ) (val This) ) (dm clone> () (let Obj (new (or (var: Dbf 1) 1) (val This)) (for X (by '((X) (nand (pair X) (isa '+Hook (meta This (cdr X))) ) ) sort (getl This ) ) (if (atom X) (ifn (meta This X) (put Obj X T) (let Rel @ (put> Obj X T) (when (isa '+Blob Rel) (in (blob This X) (out (blob Obj X) (echo)) ) ) ) ) (ifn (meta This (cdr X)) (put Obj (cdr X) (car X)) (let Rel @ (cond ((find '((B) (isa '+Key B)) (get Rel 'bag)) (let (K @ H (get K 'hook)) (put> Obj (cdr X) (mapcar '((Lst) (mapcar '((B Val) (if (== B K) (cloneKey B (cdr X) Val (get (if (sym? H) This Lst) H) ) Val ) ) (get Rel 'bag) Lst ) ) (car X) ) ) ) ) ((isa '+Key Rel) (put> Obj (cdr X) (cloneKey Rel (cdr X) (car X) (get This (get Rel 'hook)) ) ) ) ((or (not (isa '+Joint Rel)) (isa '+List (meta Obj (cdr X)))) (put> Obj (cdr X) (car X)) ) ) ) ) ) ) Obj ) ) (de cloneKey (Rel Var Val Hook) (cond ((isa '+Number Rel) (genKey Var (get Rel 'cls) Hook) ) ((isa '+String Rel) (genStrKey (pack "# " Val) Var (get Rel 'cls) Hook) ) ) ) (dm clone!> () (prog2 (dbSync) (clone> This) (commit 'upd) ) ) # Default syncronization function (de upd Lst (wipe Lst) ) ### Utilities ### # Define object variables as relations (de rel Lst (def *Class (car Lst) (new (cadr Lst) (car Lst) (cddr Lst)) ) ) # Find or create object (de request (Typ Var . @) (let Dbf (or (meta Typ 'Dbf 1) 1) (ifn Var (new Dbf Typ) (with (meta Typ Var) (or (pass db Var (: cls)) (if (: hook) (pass new Dbf Typ (: hook) (next) Var) (pass new Dbf Typ Var) ) ) ) ) ) ) # Create or update object (de obj Lst (let Obj (apply request (pop 'Lst)) (while Lst (put> Obj (pop 'Lst) (pop 'Lst)) ) Obj ) ) # vi:et:ts=3:sw=3 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/db32-64.l�����������������������������������������������������������������0000644�0000000�0000000�00000005045�12265263724�015060� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 10nov11abu # (c) Software Lab. Alexander Burger ## 1. On the 32-bit system: ## $ pil app/main.l @lib/db32-64.l ## : (export64 "db/app/" *Dbs *Blob) ## : (bye) ## ## 2. Transfer the resulting file "~/.pil/db64.tgz" to the 64-bit system, ## and unpack it in the application's runtime directory ## ## 3. On the 64-bit system: ## $ pil app/main.l @lib/too.l @lib/db32-64.l ## : (pool "db/app/" *Dbs) ## : (import32) ## : (bye) # 64-bit DB export -> "~/.pil/db64.tgz" (de export64 (Pool Dbs Blob) (if Blob (call 'tar "cfz" (tmp "db32.tgz") Pool Blob) (call 'tar "cfz" (tmp "db32.tgz") Pool) ) (chdir (tmp) (call 'tar "xfz" "db32.tgz") (pool Pool Dbs) (for (F . @) (or Dbs (2)) (for (S (seq F) S (seq S)) (touch S) (at (0 . 10000) (commit T)) ) ) (commit T) (pool) (for (F . @) Dbs (call 'mv (pack Pool F) (pack Pool (hax (dec F))) ) ) (ifn Blob (call 'tar "cvfz" "../../db64.tgz" Pool) (call 'mv Blob ".blob/") (call 'mkdir "-p" Blob) (use (@S @R Src) (let Pat '`(conc (chop ".blob/") '(@S "." @R)) (in (list 'find ".blob/" "-type" "f") (while (setq Src (line)) (when (match Pat Src) (let (L (split (replace @S "/") "-") Dbf (when (cdr L) (pack (hax (dec (fmt64 (pack (pop 'L))))) "/" ) ) Id (chop (oct (fmt64 (pack (car L))))) Dst (pack Blob Dbf (car Id) (flip (mapcan list (flip (cdr Id)) '(NIL NIL "/" .) ) ) "." @R ) ) (when (dirname Dst) (call 'mkdir "-p" @) ) (call 'mv Src Dst) ) ) ) ) ) ) (call 'tar "cvfz" "../../db64.tgz" Pool Blob) ) ) ) # 32-bit -> 64-bit DB import (de import32 () (dbMap NIL '((Base Root Var Cls Hook) (rebuild NIL Var Cls Hook) ) ) ) # vi:et:ts=3:sw=3 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/dbase.l�������������������������������������������������������������������0000644�0000000�0000000�00000004500�12265263724�015150� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 10may11abu # (c) Software Lab. Alexander Burger (de dbase (File) (use (Cnt Hdr Siz Fld X) (in File (unless (= 3 (rd 1)) # Version (quit "dBASE Version") ) (rd 3) # Date (setq Cnt (rd -4) # Record count Hdr (rd -2) # Header size Siz (rd -2) ) # Record size (rd 3) # Reserved (unless (=0 (rd 1)) # Encryption Flag (quit "Encrypted") ) (rd 16) # Reserved (setq Fld (make (until (= 13 (setq X (rd 1))) (link (cons (intern # Name (pack (char X) (make (for (L (make (do 10 (link (rd 1)))) (n0 (car L)) (cdr L) ) (link (char (car L))) ) ) ) ) (cons (char (rd 1)) # Type (cons (prog (rd 4) (rd 1)) # Size (rd 1) ) ) ) ) # Prec (rd 14) ) ) ) ) # Skip (in (list "@bin/utf2" "-dd" (pack "if=" File) (pack "bs=" Hdr) "skip=1") (prog1 (make (do Cnt (setq X (make (do Siz (link (char))))) (when (<> "*" (pop 'X)) (link (extract '((F) (let? S (pack (clip (cut (caddr F) 'X))) (cons (car F) (case (cadr F) ("C" S) ("D" ($dat S)) ("L" (bool (member S `(chop "JjTt")))) ("N" (format S (cdddr F))) (T "?") ) ) ) ) Fld ) ) ) ) ) (unless (= "^Z" (char)) (quit "Missing EOF") ) ) ) ) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/debug.l�������������������������������������������������������������������0000644�0000000�0000000�00000026043�12265263724�015166� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 31jul13abu # (c) Software Lab. Alexander Burger # Prompt (when symbols (de *Prompt (unless (== (symbols) 'pico) (symbols)) ) ) # Browsing (de doc (Sym Browser) (call (or Browser (sys "BROWSER") 'w3m) (pack "file:" (and (= `(char '/) (char (path "@"))) "//") (path "@doc/ref") (if Sym (let (L (chop Sym) C (car L)) (and (member C '("*" "+")) (cadr L) (setq C @) ) (cond ((>= "Z" C "A")) ((>= "z" C "a") (setq C (uppc C))) (T (setq C "_")) ) (pack C ".html#" Sym) ) ".html" ) ) ) ) (de more ("M" "Fun") (let *Dbg NIL (if (pair "M") ((default "Fun" print) (pop '"M")) (println (type "M")) (setq "Fun" (list '(X) (list 'pp 'X (lit "M"))) "M" (mapcar car (filter pair (val "M"))) ) ) (loop (flush) (T (atom "M") (prinl)) (T (line) T) ("Fun" (pop '"M")) ) ) ) (de what (S) (let *Dbg NIL (setq S (chop S)) (filter '(("X") (match S (chop "X"))) (all) ) ) ) (de who ("X" . "*Prg") (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) (make (mapc "who" (all))) ) ) (de "who" ("Y") (unless (or (ext? "Y") (memq "Y" "Who")) (push '"Who" "Y") (ifn (= `(char "+") (char "Y")) (and (pair (val "Y")) ("nest" @) (link "Y")) (for "Z" (pair (val "Y")) (if (atom "Z") (and ("match" "Z") (link "Y")) (when ("nest" (cdr "Z")) (link (cons (car "Z") "Y")) ) ) ) (maps '(("Z") (if (atom "Z") (and ("match" "Z") (link "Y")) (when ("nest" (car "Z")) (link (cons (cdr "Z") "Y")) ) ) ) "Y" ) ) ) ) (de "nest" ("Y") ("nst1" "Y") ("nst2" "Y") ) (de "nst1" ("Y") (let "Z" (setq "Y" (strip "Y")) (loop (T (atom "Y") (and (sym? "Y") ("who" "Y"))) (and (sym? (car "Y")) ("who" (car "Y"))) (and (pair (car "Y")) ("nst1" @)) (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) (de "nst2" ("Y") (let "Z" (setq "Y" (strip "Y")) (loop (T (atom "Y") ("match" "Y")) (T (or ("match" (car "Y")) ("nst2" (car "Y"))) T ) (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) (de "match" ("D") (and (cond ((str? "X") (and (str? "D") (= "X" "D"))) ((sym? "X") (== "X" "D")) (T (match "X" "D")) ) (or (not "*Prg") (let *Dbg (up 2 *Dbg) (run "*Prg")) ) ) ) (de can (X) (let *Dbg NIL (extract '(("Y") (and (= `(char "+") (char "Y")) (asoq X (val "Y")) (cons X "Y") ) ) (all) ) ) ) # Class dependencies (de dep ("C") (let *Dbg NIL (dep1 0 "C") (dep2 3 "C") "C" ) ) (de dep1 (N "C") (for "X" (type "C") (dep1 (+ 3 N) "X") ) (space N) (println "C") ) (de dep2 (N "C") (for "X" (all) (when (and (= `(char "+") (char "X")) (memq "C" (type "X")) ) (space N) (println "X") (dep2 (+ 3 N) "X") ) ) ) # Inherited methods (de methods (Obj) (make (let Mark NIL (recur (Obj) (for X (val Obj) (nond ((pair X) (recurse X)) ((memq (car X) Mark) (link (cons (car X) Obj)) (push 'Mark (car X)) ) ) ) ) ) ) ) # Source code (off "*Ed") (in "@lib/map" (while (read) (let Sym @ (if (get Sym '*Dbg) (set @ (read)) (put Sym '*Dbg (cons (read))) ) ) ) ) (de _ed ("Ed" . "Prg") (ifn "X" (eval (out (pil "editor") (println (cons 'load "Ed")) ) ) (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (when (setq "*Ed" (if C (get C '*Dbg -1 "X") (get "X" '*Dbg 1) ) ) (out (tmp "tags") (let D (pack (pwd) "/") (for Lst (group # (file (line . sym) (line . sym) ..) (extract '((This) (when (: *Dbg) (cons (path (cdar @)) (caar @) This) ) ) (all) ) ) (let Tags (in (car Lst) (let (Line 1 Ofs 0) (mapcar '((X) (do (- (car X) Line) (inc 'Ofs (inc (size (line T)))) ) (pack `(pack "^J" (char 127)) (cdr X) (char 1) (setq Line (car X)) "," Ofs ) ) (sort (cdr Lst)) ) ) ) (prinl "^L^J" (unless (= `(char "/") (char (car Lst))) D) (car Lst) "," (sum size Tags) Tags ) ) ) ) ) (run "Prg") ) ) "X" ) (de vi ("X" C) (_ed '("@lib/led.l" "@lib/edit.l") (call "vim" (pack "+set tags=" (tmp "tags") ",./tags") "+set isk=33-34,36-38,42-90,92,94-95,97-125" (pack "+" (car "*Ed")) (path (cdr "*Ed")) ) ) ) # Emacs interface (Thorsten Jolitz) # Note: # As 'tags-table-list' is set here, do not also set `tags-file-name' # make sure, tsm.el and picolisp.el are loaded (in that order) and put # the edited .l file in picolisp mode (M-x picolisp-mode) (de em ("X" C) (_ed '("@lib/eled.l" "@lib/eedit.l") (call "emacsclient" "-a" NIL "-e" (pack "(let ((tmp-tags \"" (tmp "tags") "\")" "(src-tags (expand-file-name \"" (path "@src64/tags") "\")))" "(setq tags-table-list " "(append `(,tmp-tags) `(,src-tags) tags-table-list))" "(mapc (lambda (F)" "(unless (file-exists-p (expand-file-name F))" "(setq tags-table-list (delete F tags-table-list))))" "tags-table-list)" "(delete-dups tags-table-list)" "(setq tags-table-list (delete \"\" tags-table-list))" "(setq tags-file-name nil)" " )" ) ) (call "emacsclient" "-c" (pack "+" (car "*Ed")) (path (cdr "*Ed")) ) ) ) (de ld () (and "*Ed" (load (cdr "*Ed"))) ) # Single-Stepping (de _dbg (Lst) (or (atom (car Lst)) (num? (caar Lst)) (flg? (caar Lst)) (== '! (caar Lst)) (set Lst (cons '! (car Lst))) ) ) (de _dbg2 (Lst) (map '((L) (if (and (pair (car L)) (flg? (caar L))) (map _dbg (cdar L)) (_dbg L) ) ) Lst ) ) (de dbg (Lst) (when (pair Lst) (casq (pop 'Lst) ((case casq state) (_dbg Lst) (for L (cdr Lst) (map _dbg (cdr L)) ) ) ((cond nond) (for L Lst (map _dbg L) ) ) (quote (when (fun? Lst) (map _dbg (cdr Lst)) ) ) ((job use let let? recur) (map _dbg (cdr Lst)) ) (loop (_dbg2 Lst) ) ((bind do) (_dbg Lst) (_dbg2 (cdr Lst)) ) (for (and (pair (car Lst)) (map _dbg (cdar Lst))) (_dbg2 (cdr Lst)) ) (T (map _dbg Lst)) ) T ) ) (de d () (let *Dbg NIL (dbg ^))) (de debug ("X" C) (ifn (traced? "X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (or (dbg (if C (method "X" C) (getd "X"))) (quit "Can't debug" "X") ) ) (untrace "X" C) (debug "X" C) (trace "X" C) ) ) (de ubg (Lst) (when (pair Lst) (map '((L) (when (pair (car L)) (when (== '! (caar L)) (set L (cdar L)) ) (ubg (car L)) ) ) Lst ) T ) ) (de u () (let *Dbg NIL (ubg ^))) (de unbug ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (or (ubg (if C (method "X" C) (getd "X"))) (quit "Can't unbug" "X") ) ) ) # Tracing (de traced? ("X" C) (setq "X" (if C (method "X" C) (getd "X") ) ) (and (pair "X") (pair (cadr "X")) (== '$ (caadr "X")) ) ) # Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B)) (de trace ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (if C (unless (traced? "X" C) (or (method "X" C) (quit "Can't trace" "X")) (con @ (cons (conc (list '$ (cons "X" C) (car @)) (cdr @) ) ) ) ) (unless (traced? "X") (and (sym? (getd "X")) (quit "Can't trace" "X")) (and (num? (getd "X")) (expr "X")) (set "X" (list (car (getd "X")) (conc (list '$ "X") (getd "X")) ) ) ) ) "X" ) ) # Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B) (de untrace ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (if C (when (traced? "X" C) (con (method "X" C) (cdddr (cadr (method "X" C))) ) ) (when (traced? "X") (let X (set "X" (cddr (cadr (getd "X")))) (and (== '@ (pop 'X)) (= 1 (length X)) (= 2 (length (car X))) (== 'pass (caar X)) (sym? (cdadr X)) (subr "X") ) ) ) ) "X" ) ) (de *NoTrace @ @@ @@@ pp show more led what who can dep d e debug u unbug trace untrace ) (de traceAll (Excl) (let *Dbg NIL (for "X" (all) (or (memq "X" Excl) (memq "X" *NoTrace) (= `(char "*") (char "X")) (cond ((= `(char "+") (char "X")) (mapc trace (extract '(("Y") (and (pair "Y") (fun? (cdr "Y")) (cons (car "Y") "X") ) ) (val "X") ) ) ) ((pair (getd "X")) (trace "X") ) ) ) ) ) ) # Process Listing (de proc @ (apply call (make (while (args) (link "-C" (next)))) 'ps "-H" "-o" "pid,ppid,start,size,pcpu,wchan,cmd" ) ) # Benchmarking (de bench Prg (let U (usec) (prog1 (run Prg 1) (out 2 (prinl (format (*/ (- (usec) U) 1000) 3) " sec" ) ) ) ) ) # vi:et:ts=3:sw=3 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/ed.l����������������������������������������������������������������������0000644�0000000�0000000�00000002663�12265263724�014472� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 27feb10abu # (c) Software Lab. Alexander Burger # Structure Editor (setq *Clip) (de ed ("X" "C") (when (pair "X") (setq "C" (cdr "X") "X" (car "X")) ) (catch NIL (let (*Dbg NIL "Done") (ifn "C" (set "X" (_ed (val "X"))) (and (asoq "X" (val "C")) (con @ (_ed (cdr @))) ) ) (pp "X" "C") ) ) ) (de _ed (X) (use C (loop (T "Done" X) (pretty (car X)) (prinl) (T (member (setq C (key)) '("^H" "^?")) X) (T (= C "^I") (on "Done") X) (setq X (if (>= "9" C "1") (cons (head (setq C (format C)) X) (nth X (inc C)) ) (case (uppc C) (("^M" "^J") (cons (_ed (car X)) (cdr X))) ("^[" (throw)) (" " (cons (car X) (_ed (cdr X)))) ("D" (cdr X)) ("I" (prin "Insert:") (cons (read) X)) ("R" (prin "Replace:") (cons (read) (cdr X))) ("X" (setq *Clip (car X)) (cdr X)) ("C" (setq *Clip (car X)) X) ("V" (cons *Clip X)) ("0" (append (car X) (cdr X))) ("B" (if (== '! (caar X)) (cons (cdar X) (cdr X)) (cons (cons '! (car X)) (cdr X)) ) ) (T X) ) ) ) ) ) ) �����������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/edit.l��������������������������������������������������������������������0000644�0000000�0000000�00000004074�12265263724�015025� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 12nov12abu # (c) Software Lab. Alexander Burger # "*F" "*Lst" "*X" "*K" (de edit @ (let *Dbg NIL (setq "*F" (tmp '"edit.l")) (catch NIL ("edit" (rest)) ) ) ) (de "edit" ("Lst") (let "N" 1 (loop (out "*F" (setq "*Lst" (make (for "S" "Lst" ("loc" (printsp "S")) ("loc" (val "S")) (pretty (val "S")) (prinl) (for "X" (sort (getl "S")) ("loc" "X") (space 3) (if (atom "X") (println "X" T) (printsp (cdr "X")) (pretty (setq "X" (car "X")) -3) (cond ((type "X") (prin " # ") (print @) ) ((>= 799999 "X" 700000) (prin " # " (datStr "X")) ) ) (prinl) ) ) (prinl) (println '(********)) (prinl) ) ) ) ) (call 'vim "+set isk=33-34,36-38,42-90,92,94-95,97-125" "+map K yiw:call setline(line(\"$\"), \"(\" . line(\".\") . \" \" . @@ . \")\")^MZZ" "+map Q GC(0)^[ZZ" (pack "+" "N") "*F" ) (apply ==== "*Lst") (in "*F" (while (and (setq "*X" (read)) (atom "*X")) (def "*X" (read)) (until (= '(********) (setq "*K" (read))) (def "*X" "*K" (read)) ) ) ) (====) (NIL "*X" (throw)) (T (=0 (car "*X"))) (setq "N" (car "*X")) ("edit" (conc (cdr "*X") "Lst")) ) ) ) (de "loc" ("X" "Lst") (cond ((memq "X" "Lst")) ((and (str? "X") (not (memq "X" (made)))) (link "X") ) ((pair "X") (push '"Lst" "X") ("loc" (car "X") "Lst") ("loc" (cdr "X") "Lst") ) ) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/eedit.l�������������������������������������������������������������������0000644�0000000�0000000�00000012173�12265263724�015171� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 29nov12tj # Authors Alexander Burger, Thorsten Joltiz # (c) Software Lab. Alexander Burger # "*F" "*Lst" "*X" "*K" #{ * Emacs Server ** Start the Emacs server you want to use for PicoLisp editing with server-name 'server', only then it will be automatically recognized by the calls to emacsclient. Example shellscript 'emacsd' for starting emacs as daemon (make it executable): ,------------------------------------------------ | -rwxr-xr-x 1 me users 83 12. Nov 12:27 emacsd `------------------------------------------------ ,----------------------------------------------- | #!/bin/sh | | exec emacs --daemon=server -l ~/my/home/emacs/init.el `----------------------------------------------- If there is no Emacs server running, or none with server-name 'server', the call to emacsclient will start a new server and open an emacsclient for this server. * Customize Emacs: ** Make Emacs revert the edit-buffers without querying (see http://www.gnu.org/software/emacs/manual/html_node/elisp/Reverting.html) ,-------------------------------------------------------------------- | You can customize how revert-buffer does its work by setting the | variables described in the rest of this section. | | — User Option: revert-without-query | | This variable holds a list of files that should be reverted without | query. The value is a list of regular expressions. `-------------------------------------------------------------------- Use a regexp like this, replacing 'my/home/directory/' with the path to your home directory: ,------------------------------- | my/home/directory/\.pil/tmp/.+ `------------------------------- ** Make Emacs save the edited buffer on exit without querying Do not exit with "C-x #" (server-edit) but with "C-x C-c" or "C-u C-x C-c": ,--------------------------------------------------------------------- | (save-buffers-kill-terminal &optional ARG) | | Offer to save each buffer, then kill the current connection. | If the current frame has no client, kill Emacs itself. | | With prefix ARG, silently save all file-visiting buffers, then kill. | | If emacsclient was started with a list of filenames to edit, then | only these files will be asked to be saved. `--------------------------------------------------------------------- ** Put the edited buffer into PicoLisp Mode The PicoLisp distribution contains a PicoLisp major mode for Emacs, 'picolisp.el' in the "el/" directory (that is "@lib/el" for a local installation, or some system dependent directory for a global installation). Make sure that you load this file on Emacs startup and automatically put '.l' files into picolisp-mode, e.g. with the following code in you .emacs: ,------------------------------------------------------------ | (add-to-list 'load-path "~/path/to/picolisp/lib/el/") | (require 'picolisp) | (add-to-list 'auto-mode-alist '("\\.l\\'" . picolisp-mode)) `------------------------------------------------------------ ** Add and remove symbols from the 'edit' buffer With point on a symbol (or with a symbol marked as region in transient mark mode), 'C-c C-v' (picolisp-edit-K) adds this symbol on top of the editing buffer. A subsequent 'C-c C-c' (picolisp-edit-Q) removes it again and puts point back to its previous line. Using 'C-c C-c' when only one symbol is left exits the 'edit' buffer. }# (de edit @ (let *Dbg NIL (setq "*F" (tmp '"edit.l")) (catch NIL ("edit" (rest)) ) ) ) (de "edit" ("Lst") (let "N" 1 (loop (out "*F" (setq "*Lst" (make (for "S" "Lst" ("loc" (printsp "S")) ("loc" (val "S")) (pretty (val "S")) (prinl) (for "X" (sort (getl "S")) ("loc" "X") (space 3) (if (atom "X") (println "X" T) (printsp (cdr "X")) (pretty (setq "X" (car "X")) -3) (cond ((type "X") (prin " # ") (print @) ) ((>= 799999 "X" 700000) (prin " # " (datStr "X")) ) ) (prinl) ) ) (prinl) (println '(********)) (prinl) ) ) ) ) (call 'emacsclient "-a" "" "-c" (pack "+" "N") "*F" ) (apply ==== "*Lst") (in "*F" (while (and (setq "*X" (read)) (atom "*X")) (def "*X" (read)) (until (= '(********) (setq "*K" (read))) (def "*X" "*K" (read)) ) ) ) (====) (NIL "*X" (throw)) (T (=0 (car "*X"))) (setq "N" (car "*X")) ("edit" (conc (cdr "*X") "Lst")) ) ) ) (de "loc" ("X" "Lst") (cond ((memq "X" "Lst")) ((and (str? "X") (not (memq "X" (made)))) (link "X") ) ((pair "X") (push '"Lst" "X") ("loc" (car "X") "Lst") ("loc" (cdr "X") "Lst") ) ) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/el/�����������������������������������������������������������������������0000755�0000000�0000000�00000000000�12265263724�014316� 5����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/el/README�����������������������������������������������������������������0000644�0000000�0000000�00000002073�12265263724�015200� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������In order to get the picolisp-mode working correctly you have to add the following expressions to your .emacs and adapt them according to your set-up: (add-to-list 'load-path "<path-to>/picoLisp/lib/el") (load "tsm.el") ;; Picolisp TransientSymbolsMarkup (*Tsm) (autoload 'run-picolisp "inferior-picolisp") (autoload 'picolisp-mode "picolisp" "Major mode for editing Picolisp." t) If you have also SLIME installed, it will suck all possible lisp extensions up (greedy bastard). So in order to get the correct file-association for picolisp files you'll have to also add this: (add-to-list 'auto-mode-alist '("\\.l$" . picolisp-mode)) If you want, you can add a few hooks for convenience: (add-hook 'picolisp-mode-hook (lambda () (paredit-mode +1) ;; Loads paredit mode automatically (tsm-mode) ;; Enables TSM (define-key picolisp-mode-map (kbd "RET") 'newline-and-indent) (define-key picolisp-mode-map (kbd "C-h") 'paredit-backward-delete) ) ) By the way, don't forget to patch your paredit.el (v21) with the patch provided to get a smoother editing. ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/el/inferior-picolisp.el���������������������������������������������������0000644�0000000�0000000�00000036111�12265263724�020277� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;;;;; inferior-picolisp: Picolisp repl in a buffer. ;;;;;; Version: 1.2 ;;; Copyright (c) 2009, 2012, 2013, Guillermo R. Palavecino, Thorsten Jolitz ;; This file is NOT part of GNU emacs. ;;;; Credits: ;; It's and adaptation of GNU emacs' cmuscheme.el ;; ;;;; Contact: ;; For comments, bug reports, questions, etc, you can contact me via IRC ;; to the user named grpala (or armadillo) on irc.freenode.net in the ;; #picolisp channel or via email to the author's nickname at gmail.com ;; ;;;; License: ;; This work is released under the GPL 2 or (at your option) any later ;; version. (require 'picolisp) (require 'comint) (defgroup picolisp nil "Run an Picolisp process in a buffer." :group 'picolisp ) ;;; INFERIOR PICOLISP MODE STUFF ;;;============================================================================ (defconst inferior-picolisp-version "1.2" "Verion-number of library") (defcustom inferior-picolisp-mode-hook nil "*Hook for customizing inferior-picolisp mode." :type 'hook :group 'picolisp ) (defvar inferior-picolisp-mode-map (let ((m (make-sparse-keymap))) (define-key m "\M-\C-x" 'picolisp-send-definition) ;gnu convention (define-key m "\C-x\C-e" 'picolisp-send-last-sexp) (define-key m "\C-c\C-l" 'picolisp-load-file) m ) ) (defvar picolisp-local-program-name "./pil +") (defvar picolisp-process-number 0) (defvar picolisp-program-name "pil +" "The name of the program used to run Picolisp." ) ;; Install the process communication commands in the picolisp-mode keymap. (define-key picolisp-mode-map "\M-\C-x" 'picolisp-send-definition);gnu convention (define-key picolisp-mode-map "\C-x\C-e" 'picolisp-send-last-sexp);gnu convention (define-key picolisp-mode-map "\C-c\C-e" 'picolisp-send-definition) (define-key picolisp-mode-map "\C-c\M-e" 'picolisp-send-definition-and-go) (define-key picolisp-mode-map "\C-c\C-r" 'picolisp-send-region) (define-key picolisp-mode-map "\C-c\M-r" 'picolisp-send-region-and-go) (define-key picolisp-mode-map "\C-c\C-x" 'switch-to-picolisp) (define-key picolisp-mode-map "\C-c\C-l" 'picolisp-load-file) (let ((map (lookup-key picolisp-mode-map [menu-bar picolisp]))) (define-key map [separator-eval] '("--")) (define-key map [load-file] '("Load Picolisp File" . picolisp-load-file) ) (define-key map [switch] '("Switch to Picolisp" . switch-to-picolisp) ) (define-key map [send-def-go] '("Evaluate Last Definition & Go" . picolisp-send-definition-and-go) ) (define-key map [send-def] '("Evaluate Last Definition" . picolisp-send-definition) ) (define-key map [send-region-go] '("Evaluate Region & Go" . picolisp-send-region-and-go) ) (define-key map [send-region] '("Evaluate Region" . picolisp-send-region) ) (define-key map [send-sexp] '("Evaluate Last S-expression" . picolisp-send-last-sexp) ) ) (defvar picolisp-buffer) (define-derived-mode inferior-picolisp-mode comint-mode "Inferior Picolisp" "Major mode for interacting with an inferior Picolisp process. The following commands are available: \\{inferior-picolisp-mode-map} An Picolisp process can be fired up with M-x run-picolisp. Customization: Entry to this mode runs the hooks on comint-mode-hook and inferior-picolisp-mode-hook (in that order). You can send text to the inferior Picolisp process from other buffers containing Picolisp source. switch-to-picolisp switches the current buffer to the Picolisp process buffer. picolisp-send-definition sends the current definition to the Picolisp process. picolisp-send-region sends the current region to the Picolisp process. picolisp-send-definition-and-go and picolisp-send-region-and-go switch to the Picolisp process buffer after sending their text. For information on running multiple processes in multiple buffers, see documentation for variable picolisp-buffer. Commands: Return after the end of the process' output sends the text from the end of process to point. Return before the end of the process' output copies the sexp ending at point to the end of the process' output, and sends it. Delete converts tabs to spaces as it moves back. Tab indents for Picolisp; with argument, shifts rest of expression rigidly with the current line. C-M-q does Tab on each line starting within following expression. Paragraphs are separated only by blank lines. Semicolons start comments. If you accidentally suspend your process, use \\[comint-continue-subjob] to continue it." ;; Customize in inferior-picolisp-mode-hook (picolisp-mode-variables) (setq comint-prompt-regexp "^[^\n:?!]*[?!:]+ *") (setq comint-prompt-read-only nil) (setq comint-input-filter (function picolisp-input-filter)) (setq comint-get-old-input (function picolisp-get-old-input)) (setq mode-line-process '(":%s")) (setq comint-input-ring-file-name "~/.pil_history") ) (defcustom inferior-picolisp-filter-regexp "\\`\\s *\\S ?\\S ?\\s *\\'" "*Input matching this regexp are not saved on the history list. Defaults to a regexp ignoring all inputs of 0, 1, or 2 letters." :type 'regexp :group 'picolisp ) (defun picolisp-input-filter (str) "Don't save anything matching `inferior-picolisp-filter-regexp'." (not (string-match inferior-picolisp-filter-regexp str)) ) (defun picolisp-get-old-input () "Snarf the sexp ending at point." (save-excursion (let ((end (point))) (backward-sexp) (buffer-substring (point) end) ) ) ) (defun picolisp-disable-line-editor () "Disable inbuild PicoLisp line-editor. Not needed when PicoLisp is run as Emacs subprocess." (let ((pil-tmp-dir (expand-file-name "~/.pil/"))) (and (member "editor" (directory-files pil-tmp-dir )) (rename-file (expand-file-name "editor" pil-tmp-dir) (expand-file-name "editor-orig" pil-tmp-dir))) (with-current-buffer (find-file-noselect (expand-file-name "editor" pil-tmp-dir)) (save-buffer) (kill-buffer)))) (defun picolisp-reset-line-editor () "Reset inbuild PicoLisp line-editor to original state." (let ((pil-tmp-dir (expand-file-name "~/.pil/"))) (if (member "editor-orig" (directory-files pil-tmp-dir)) (rename-file (expand-file-name "editor-orig" pil-tmp-dir) (expand-file-name "editor" pil-tmp-dir) 'OK-IF-ALREADY-EXISTS) (delete-file (expand-file-name "editor" pil-tmp-dir))))) ;;;###autoload (defun run-picolisp-new-local (cmd) "Run a new inferior Picolisp process for a locally installed PicoLisp, input and output via buffer `*picolisp<N>*'. Works only as intended, when called from inside a picolisp directory, e.g. from a dired buffer showing the top-level directory of a local picolisp installation. Otherwise, calls a global picolisp installation instead (with `picolisp-program-name', see function `picolisp-interactively-start-process'). If there is a process already running in `*picolisp<N>*', create a new process in buffer `*picolisp<N+1>*'. With argument, allows you to edit the command line (default is value of `picolisp-local-program-name'). Runs the hook `inferior-picolisp-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run Picolisp: " picolisp-local-program-name) picolisp-local-program-name) ) ) (setq picolisp-process-number (1+ picolisp-process-number)) (setq pl-proc-buf (concat "picolisp<" (number-to-string picolisp-process-number) ">")) (let ((cmdlist (split-string cmd))) (picolisp-disable-line-editor) (set-buffer (apply 'make-comint pl-proc-buf (car cmdlist) nil (cdr cmdlist))) (picolisp-reset-line-editor) (inferior-picolisp-mode) ) (pop-to-buffer (concat "*" pl-proc-buf "*")) ) ;;;###autoload (defun run-picolisp (cmd) "Run an inferior Picolisp process, input and output via buffer `*picolisp*'. If there is a process already running in `*picolisp*', switch to that buffer. With argument, allows you to edit the command line (default is value of `picolisp-program-name'). Runs the hook `inferior-picolisp-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" (interactive (list (if current-prefix-arg (read-string "Run Picolisp: " picolisp-program-name) picolisp-program-name ) ) ) (when (not (comint-check-proc "*picolisp*")) (let ((cmdlist (split-string cmd))) (picolisp-disable-line-editor) (set-buffer (apply 'make-comint "picolisp" (car cmdlist) nil (cdr cmdlist) ) ) (picolisp-reset-line-editor) (inferior-picolisp-mode) ) ) (setq picolisp-program-name cmd) (setq picolisp-buffer "*picolisp*") (pop-to-buffer "*picolisp*") ) ;;;###autoload (add-hook 'same-window-buffer-names "*picolisp*") (defun picolisp-send-region (start end) "Send the current region to the inferior Picolisp process." (interactive "r") (let ((regionsubstring (replace-regexp-in-string "^ " "" (buffer-substring start end) ) ) ) (comint-send-string (picolisp-proc) (if (string= "" (car (last (split-string regionsubstring " " ) ) ) ) regionsubstring (concat regionsubstring "\n") ) ) ) ) (defun picolisp-send-definition () "Send the current definition to the inferior Picolisp process." (interactive) (save-excursion (end-of-defun) (let ((end (point))) (beginning-of-defun) (picolisp-send-region (point) (progn (forward-sexp) (point)) ) ) ) ) (defun picolisp-send-last-sexp () "Send the previous sexp to the inferior Picolisp process." (interactive) (picolisp-send-region (save-excursion (backward-sexp) (point)) (point)) ) (defun switch-to-picolisp (eob-p) "Switch to the picolisp process buffer. With argument, position cursor at end of buffer." (interactive "P") (if (or (and picolisp-buffer (get-buffer picolisp-buffer)) (picolisp-interactively-start-process) ) (pop-to-buffer picolisp-buffer) (error "No current process buffer. See variable `picolisp-buffer'") ) (when eob-p (push-mark) (goto-char (point-max)) ) ) (defun picolisp-send-region-and-go (start end) "Send the current region to the inferior Picolisp process. Then switch to the process buffer." (interactive "r") (picolisp-send-region start end) (switch-to-picolisp t) ) (defun picolisp-send-definition-and-go () "Send the current definition to the inferior Picolisp. Then switch to the process buffer." (interactive) (picolisp-send-definition) (switch-to-picolisp t) ) (defcustom picolisp-source-modes '(picolisp-mode) "*Used to determine if a buffer contains Picolisp source code. If it's loaded into a buffer that is in one of these major modes, it's considered a picolisp source file by `picolisp-load-file'. Used by these commands to determine defaults." :type '(repeat function) :group 'picolisp ) (defvar picolisp-prev-load-dir/file nil "Caches the last (directory . file) pair. Caches the last pair used in the last `picolisp-load-file' command. Used for determining the default in the next one." ) (defun picolisp-load-file (file-name) "Load a Picolisp file FILE-NAME into the inferior Picolisp process." (interactive (comint-get-source "Load Picolisp file: " picolisp-prev-load-dir/file picolisp-source-modes t ) ) ; t because `load' ; needs an exact name (comint-check-source file-name) ; Check to see if buffer needs saved. (setq picolisp-prev-l/c-dir/file (cons (file-name-directory file-name) (file-name-nondirectory file-name) ) ) (comint-send-string (picolisp-proc) (concat "(load \"" file-name "\"\)\n" ) ) ) (defvar picolisp-buffer nil "*The current picolisp process buffer. MULTIPLE PROCESS SUPPORT =========================================================================== inferior-picolisp.el supports, in a fairly simple fashion, running multiple Picolisp processes. To run multiple Picolisp processes, you start the first up with \\[run-picolisp]. It will be in a buffer named *picolisp*. Rename this buffer with \\[rename-buffer]. You may now start up a new process with another \\[run-picolisp]. It will be in a new buffer, named *picolisp*. You can switch between the different process buffers with \\[switch-to-buffer]. Commands that send text from source buffers to Picolisp processes -- like `picolisp-send-definition' -- have to choose a process to send to, when you have more than one Picolisp process around. This is determined by the global variable `picolisp-buffer'. Suppose you have three inferior Picolisps running: Buffer Process foo picolisp bar picolisp<2> *picolisp* picolisp<3> If you do a \\[picolisp-send-definition-and-go] command on some Picolisp source code, what process do you send it to? - If you're in a process buffer (foo, bar, or *picolisp*), you send it to that process. - If you're in some other buffer (e.g., a source file), you send it to the process attached to buffer `picolisp-buffer'. This process selection is performed by function `picolisp-proc'. Whenever \\[run-picolisp] fires up a new process, it resets `picolisp-buffer' to be the new process's buffer. If you only run one process, this will do the right thing. If you run multiple processes, you can change `picolisp-buffer' to another process buffer with \\[set-variable]. More sophisticated approaches are, of course, possible. If you find yourself needing to switch back and forth between multiple processes frequently, you may wish to consider ilisp.el, a larger, more sophisticated package for running inferior Lisp and Picolisp processes. The approach taken here is for a minimal, simple implementation. Feel free to extend it." ) (defun picolisp-proc () "Return the current Picolisp process, starting one if necessary. See variable `picolisp-buffer'." (unless (and picolisp-buffer (get-buffer picolisp-buffer) (comint-check-proc picolisp-buffer) ) (picolisp-interactively-start-process) ) (or (picolisp-get-process) (error "No current process. See variable `picolisp-buffer'") ) ) (defun picolisp-get-process () "Return the current Picolisp process or nil if none is running." (get-buffer-process (if (eq major-mode 'inferior-picolisp-mode) (current-buffer) picolisp-buffer ) ) ) (defun picolisp-interactively-start-process (&optional cmd) "Start an inferior Picolisp process. Return the process started. Since this command is run implicitly, always ask the user for the command to run." (save-window-excursion (run-picolisp (read-string "Run Picolisp: " picolisp-program-name)) ) ) ;;; Do the user's customization... (defcustom inferior-picolisp-load-hook nil "This hook is run when inferior-picolisp is loaded in. This is a good place to put keybindings." :type 'hook :group 'picolisp ) (run-hooks 'inferior-picolisp-load-hook) (provide 'inferior-picolisp) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/el/paredit.el.diff��������������������������������������������������������0000644�0000000�0000000�00000006724�12265263724�017210� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������--- /usr/share/emacs/site-lisp/paredit/paredit.el 2009-07-28 20:43:11.000000000 -0300 +++ src/el/paredit.el 2009-12-15 04:39:31.000000000 -0300 @@ -683,7 +683,8 @@ (defun paredit-move-past-close (close) (cond ((or (paredit-in-string-p) (paredit-in-comment-p)) - (insert close)) + (insert close) + (paredit-delete-leading-whitespace)) ((not (paredit-in-char-p)) (paredit-move-past-close-and-reindent close) (paredit-blink-paren-match nil)))) @@ -691,7 +692,8 @@ (defun paredit-move-past-close-and-newline (close) (if (or (paredit-in-string-p) (paredit-in-comment-p)) - (insert close) + (progn (insert close) + (paredit-delete-leading-whitespace)) (if (paredit-in-char-p) (forward-char)) (paredit-move-past-close-and-reindent close) (let ((comment.point (paredit-find-comment-on-line))) @@ -747,6 +749,7 @@ (point)))) (regionp (funcall forward (+ end (if spacep 2 1))))) (insert close) + (paredit-delete-leading-whitespace) (if (paredit-space-for-delimiter-p t close) (insert " ")))))) @@ -784,7 +787,8 @@ (if (eq close (matching-paren open)) (save-excursion (message "Missing closing delimiter: %c" close) - (insert close)) + (insert close) + (paredit-delete-leading-whitespace)) (error "Mismatched missing closing delimiter: %c ... %c" open close)))) (let ((orig (point))) @@ -1543,6 +1547,7 @@ ((paredit-region-active-p) nil) (t 1))) (insert close) + (paredit-delete-leading-whitespace) (backward-char))) (save-excursion (backward-up-list) (indent-sexp))) @@ -1791,8 +1796,10 @@ (setq close ; adjusting for mixed (prog1 (char-before) ; delimiters as necessary, (backward-delete-char 1) - (insert close)))))) - (insert close))) ; to insert that delimiter. + (insert close) + (paredit-delete-leading-whitespace)))))) + (insert close) ; to insert that delimiter. + (paredit-delete-leading-whitespace))) (defun paredit-forward-slurp-into-string () (goto-char (1+ (cdr (paredit-string-start+end-points)))) @@ -1802,7 +1809,8 @@ (let ((close (char-before))) (backward-delete-char 1) (paredit-forward-for-quote (save-excursion (forward-sexp) (point))) - (insert close))) + (insert close) + (paredit-delete-leading-whitespace))) (defun paredit-forward-barf-sexp () "Remove the last S-expression in the current list from that list @@ -1822,7 +1830,8 @@ (error "Barfing all subexpressions with no open-paren?")) ((paredit-in-comment-p) ; Don't put the close-paren in (newline-and-indent))) ; a comment. - (insert close)) + (insert close) + (paredit-delete-leading-whitespace)) ;; Reindent all of the newly barfed S-expressions. (paredit-forward-and-indent))) @@ -1919,6 +1928,7 @@ (char-before)))) (delete-horizontal-space) (insert close) + (paredit-delete-leading-whitespace) (save-excursion (insert ?\ ) (insert open) (backward-char) ��������������������������������������������picolisp-3.1.5.2.orig/lib/el/picolisp-wiki-mode.el��������������������������������������������������0000644�0000000�0000000�00000120116�12265263724�020346� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; picolisp-wiki-mode.el --- Emacs Major mode for PicoLisp-Wiki formatted text files ;; Copyright (C) 2012-13 Thorsten Jolitz <tjolitz@gmail.com> ;; Author: Thorsten Jolitz <tjolitz@gmail.com> ;; Maintainer: Thorsten Jolitz <tjolitz@gmail.com> ;; Created: September 01, 2012 ;; Version: 1.0 ;; Keywords: PicoLisp, wiki ;; URL: http://picolisp.com/5000/!wiki?home ;; This file is not part of GNU Emacs. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; picolisp-wiki-mode is a major mode for editing text files for ;; PicoLisp-Wiki in GNU Emacs. picolisp-wiki-mode is free software, ;; licensed under the GNU GPL. ;;; Dependencies: ;; picolisp-wiki-mode requires easymenu, a standard package since GNU Emacs ;; 19 and XEmacs 19, which provides a uniform interface for creating ;; menus in GNU Emacs and XEmacs. ;;; Installation: ;; Make sure to place `picolisp-wiki-mode.el` somewhere in the ;; load-path and add the following lines to your `.emacs` file to ;; associate picolisp-wiki-mode with `.text` files: (autoload 'picolisp-wiki-mode "picolisp-wiki-mode" "Major mode for editing Picolisp-Wiki files" t) (setq auto-mode-alist ;; (cons '("\\.text" . picolisp-wiki-mode) auto-mode-alist)) (cons '("\\.plw" . picolisp-wiki-mode) auto-mode-alist)) ;; There is no consensus on an official file extension so change `.text` to ;; `.plw`, `.lw`, `.lwik`, or whatever you call your picolisp-wiki files. ;;; Customization: ;; Although no configuration is *necessary* there are a few things ;; that can be customized. The `M-x customize-mode` command ;; provides an interface to all of the possible customizations. ;; Usage: ;; Keybindings for inserting are grouped by prefixes based on their ;; function. For example, commands inserting links and lists begin ;; with `C-c C-l`, those inserting floating content with `C-c C-f`, ;; all other inserting commands with `C-c C-c`. The commands in each ;; group are described below. You can obtain a list of all keybindings ;; by pressing `C-c C-h`. ;; ;; Element insertion ;; "\C-c\C-l n" Insert Internal Link ;; "\C-c\C-l x" Insert External Link ;; "\C-c\C-l u" Insert Unordered List ;; "\C-c\C-l o" Insert Ordered List ;; "\C-c\C-l i" Insert List Item ;; "\C-c\C-f l" Insert Left-Floating-Content ;; "\C-c\C-f n" Insert Non-Floating Content ;; "\C-c\C-f r" Insert Right-Floating-Content ;; "\C-c\C-c k" Insert Line Breaks ;; "\C-c\C-c 1" Insert Header 1 ;; "\C-c\C-c 2" Insert Header 2 ;; "\C-c\C-c 3" Insert Header 3 ;; "\C-c\C-c 4" Insert Header 4 ;; "\C-c\C-c 5" Insert Header 5 ;; "\C-c\C-c 6" Insert Header 6 ;; "\C-c\C-c b" Insert Bold ;; "\C-c\C-c i" Insert Italic ;; "\C-c\C-c u" Insert Underlined ;; "\C-c\C-c p" Insert Pre Block ;; "\C-c\C-c c" Insert Comment ;; "\C-c\C-c -" Insert Horizontal Rule (hr) ;; ;; Visibility cycling ;; "<tab>" Picolisp Wiki Cycle ;; "<S-iso-lefttab>" Picolisp Wiki Shifttab ;; ;; Header navigation ;; "C-M-n" Outline Next Visible Heading ;; "C-M-p" Outline Previous Visible Heading ;; "C-M-f" Outline Forward Same Level ;; "C-M-b" Outline Backward Same Level ;; "C-M-u" Outline Up Heading ;; Many of the commands described above behave differently depending on ;; whether Transient Mark mode is enabled or not. When it makes sense, ;; if Transient Mark mode is on and a region is active, the command ;; applies to the text in the region (e.g., `C-c C-c b` makes the region ;; bold). For users who prefer to work outside of Transient Mark mode, ;; in Emacs 22 it can be enabled temporarily by pressing `C-SPC C-SPC`. ;; ;; picolisp-wiki-mode supports outline-minor-mode as well as ;; org-mode-style visibility cycling for PicoLisp-Wikli-style headers. ;; There are two types of visibility cycling: Pressing `S-TAB` cycles ;; globally between the table of contents view (headers only), outline ;; view (top-level headers only), and the full document view. Pressing ;; `TAB` while the point is at a header will cycle through levels of ;; visibility for the subtree: completely folded, visible children, ;; and fully visible. ;; * Outline Navigation: ;; ;; Navigation between headings is possible using `outline-mode'. ;; Use `C-M-n` and `C-M-p` to move between the next and previous ;; visible headings. Similarly, `C-M-f` and `C-M-b` move to the ;; next and previous visible headings at the same level as the one ;; at the point. Finally, `C-M-u` will move up to a lower-level ;; (more inclusive) visible heading. ;; ;; FIXME: different headers levels are not yet recognized by the outine ;; commands. ;;; Acknowledgments: ;; picolisp-wiki-mode is based on markdown.el (available from ELPA). ;; It has benefited greatly from the efforts of the following people: ;; ;; * Thorsten Jolitz <tjolitz [AT] gmail [DOT] com> ;; * Doug Lewan <dougl [@] shubertticketing [DOT] com> ;;; Bugs: ;; picolisp-wiki-mode is developed and tested primarily using GNU ;; Emacs 24, compatibility with earlier Emacsen is no priority. For ;; bugs and todo's, see the HISTORY.org file in the github-repo ;; (https://github.com/tj64/picolisp-wiki-mode). ;; ;; If you find any bugs in picolisp-wiki-mode, please construct a test case ;; or a patch and email me at <tjolitz@gmail.com>. ;;; History: ;; picolisp-wiki-mode was written and is maintained by Thorsten ;; Joltiz. The first version (0.9) was released on Sept 01, 2012. For ;; further information see the HISTORY.org file in the github-repo ;; (https://github.com/tj64/picolisp-wiki-mode). ;;; Code: (require 'easymenu) (require 'outline) (require 'cl) ;;; Constants ================================================================= (defconst picolisp-wiki-mode-version "1.0" "Picolisp-Wiki mode version number.") ;;; Customizable variables ==================================================== (defvar picolisp-wiki-mode-hook nil "Hook runs when Picolisp-Wiki mode is loaded.") (defgroup picolisp-wiki nil "Major mode for editing text files in Picolisp-Wiki format." :prefix "picolisp-wiki-" :group 'wp :link '(url-link "http://picolisp.com/5000/!wiki?homef")) (defcustom picolisp-wiki-hr-string "------------------------------------" "String to use for horizonal rules." :group 'picolisp-wiki :type 'string) (defcustom picolisp-wiki-uri-types '("acap" "cid" "data" "dav" "fax" "file" "ftp" "gopher" "http" "https" "imap" "ldap" "mailto" "mid" "modem" "news" "nfs" "nntp" "pop" "prospero" "rtsp" "service" "sip" "tel" "telnet" "tip" "urn" "vemmi" "wais") "Link types for syntax highlighting of URIs." :group 'picolisp-wiki :type 'list) (defcustom picolisp-wiki-link-space-sub-char "_" "Character to use instead of spaces when mapping wiki links to filenames." :group 'picolisp-wiki :type 'string) ;;; Font lock ================================================================= (require 'font-lock) (defvar picolisp-wiki-starting-brace-face 'picolisp-wiki-starting-brace-face "Face name to use for starting braces.") (defvar picolisp-wiki-closing-brace-face 'picolisp-wiki-closing-brace-face "Face name to use for closing braces.") (defvar picolisp-wiki-line-break-face 'picolisp-wiki-line-break-face "Face name to use for line breaks.") (defvar picolisp-wiki-italic-face 'picolisp-wiki-italic-face "Face name to use for italic text.") (defvar picolisp-wiki-bold-face 'picolisp-wiki-bold-face "Face name to use for bold text.") (defvar picolisp-wiki-underlined-face 'picolisp-wiki-underlined-face "Face name to use for underlined text.") (defvar picolisp-wiki-header-face 'picolisp-wiki-header-face "Face name to use as a base for headers.") (defvar picolisp-wiki-header-face-1 'picolisp-wiki-header-face-1 "Face name to use for level-1 headers.") (defvar picolisp-wiki-header-face-2 'picolisp-wiki-header-face-2 "Face name to use for level-2 headers.") (defvar picolisp-wiki-header-face-3 'picolisp-wiki-header-face-3 "Face name to use for level-3 headers.") (defvar picolisp-wiki-header-face-4 'picolisp-wiki-header-face-4 "Face name to use for level-4 headers.") (defvar picolisp-wiki-header-face-5 'picolisp-wiki-header-face-5 "Face name to use for level-5 headers.") (defvar picolisp-wiki-header-face-6 'picolisp-wiki-header-face-6 "Face name to use for level-6 headers.") (defvar picolisp-wiki-list-item-face 'picolisp-wiki-list-item-face "Face name to use for list markers.") (defvar picolisp-wiki-left-floating-content-face 'picolisp-wiki-left-floating-content-face "Face name to use for left floating content.") (defvar picolisp-wiki-non-floating-content-face 'picolisp-wiki-non-floating-content-face "Face name to use for non floating content.") (defvar picolisp-wiki-right-floating-content-face 'picolisp-wiki-right-floating-content-face "Face name to use for right floating content.") (defvar picolisp-wiki-pre-face 'picolisp-wiki-pre-face "Face name to use for preformatted text.") (defvar picolisp-wiki-link-label-face 'picolisp-wiki-link-label-face "Face name to use for link labels.") (defvar picolisp-wiki-url-face 'picolisp-wiki-url-face "Face name to use for URLs.") (defvar picolisp-wiki-link-title-face 'picolisp-wiki-link-title-face "Face name to use for reference link titles.") (defvar picolisp-wiki-comment-face 'picolisp-wiki-comment-face "Face name to use for HTML comments.") ;; FACE definitions (defgroup picolisp-wiki-faces nil "Faces used in Picolisp-Wiki Mode" :group 'picolisp-wiki :group 'faces) (defface picolisp-wiki-hr-face '((t (:inherit font-lock-comment-delimiter-face))) "Face for starting braces." :group 'picolisp-wiki-faces) (defface picolisp-wiki-starting-brace-face '((t (:inherit font-lock-comment-delimiter-face))) "Face for starting braces." :group 'picolisp-wiki-faces) (defface picolisp-wiki-closing-brace-face '((t (:inherit font-lock-comment-delimiter-face))) "Face for closing braces." :group 'picolisp-wiki-faces) (defface picolisp-wiki-italic-face '((t (:inherit font-lock-negation-char-face :slant italic))) "Face for italic text." :group 'picolisp-wiki-faces) (defface picolisp-wiki-bold-face '((t (:inherit font-lock-negation-char-face :weight bold))) "Face for bold text." :group 'picolisp-wiki-faces) (defface picolisp-wiki-underlined-face '((t (:inherit font-lock-negation-char-face :underline t))) "Face for underlined text." :group 'picolisp-wiki-faces) (defface picolisp-wiki-line-break-face '((t (:inherit font-lock-warning-face))) "Face for underlined text." :group 'picolisp-wiki-faces) (defface picolisp-wiki-header-face '((t (:inherit font-lock-function-name-face :weight bold))) "Base face for headers." :group 'picolisp-wiki-faces) (defface picolisp-wiki-header-face-1 '((t (:inherit picolisp-wiki-header-face))) "Face for level-1 headers." :group 'picolisp-wiki-faces) (defface picolisp-wiki-header-face-2 '((t (:inherit picolisp-wiki-header-face))) "Face for level-2 headers." :group 'picolisp-wiki-faces) (defface picolisp-wiki-header-face-3 '((t (:inherit picolisp-wiki-header-face))) "Face for level-3 headers." :group 'picolisp-wiki-faces) (defface picolisp-wiki-header-face-4 '((t (:inherit picolisp-wiki-header-face))) "Face for level-4 headers." :group 'picolisp-wiki-faces) (defface picolisp-wiki-header-face-5 '((t (:inherit picolisp-wiki-header-face))) "Face for level-5 headers." :group 'picolisp-wiki-faces) (defface picolisp-wiki-header-face-6 '((t (:inherit picolisp-wiki-header-face))) "Face for level-6 headers." :group 'picolisp-wiki-faces) (defface picolisp-wiki-list-item-face '((t (:inherit font-lock-string-face))) "Face for list item markers." :group 'picolisp-wiki-faces) (defface picolisp-wiki-pre-face '((t (:inherit font-lock-constant-face))) ;; '((t (:inherit font-lock-string-face))) "Face for preformatted text." :group 'picolisp-wiki-faces) (defface picolisp-wiki-internal-link-face '((t (:inherit font-lock-keyword-face))) "Face for internal links." :group 'picolisp-wiki-faces) (defface picolisp-wiki-external-link-face '((t (:inherit font-lock-keyword-face))) "Face for external links." :group 'picolisp-wiki-faces) (defface picolisp-wiki-url-face '((t (:inherit font-lock-string-face))) "Face for URLs." :group 'picolisp-wiki-faces) (defface picolisp-wiki-link-label-face '((t (:inherit font-lock-keyword-face))) "Face for reference link titles." :group 'picolisp-wiki-faces) (defface picolisp-wiki-comment-face '((t (:inherit font-lock-comment-face))) "Face for HTML comments." :group 'picolisp-wiki-faces) ;; REGEXP ;; FIXME consider linebreaks in pattern ;; [start] regexp by Doug Lewan (Newsgroups: gmane.emacs.help) (defconst picolisp-wiki-regex-plain-text (concat "\\([[:space:]]*[^}]+\\)[[:space:]]*" ; Matches "123$%^ Чебурашка &*(0-=" ) "Regular expression defining what 'plain text' is.") (defconst picolisp-wiki-regex-bold-text (concat "\\(!{\\)" picolisp-wiki-regex-plain-text "\\(}\\)") "Regular expression defining what 'bold text' is.") (defconst picolisp-wiki-regex-text (concat "\\(" picolisp-wiki-regex-plain-text "\\|" picolisp-wiki-regex-bold-text "\\)") "Regular expression defining what 'text'. Text is a mix of plain text and bold text.") (defconst picolisp-wiki-regex-list-item-text (concat "\\(-{\\)" picolisp-wiki-regex-text "+" "\\(}\\)") "Regular expression defining what a 'list item' is.") ;; [end] regexp by Doug Lewan (Newsgroups: gmane.emacs.help) ;; [start] testcode for regexp by Doug Lewan ;; ;; ;; ;; Sunny day test code ;; ;; ;; (defconst test-plain-text (list "foo" ;; "foo bar " ;; " foo bar baz bat" ;; " --- 123$%^ Чебурашка &*(0-= --- ")) ;; (defconst test-bold-text (mapcar (lambda (text) ;; (concat "!{" text "}")) ;; test-plain-text)) ;; (defconst test-list-item-text (mapcar (lambda (list-text) ;; (concat "-{" list-text "}")) ;; (append test-plain-text test-bold-text))) ;; (mapc (lambda (test-spec) ;; (let ((re (car test-spec)) ;; (test-data (cdr test-spec))) ;; (mapc (lambda (item) ;; (if (string-match re item) ;; (message "PASS -- [[%s]] matches [[%s]]" re item) ;; (message "FAIL -- [[%s]] DIDN'T match [[%s]]" re item)) ;; (sit-for 1)) ;; test-data))) ;; (list (cons picolisp-wiki-regex-plain-text test-plain-text) ;; (cons picolisp-wiki-regex-bold-text test-bold-text) ;; (cons picolisp-wiki-regex-list-item-text test-list-item-text))) ;; [end] testcode testcode for regexp by Doug Lewan (defconst picolisp-wiki-regex-internal-link "\\(={\\)\\([^ ]+\\)\\( \\)\\(.*\\)\\(}\\)" "Regular expression for an internal link.") (defconst picolisp-wiki-regex-external-link "\\(\\^{\\)\\([^ ]+\\)\\( \\)\\(.*\\)\\(}\\)" "Regular expression for an external link.") (defconst picolisp-wiki-regex-comment "\\(#{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for an external link.") (defconst picolisp-wiki-regex-header-1 "\\(1{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for level 1 headers.") (defconst picolisp-wiki-regex-header-2 "\\(2{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for level 2 headers.") (defconst picolisp-wiki-regex-header-3 "\\(3{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for level 3 headers.") (defconst picolisp-wiki-regex-header-4 "\\(4{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for level 4 headers.") (defconst picolisp-wiki-regex-header-5 "\\(5{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for level 5 headers.") (defconst picolisp-wiki-regex-header-6 "\\(6{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for level 6 headers.") (defconst picolisp-wiki-regex-hr "\\(--\\)+\\(---\\)*$" "Regular expression for matching Picolisp-Wiki horizontal rules.") (defconst picolisp-wiki-regex-left-floating-content "\\(<{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for matching left-floating-content.") (defconst picolisp-wiki-regex-non-floating-content "\\(@{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for matching non-floating-content.") (defconst picolisp-wiki-regex-right-floating-content "\\(>{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for matching right-floating-content.") (defconst picolisp-wiki-regex-pre-block "\\(:{\\)\\([ ]*[^}]+\\)\\(}\\)" ;; "\\(:{\\)\\([ \t\n]*[^}]+\\)\\(}\\)" ;; "\\(:{\\)\\([ ;; ][^}]+\\)\\(}\\)" "Regular expression for matching preformatted text sections.") ;; (defconst picolisp-wiki-regex-unordered-list ;; "\\(^[\\t ]*\\*{\\)\\([ ]*[ ;; ]+\\)\\(-{.*}[ ;; ]+\\)\\{1,\\}\\(}\\)" ;; "Regular expression for matching unordered list markers.") ;; (defconst picolisp-wiki-regex-ordered-list ;; "\\(^[\\t ]*\\+{\\)\\([ ]*[ ;; ]+\\)\\(-{.*}[ ;; ]+\\)\\{1,\\}\\(}\\)" ;; "Regular expression for matching ordered list markers.") ;; (defconst picolisp-wiki-regex-unordered-list-start ;; "\\(^\\*{\\)\\([ \t\n]*$\\)" ;; "Regular expression for matching the start of an unordered list.") ;; (defconst picolisp-wiki-regex-ordered-list-start ;; "\\(^\\+{\\)\\([ \t\n]*$\\)" ;; "Regular expression for matching the start of an ordered list.") (defconst picolisp-wiki-regex-starting-brace (concat "\\(\\*\\|\\+\\|-\\|&\\|/\\|_\\|\\^\\|" "<\\|>\\|@\\|!\\|=\\|:\\|#\\|1\\|2\\|" "3\\|4\\|5\\|6\\)\\({\\)") "Regular expression for matching a starting brace.") (defconst picolisp-wiki-regex-closing-brace "\\([^\\]\\)\\(}\\)" "Regular expression for matching a closing brace.") (defconst picolisp-wiki-regex-list-item "\\(-{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for matching a list item.") (defconst picolisp-wiki-regex-bold "\\(!{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for matching bold text.") (defconst picolisp-wiki-regex-italic "\\(/{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for matching italic text.") (defconst picolisp-wiki-regex-underlined "\\(_{\\)\\([ ]*[^}]+\\)\\(}\\)" "Regular expression for matching underlined text.") (defconst picolisp-wiki-regex-line-break "\\(&{\\)\\([-]?[0-9]\\)\\(}\\)" "Regular expression for matching line breaks.") (defconst picolisp-wiki-regex-wiki-link "\\[\\[\\([^]|]+\\)\\(|\\([^]]+\\)\\)?\\]\\]" "Regular expression for matching wiki links. This matches typical bracketed [[WikiLinks]] as well as 'aliased' wiki links of the form [[PageName|link text]]. In this regular expression, #1 matches the page name and #3 matches the link text.") (defconst picolisp-wiki-regex-uri (concat "\\(" (mapconcat 'identity picolisp-wiki-uri-types "\\|") "\\):[^]\t\n\r<>,;() ]+") "Regular expression for matching inline URIs.") (defconst picolisp-wiki-regex-angle-uri (concat "\\(<\\)\\(" (mapconcat 'identity picolisp-wiki-uri-types "\\|") "\\):[^]\t\n\r<>,;()]+\\(>\\)") "Regular expression for matching inline URIs in angle brackets.") (defconst picolisp-wiki-regex-email "<\\(\\sw\\|\\s_\\|\\s.\\)+@\\(\\sw\\|\\s_\\|\\s.\\)+>" "Regular expression for matching inline email addresses.") ;; Keywords (defvar picolisp-wiki-mode-font-lock-keywords-basic (list (cons picolisp-wiki-regex-header-1 '(2 picolisp-wiki-header-face-1)) (cons picolisp-wiki-regex-header-2 '(2 picolisp-wiki-header-face-2)) (cons picolisp-wiki-regex-header-3 '(2 picolisp-wiki-header-face-3)) (cons picolisp-wiki-regex-header-4 '(2 picolisp-wiki-header-face-4)) (cons picolisp-wiki-regex-header-5 '(2 picolisp-wiki-header-face-5)) (cons picolisp-wiki-regex-header-6 '(2 picolisp-wiki-header-face-6)) (cons picolisp-wiki-regex-starting-brace 'picolisp-wiki-starting-brace-face) (cons picolisp-wiki-regex-closing-brace '(2 picolisp-wiki-closing-brace-face)) (cons picolisp-wiki-regex-pre-block '(2 picolisp-wiki-pre-face)) (cons picolisp-wiki-regex-hr '(2 picolisp-wiki-hr-face)) (cons picolisp-wiki-regex-line-break '(2 picolisp-wiki-line-break-face)) (cons picolisp-wiki-regex-comment '(2 picolisp-wiki-comment-face)) (cons picolisp-wiki-regex-angle-uri '(2 picolisp-wiki-url-face)) (cons picolisp-wiki-regex-uri '(2 picolisp-wiki-url-face)) (cons picolisp-wiki-regex-email '(2 picolisp-wiki-url-face)) ;; (cons picolisp-wiki-regex-left-floating-content ;; '(2 picolisp-wiki-left-floating-content-fact)) ;; (cons picolisp-wiki-regex-non-floating-content ;; '(2 picolisp-wiki-non-floating-content-fact)) ;; (cons picolisp-wiki-regex-right-floating-content ;; '(2 picolisp-wiki-right-floating-content-fact)) (cons picolisp-wiki-regex-email '(2 picolisp-wiki-url-face)) ;; changed from picolisp-wiki-regex-list-item ;; (cons picolisp-wiki-regex-list-item '(2 picolisp-wiki-list-item-face)) ;; (cons picolisp-wiki-regex-list-item-text 'picolisp-wiki-list-item-face) (cons picolisp-wiki-regex-internal-link '((2 picolisp-wiki-url-face t) (4 picolisp-wiki-internal-link-face t))) (cons picolisp-wiki-regex-external-link '((2 picolisp-wiki-url-face t) (4 picolisp-wiki-external-link-face t))) (cons picolisp-wiki-regex-bold '(2 picolisp-wiki-bold-face)) ;; (cons picolisp-wiki-regex-bold-text 'picolisp-wiki-bold-face) (cons picolisp-wiki-regex-italic '(2 picolisp-wiki-italic-face)) (cons picolisp-wiki-regex-underlined '(2 picolisp-wiki-underlined-face)) ) "Syntax highlighting for Picolisp-Wiki files.") (defvar picolisp-wiki-mode-font-lock-keywords (append picolisp-wiki-mode-font-lock-keywords-basic) "Default highlighting expressions for Picolisp-Wiki mode.") ;;; Syntax Table ============================================================== (defvar picolisp-wiki-mode-syntax-table (let ((picolisp-wiki-mode-syntax-table (make-syntax-table))) (modify-syntax-entry ?\" "w" picolisp-wiki-mode-syntax-table) picolisp-wiki-mode-syntax-table) "Syntax table for `picolisp-wiki-mode'.") ;;; Element Insertion ========================================================= (defun picolisp-wiki-wrap-or-insert (s1 s2 &optional beg-newline-p) "Insert the strings S1 and S2. If Transient Mark mode is on and a region is active, wrap the strings S1 and S2 around the region." (if (and transient-mark-mode mark-active) (let ((a (region-beginning)) (b (region-end))) (goto-char a) (insert s1) (goto-char (+ b (length s1))) (insert s2)) (if (not beg-newline-p) (insert s1 s2) (end-of-line) (newline 2) (insert s1 s2)))) (defun picolisp-wiki-insert-hr () "Insert a horizonal rule using `picolisp-wiki-hr-string'." (interactive) ;; Leading blank line (when (and (>= (point) (+ (point-min) 2)) (not (looking-back "\n\n" 2))) (insert "\n")) ;; Insert custom HR string (insert (concat picolisp-wiki-hr-string "\n")) ;; Following blank line (backward-char) (unless (looking-at "\n\n") (insert "\n"))) (defun picolisp-wiki-insert-bold () "Insert markup for a bold word or phrase. If Transient Mark mode is on and a region is active, it is made bold." (interactive) (picolisp-wiki-wrap-or-insert "!{" "}") (backward-char 1)) (defun picolisp-wiki-insert-italic () "Insert markup for an italic word or phrase. If Transient Mark mode is on and a region is active, it is made italic." (interactive) (picolisp-wiki-wrap-or-insert "/{" "}") (backward-char 1)) (defun picolisp-wiki-insert-underlined () "Insert markup for an underlined word or phrase. If Transient Mark mode is on and a region is active, it is underlined." (interactive) (picolisp-wiki-wrap-or-insert "_{" "}") (backward-char 1)) (defun picolisp-wiki-insert-pre-block () "Insert markup for a pre-formatted block. If Transient Mark mode is on and a region is active, it is marked as inline code." (interactive) (picolisp-wiki-wrap-or-insert ":{" "}") (backward-char 1)) (defun picolisp-wiki-insert-comment () "Insert markup for an comment. If Transient Mark mode is on and a region is active, it is marked as inline code." (interactive) (picolisp-wiki-wrap-or-insert "#{" "}") (backward-char 1)) (defun picolisp-wiki-insert-internal-link () "Insert an internal link. If Transient Mark mode is on and a region is active, it is used as the link text." (interactive) (picolisp-wiki-wrap-or-insert "={" "}") (backward-char 1)) (defun picolisp-wiki-insert-external-link () "Insert an external link. If Transient Mark mode is on and a region is active, it is used as the link text." (interactive) (picolisp-wiki-wrap-or-insert "^{" "}") (backward-char 1)) (defun picolisp-wiki-insert-left-floating-content () "Insert an inline image tag of the form <{content}. If Transient Mark mode is on and a region is active, it is used as the alt text of the image." (interactive) (picolisp-wiki-wrap-or-insert "<{" "}") (backward-char 1)) (defun picolisp-wiki-insert-non-floating-content () "Insert an inline image tag of the form @{content}. If Transient Mark mode is on and a region is active, it is used as the alt text of the image." (interactive) (picolisp-wiki-wrap-or-insert "@{" "}") (backward-char 1)) (defun picolisp-wiki-insert-right-floating-content () "Insert an inline image tag of the form >{content}. If Transient Mark mode is on and a region is active, it is used as the alt text of the image." (interactive) (picolisp-wiki-wrap-or-insert ">{" "}") (backward-char 1)) (defun picolisp-wiki-insert-line-breaks (n) "Insert line-breaks. With no prefix argument, insert 1 line-break. With prefix N, insert N line-breaks. With prefix N, insert N line-breaks. With negative prefix -N, insert N line-breaks and clear float style." (interactive "p") (unless n ; Test to see if n is defined (setq n 1)) ; Default to level 1 header (insert (format "&{%d}" n ))) (defun picolisp-wiki-insert-unordered-list () "Insert an unordered list. If Transient Mark mode is on and a region is active, it is wrapped in an unordered list (the region should only contain list-items)." (interactive) (end-of-line) (newline) (insert "*{") (newline) (insert " -{}") (newline) (insert "}") (newline) (search-backward "-{" nil t 1) (forward-char 2)) (defun picolisp-wiki-insert-ordered-list () "Insert an ordered list. If Transient Mark mode is on and a region is active, it is wrapped in an ordered list (the region should only contain list-items)." (interactive) (end-of-line) (newline) (insert "+{") (newline) (insert " -{}") (newline) (insert "}") (newline) (search-backward "-{" nil t 1) (forward-char 2)) ;; FIXME consider escaped braces '\{'and '\}' inside list items (defun picolisp-wiki--inside-list-item-p (&optional second-trial-p) "Return t if inside list-item, nil otherwise. This function takes care of the (common) case when there is one nested markup inside the list item, e.g. a link or a bold text, and point is inside the nested markup braces." (save-excursion (let ((pt (point))) (search-backward "{" nil t 1) (backward-char) (if (not (looking-at "-{")) (if (and (not second-trial-p) (looking-at (concat "\\(\\*\\|\\+\\|&\\|/\\|_\\|\\^\\|" "<\\|>\\|@\\|!\\|=\\|:\\|#\\)\\({\\)"))) (picolisp-wiki--inside-list-item-p 'SECOND-TRIAL-P) nil) (and (if second-trial-p (search-forward-regexp "}[^}]*}" nil t 1) (search-forward "}" nil t 1)) (setq item-end (point)) (> item-end pt)))))) (defun picolisp-wiki-insert-list-item () "Insert a list-item. If Transient Mark mode is on and a region is active, it becomes the text of a list item." (interactive) (if (not (picolisp-wiki--inside-list-item-p)) (progn (picolisp-wiki-wrap-or-insert "-{" "}") (backward-char 1)) (end-of-line) (newline) (insert " -{}") (backward-char 1) )) (defun picolisp-wiki-insert-header-1 () "Insert a first level picolisp-wiki-style header. If Transient Mark mode is on and a region is active, it is used as the header text." (interactive) (picolisp-wiki-insert-header 1)) (defun picolisp-wiki-insert-header-2 () "Insert a second level picolisp-wiki-style header. If Transient Mark mode is on and a region is active, it is used as the header text." (interactive) (picolisp-wiki-insert-header 2)) (defun picolisp-wiki-insert-header-3 () "Insert a third level picolisp-wiki-style header. If Transient Mark mode is on and a region is active, it is used as the header text." (interactive) (picolisp-wiki-insert-header 3)) (defun picolisp-wiki-insert-header-4 () "Insert a fourth level picolisp-wiki-style header. If Transient Mark mode is on and a region is active, it is used as the header text." (interactive) (picolisp-wiki-insert-header 4)) (defun picolisp-wiki-insert-header-5 () "Insert a fifth level picolisp-wiki-style header. If Transient Mark mode is on and a region is active, it is used as the header text." (interactive) (picolisp-wiki-insert-header 5)) (defun picolisp-wiki-insert-header-6 () "Insert a sixth level picolisp-wiki-style header. If Transient Mark mode is on and a region is active, it is used as the header text." (interactive) (picolisp-wiki-insert-header 6)) (defun picolisp-wiki-insert-header (n) "Insert an picolisp-wiki-style header. With no prefix argument, insert a level-1 header. With prefix N, insert a level-N header. If Transient Mark mode is on and the region is active, it is used as the header text." (interactive "p") (unless n ; Test to see if n is defined (setq n 1)) ; Default to level 1 header (picolisp-wiki-wrap-or-insert (concat (number-to-string n) "{") "}" 'BEG-NEWLINE-P) (backward-char 1)) ;;; Keymap ==================================================================== (defvar picolisp-wiki-mode-map (let ((map (make-keymap))) ;; Element insertion (define-key map "\C-c\C-ln" 'picolisp-wiki-insert-internal-link) (define-key map "\C-c\C-lx" 'picolisp-wiki-insert-external-link) (define-key map "\C-c\C-lu" 'picolisp-wiki-insert-unordered-list) (define-key map "\C-c\C-lo" 'picolisp-wiki-insert-ordered-list) (define-key map "\C-c\C-li" 'picolisp-wiki-insert-list-item) (define-key map "\C-c\C-fl" 'picolisp-wiki-insert-left-floating-content) (define-key map "\C-c\C-fn" 'picolisp-wiki-insert-non-floating-content) (define-key map "\C-c\C-fr" 'picolisp-wiki-insert-right-floating-content) (define-key map "\C-c\C-ck" 'picolisp-wiki-insert-line-breaks) (define-key map "\C-c\C-c1" 'picolisp-wiki-insert-header-1) (define-key map "\C-c\C-c2" 'picolisp-wiki-insert-header-2) (define-key map "\C-c\C-c3" 'picolisp-wiki-insert-header-3) (define-key map "\C-c\C-c4" 'picolisp-wiki-insert-header-4) (define-key map "\C-c\C-c5" 'picolisp-wiki-insert-header-5) (define-key map "\C-c\C-c6" 'picolisp-wiki-insert-header-6) (define-key map "\C-c\C-cb" 'picolisp-wiki-insert-bold) (define-key map "\C-c\C-ci" 'picolisp-wiki-insert-italic) (define-key map "\C-c\C-cu" 'picolisp-wiki-insert-underlined) (define-key map "\C-c\C-cp" 'picolisp-wiki-insert-pre-block) (define-key map "\C-c\C-cc" 'picolisp-wiki-insert-comment) (define-key map "\C-c\C-c-" 'picolisp-wiki-insert-hr) ;; Visibility cycling (define-key map (kbd "<tab>") 'picolisp-wiki-cycle) (define-key map (kbd "<S-iso-lefttab>") 'picolisp-wiki-shifttab) ;; Header navigation (define-key map (kbd "C-M-n") 'outline-next-visible-heading) (define-key map (kbd "C-M-p") 'outline-previous-visible-heading) (define-key map (kbd "C-M-f") 'outline-forward-same-level) (define-key map (kbd "C-M-b") 'outline-backward-same-level) (define-key map (kbd "C-M-u") 'outline-up-heading) ;; Picolisp-Wiki functions ;; (define-key map "\C-c\C-cm" 'picolisp-wiki) ;; (define-key map "\C-c\C-cp" 'picolisp-wiki-preview) ;; (define-key map "\C-c\C-ce" 'picolisp-wiki-export) ;; (define-key map "\C-c\C-cv" 'picolisp-wiki-export-and-view) map) "Keymap for Picolisp-Wiki major mode.") ;;; Menu ================================================================== (easy-menu-define picolisp-wiki-mode-menu picolisp-wiki-mode-map "Menu for Picolisp-Wiki mode" '("Picolisp-Wiki" ("Show/Hide" ["Cycle visibility" picolisp-wiki-cycle (outline-on-heading-p)] ["Cycle global visibility" picolisp-wiki-shifttab]) "---" ("Headers" ["First level" picolisp-wiki-insert-header-1] ["Second level" picolisp-wiki-insert-header-2] ["Third level" picolisp-wiki-insert-header-3] ["Fourth level" picolisp-wiki-insert-header-4] ["Fifth level" picolisp-wiki-insert-header-5] ["Sixth level" picolisp-wiki-insert-header-6]) "---" ["Bold" picolisp-wiki-insert-bold] ["Italic" picolisp-wiki-insert-italic] ["Underlined" picolisp-wiki-insert-underlined] ["Preformatted" picolisp-wiki-insert-pre-block] ["Comment" picolisp-wiki-insert-comment] ["Insert horizontal rule" picolisp-wiki-insert-hr] "---" ["Insert internal link" picolisp-wiki-insert-internal-link] ["Insert external link" picolisp-wiki-insert-external-link] "---" ["Insert left-floating content" picolisp-wiki-insert-left-floating-content] ["Insert non-floating content" picolisp-wiki-insert-non-floating-content] ["Insert right-floating content" picolisp-wiki-insert-right-floating-content] "---" ["Insert unordered list" picolisp-wiki-insert-unordered-list] ["Insert ordered list" picolisp-wiki-insert-ordered-list] "---" ["Version" picolisp-wiki-show-version] )) ;;; Outline =================================================================== ;; The following visibility cycling code was taken from org-mode ;; by Carsten Dominik and adapted for picolisp-wiki-mode. (defvar picolisp-wiki-cycle-global-status 1) (defvar picolisp-wiki-cycle-subtree-status nil) ;; Based on org-end-of-subtree from org.el (defun picolisp-wiki-end-of-subtree (&optional invisible-OK) "Move to the end of the current subtree. Only visible heading lines are considered, unless INVISIBLE-OK is non-nil." (outline-back-to-heading invisible-OK) (let ((first t) (level (funcall outline-level))) (while (and (not (eobp)) (or first (> (funcall outline-level) level))) (setq first nil) (outline-next-heading)) (if (memq (preceding-char) '(?\n ?\^M)) (progn ;; Go to end of line before heading (forward-char -1) (if (memq (preceding-char) '(?\n ?\^M)) ;; leave blank line before heading (forward-char -1))))) (point)) ;; Based on org-cycle from org.el. (defun picolisp-wiki-cycle (&optional arg) "Visibility cycling for Picolisp-Wiki mode. If ARG is t, perform global visibility cycling. If the point is at an picolisp-wiki-style header, cycle visibility of the corresponding subtree. Otherwise, insert a tab using `indent-relative'." (interactive "P") (cond ((eq arg t) ;; Global cycling (cond ((and (eq last-command this-command) (eq picolisp-wiki-cycle-global-status 2)) ;; Move from overview to contents (hide-sublevels 1) (message "CONTENTS") (setq picolisp-wiki-cycle-global-status 3)) ((and (eq last-command this-command) (eq picolisp-wiki-cycle-global-status 3)) ;; Move from contents to all (show-all) (message "SHOW ALL") (setq picolisp-wiki-cycle-global-status 1)) (t ;; Defaults to overview (hide-body) (message "OVERVIEW") (setq picolisp-wiki-cycle-global-status 2)))) ((save-excursion (beginning-of-line 1) (looking-at outline-regexp)) ;; At a heading: rotate between three different views (outline-back-to-heading) (let ((goal-column 0) eoh eol eos) ;; Determine boundaries (save-excursion (outline-back-to-heading) (save-excursion (beginning-of-line 2) (while (and (not (eobp)) ;; this is like `next-line' (get-char-property (1- (point)) 'invisible)) (beginning-of-line 2)) (setq eol (point))) (outline-end-of-heading) (setq eoh (point)) (picolisp-wiki-end-of-subtree t) (skip-chars-forward " \t\n") (beginning-of-line 1) ; in case this is an item (setq eos (1- (point)))) ;; Find out what to do next and set `this-command' (cond ((= eos eoh) ;; Nothing is hidden behind this heading (message "EMPTY ENTRY") (setq picolisp-wiki-cycle-subtree-status nil)) ((>= eol eos) ;; Entire subtree is hidden in one line: open it (show-entry) (show-children) (message "CHILDREN") (setq picolisp-wiki-cycle-subtree-status 'children)) ((and (eq last-command this-command) (eq picolisp-wiki-cycle-subtree-status 'children)) ;; We just showed the children, now show everything. (show-subtree) (message "SUBTREE") (setq picolisp-wiki-cycle-subtree-status 'subtree)) (t ;; Default action: hide the subtree. (hide-subtree) (message "FOLDED") (setq picolisp-wiki-cycle-subtree-status 'folded))))) (t (indent-for-tab-command)))) ;; Based on org-shifttab from org.el. (defun picolisp-wiki-shifttab () "Global visibility cycling. Calls `picolisp-wiki-cycle' with argument t." (interactive) (picolisp-wiki-cycle t)) ;;; Miscellaneous ============================================================= (defun picolisp-wiki-line-number-at-pos (&optional pos) "Return (narrowed) buffer line number at position POS. If POS is nil, use current buffer location. This is an exact copy of `line-number-at-pos' for use in emacs21." (let ((opoint (or pos (point))) start) (save-excursion (goto-char (point-min)) (setq start (point)) (goto-char opoint) (forward-line 0) (1+ (count-lines start (point)))))) (defun picolisp-wiki-nobreak-p () "Return nil if it is acceptable to break the current line at the point." ;; inside in square brackets (e.g., link anchor text) (looking-back "\\[[^]]*")) ;;; Mode definition ========================================================== (defun picolisp-wiki-show-version () "Show the version number in the minibuffer." (interactive) (message "picolisp-wiki-mode, version %s" picolisp-wiki-mode-version)) ;;;###autoload (define-derived-mode picolisp-wiki-mode text-mode "PicoLisp-Wiki" "Major mode for editing PicoLisp-Wiki files." ;; Natural Picolisp-Wiki tab width (setq tab-width 4) ;; Comments (make-local-variable 'comment-start) (setq comment-start "#{") (make-local-variable 'comment-end) (setq comment-end "}") ;; (make-local-variable 'comment-start-skip) ;; (setq comment-start-skip "#{ \t}*") (make-local-variable 'comment-column) (setq comment-column 0) ;; Font lock. (set (make-local-variable 'font-lock-defaults) '(picolisp-wiki-mode-font-lock-keywords)) (set (make-local-variable 'font-lock-multiline) t) ;; Make filling work with lists (unordered, ordered, and definition) ;; (set (make-local-variable 'paragraph-start) ;; "\f\\|[ \t]*$\\|^[ \t]*[*+-] \\|^[ \t*][0-9]+\\.\\|^[ \t]*: ") ;; Outline mode (make-local-variable 'eval) (setq eval (outline-minor-mode)) (make-local-variable 'outline-regexp) ;; (setq outline-regexp "^[ \t]*[0-9]{") (setq outline-regexp "^[ ]*\\(1{\\|2{.\\|3{..\\|4{...\\|5{....\\|6{.....\\)") ;; Cause use of ellipses for invisible text. (add-to-invisibility-spec '(outline . t))) (provide 'picolisp-wiki-mode) ;;; picolisp-wiki-mode.el ends here ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/el/picolisp.el������������������������������������������������������������0000644�0000000�0000000�00000073727�12265263724�016502� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;;;;; picolisp-mode: Major mode to edit picoLisp. ;;;;;; Version: 1.3 ;;; Copyright (c) 2009, Guillermo R. Palavecino ;;; Copyright (c) 2011, 2012 Thorsten Jolitz ;; This file is NOT part of GNU emacs. ;;;; Credits: ;; It's based on GNU emacs' lisp-mode and scheme-mode. ;; Some bits were taken from paredit.el ;; Two functions were copied from Xah Lee (http://xahlee.org/) ;; ;;;; Contact: ;; For comments, bug reports, questions, etc, you can contact the ;; first author via IRC to the user named grpala (or armadillo) on ;; irc.freenode.net in the #picolisp channel or via email to the ;; author's nickname at gmail.com ;; ;; Or contact the second author and curent maintainer via email: ;; t <lastname in lowercase letters> AT gmail DOT com ;; ;;;; License: ;; This work is released under the GPL 2 or (at your option) any later ;; version. (require 'lisp-mode) (defcustom picolisp-parsep t "This is to toggle picolisp-mode's multi-line s-exps closing parens separation capability." :type 'boolean :group 'picolisp ) ;; I know... this shouldn't be here, but you see, people may want to keep ;; their body-indent value unaltered and have a different one for picolisp ;; sources, so... (defcustom picolisp-body-indent 3 "Number of columns to indent the second line of a `(de ...)' form." :group 'picolisp :type 'integer ) (defvar picolisp-mode-syntax-table (let ((st (make-syntax-table)) (i 0) ) ;; Default is atom-constituent. (while (< i 256) (modify-syntax-entry i "_ " st) (setq i (1+ i)) ) ;; Word components. (setq i ?0) (while (<= i ?9) (modify-syntax-entry i "w " st) (setq i (1+ i)) ) (setq i ?A) (while (<= i ?Z) (modify-syntax-entry i "w " st) (setq i (1+ i)) ) (setq i ?a) (while (<= i ?z) (modify-syntax-entry i "w " st) (setq i (1+ i)) ) ;; Whitespace (modify-syntax-entry ?\t " " st) (modify-syntax-entry ?\n "> " st) (modify-syntax-entry ?\f " " st) (modify-syntax-entry ?\r " " st) (modify-syntax-entry ?\s " " st) ;; These characters are delimiters but otherwise undefined. ;; Brackets and braces balance for editing convenience. (modify-syntax-entry ?\[ "(] " st) (modify-syntax-entry ?\] ")[ " st) (modify-syntax-entry ?{ "(} " st) (modify-syntax-entry ?} "){ " st) ;; Other atom delimiters (modify-syntax-entry ?\( "() " st) (modify-syntax-entry ?\) ")( " st) ;; It's used for single-line comments. (modify-syntax-entry ?# "< " st) (modify-syntax-entry ?\" "\" " st) (modify-syntax-entry ?' "' " st) (modify-syntax-entry ?` "' " st) (modify-syntax-entry ?~ "' " st) ;; Special characters (modify-syntax-entry ?, "' " st) (modify-syntax-entry ?\\ "\\ " st) st ) ) (defvar picolisp-mode-abbrev-table nil) (define-abbrev-table 'picolisp-mode-abbrev-table ()) (defun picolisp-mode-variables () (set-syntax-table picolisp-mode-syntax-table) ;;(setq local-abbrev-table picolisp-mode-abbrev-table) (make-local-variable 'paragraph-start) (setq paragraph-start (concat "$\\|" page-delimiter)) ;;(setq comint-input-ring-file-name "~/.pil_history") (make-local-variable 'paragraph-separate) (setq paragraph-separate paragraph-start) (make-local-variable 'paragraph-ignore-fill-prefix) (setq paragraph-ignore-fill-prefix t) (make-local-variable 'fill-paragraph-function) (setq fill-paragraph-function 'lisp-fill-paragraph) ;; Adaptive fill mode gets in the way of auto-fill, ;; and should make no difference for explicit fill ;; because lisp-fill-paragraph should do the job. (make-local-variable 'adaptive-fill-mode) (setq adaptive-fill-mode nil) (make-local-variable 'normal-auto-fill-function) (setq normal-auto-fill-function 'lisp-mode-auto-fill) (make-local-variable 'indent-line-function) (setq indent-line-function 'picolisp-indent-line) (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments t) (make-local-variable 'comment-start) (setq comment-start "#") (set (make-local-variable 'comment-add) 1) (make-local-variable 'comment-start-skip) ;; Look within the line for a # following an even number of backslashes ;; after either a non-backslash or the line beginning. (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)#+[ \t]*"); ((^|[^\n])(\\\\)*)#+[ t]* (set (make-local-variable 'font-lock-comment-start-skip) "#+ *") (make-local-variable 'comment-column) (setq comment-column 40) (make-local-variable 'parse-sexp-ignore-comments) (setq parse-sexp-ignore-comments t) (make-local-variable 'lisp-indent-function) (setq lisp-indent-function 'picolisp-indent-function) ;; This is just to avoid tabsize-variations fuck-up. (make-local-variable 'indent-tabs-mode) (setq indent-tabs-mode) (setq dabbrev-case-fold-search t) (setq dabbrev-case-replace nil) (setq mode-line-process '("" picolisp-mode-line-process)) (set (make-local-variable 'font-lock-defaults) '((picolisp-font-lock-keywords picolisp-font-lock-keywords-1 picolisp-font-lock-keywords-2 ) nil t (("+-*/.<>=!?$%_&~^:" . "w")) beginning-of-defun (font-lock-mark-block-function . mark-defun) (font-lock-keywords-case-fold-search . nil) (parse-sexp-lookup-properties . t) (font-lock-extra-managed-props syntax-table) ) ) (set (make-local-variable 'lisp-doc-string-elt-property) 'picolisp-doc-string-elt ) ) (defvar picolisp-mode-line-process "") (defvar picolisp-mode-map (let ((map (make-sparse-keymap "Picolisp"))) (set-keymap-parent map lisp-mode-shared-map) ;; more convenient than "C-ck" (define-key map "\C-c\C-v" 'picolisp-edit-K) ;; more convenient than "C-cq" (define-key map "\C-c\C-c" 'picolisp-edit-Q) ;; not necesary: picolisp-edit-Q exits on last undo ;; (define-key map "\C-q" '(save-buffers-kill-terminal 1)) (define-key map [menu-bar picolisp] (cons "Picolisp" map)) (define-key map [run-picolisp] '("Run Inferior Picolisp" . run-picolisp)) (define-key map [uncomment-region] '("Uncomment Out Region" . (lambda (beg end) (interactive "r") (comment-region beg end '(4)) ) ) ) (define-key map [comment-region] '("Comment Out Region" . comment-region)) (define-key map [indent-region] '("Indent Region" . indent-region)) (define-key map [indent-line] '("Indent Line" . picolisp-indent-line)) (define-key map "\t" 'picolisp-indent-line) (put 'comment-region 'menu-enable 'mark-active) (put 'uncomment-region 'menu-enable 'mark-active) (put 'indent-region 'menu-enable 'mark-active) map ) "Keymap for Picolisp mode. All commands in `lisp-mode-shared-map' are inherited by this map." ) ;;;###autoload (defun picolisp-mode () "Major mode for editing Picolisp code. Editing commands are similar to those of `lisp-mode'. Commands: Delete converts tabs to spaces as it moves back. Blank lines separate paragraphs. Semicolons start comments. \\{picolisp-mode-map} Entry to this mode calls the value of `picolisp-mode-hook' if that value is non-nil." (interactive) (remove-text-properties (point-min) (point-max) '(display "")) (kill-all-local-variables) (use-local-map picolisp-mode-map) (setq major-mode 'picolisp-mode) (setq mode-name "Picolisp") (picolisp-mode-variables) (run-mode-hooks 'picolisp-mode-hook) (defun paredit-delete-leading-whitespace () (picolisp-delete-leading-whitespace) ) ) (autoload 'run-picolisp "inferior-picolisp" "Run an inferior Picolisp process, input and output via buffer `*picolisp*'. If there is a process already running in `*picolisp*', switch to that buffer. With argument, allows you to edit the command line (default is value of `picolisp-program-name'). Runs the hook `inferior-picolisp-mode-hook' \(after the `comint-mode-hook' is run). \(Type \\[describe-mode] in the process buffer for a list of commands.)" t ) (defgroup picolisp nil "Editing Picolisp code." :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) :group 'lisp ) (defcustom picolisp-mode-hook nil "Normal hook run when entering `picolisp-mode'. See `run-hooks'." :type 'hook :group 'picolisp ) (defconst picolisp-font-lock-keywords-1 (eval-when-compile (list ;; ;; Declarations. (list (concat "(" (regexp-opt '("be" "de" "dm") t) "\\>" ;; Any whitespace and declared object. "[ \t]*" "\\(\\sw+\\)?" ) '(2 font-lock-function-name-face nil t ) ) (list (concat "\\<" (regexp-opt '("NIL" "T") t) "\\>" ) '(1 font-lock-constant-face) ) (list (concat "\\<" (regexp-opt '("*OS" "*DB" "*Solo" "*PPid" "*Pid" "@" "@@" "@@@" "This" "*Dbg" "*Zap" "*Scl" "*Class" "*Dbs" "*Run" "*Hup" "*Sig1" "*Sig2" "^" "*Err" "*Msg" "*Uni" "*Led" "*Adr" "*Allow" "*Fork" "*Bye" ) t ) "\\>" ) '(1 font-lock-builtin-face) ) ;; This is so we make the point used in conses more visible '("\\<\\(\\.\\)\\>" (1 font-lock-negation-char-face)) '("(\\(====\\)\\>" (1 font-lock-negation-char-face)) (list ;; Functions that modify @ (concat "(" (regexp-opt '("prog1" "prog2" "cond" "case" "if" "if2" "ifn" "when" "unless" "and" "or" "nor" "not" "nand" "nond" "loop" "do" "while" "until" "for" "state" ) t ) "\\>" ) '(1 font-lock-preprocessor-face) ) ) ) "Subdued expressions to highlight in Picolisp modes." ) (defconst picolisp-font-lock-keywords-2 (append picolisp-font-lock-keywords-1 (eval-when-compile (list ;; Control structures. (cons (concat "(" (regexp-opt '( ;; Symbol Functions "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" ;; Property Access "put" "get" "prop" ";" "=:" ":" "::" "putl" "getl" "wipe" ; "meta" ;; Predicates "atom" "pair" "lst?" "num?" "sym?" "flg?" "sp?" "pat?" "fun?" "box?" "str?" "ext?" "bool" "not" "==" "n==" "=" "<>" "=0" "=T" "n0" "nT" "<" "<=" ">" ">=" "match" ;; Arithmetics "+" "-" "*" "/" "%" "*/" "**" "inc" "dec" ">>" "lt0" "ge0" "gt0" "abs" "bit?" "&" "|" "x|" "sqrt" "seed" "rand" "max" "min" "length" "size" "accu" "format" "pad" "oct" "hex" "fmt64" "money" ;; List Processing "car" "cdr" "caar" "cadr" "cdar" "cddr" "caaar" "caadr" "cadar" "caddr" "cdaar" "cdadr" "cddar" "cdddr" "cadddr" "cddddr" "nth" "con" "cons" "conc" "circ" "rot" "list" "need" "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" "assoc" "asoq" "rank" "sort" "uniq" "group" "length" "size" "val" "set" "xchg" "push" "push1" "pop" "cut" "queue" "fifo" "idx" "balance" "get" "fill" "apply" "range" ;; Control Flow "load" "args" "next" "arg" "rest" "pass" "quote" "as" "pid" "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" "xor" "bool" "nil" "t" "prog" "at" "catch" "throw" "finally" "!" "e" "$" "sys" "call" "tick" "ipid" "opid" "kill" "quit" "task" "fork" "pipe" "later" "timeout" "abort" "bye" ;; Mapping "apply" "pass" "maps" "map" "mapc" "maplist" "mapcar" "mapcon" "mapcan" "filter" "extract" "seek" "find" "pick" "cnt" "sum" "maxi" "mini" "fish" "by" ;; Input/Output "path" "in" "ipid" "out" "opid" "pipe" "ctl" "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" "rpc" "wait" "sync" "echo" "info" "file" "dir" "lines" "open" "close" "port" "listen" "accept" "host" "connect" "nagle" "udp" "script" "once" "rc" "pretty" "pp" "show" "view" "here" "prEval" "mail" ;; Object Orientation "*Class" "class" "dm" "rel" "var" "var:" "new" "type" "isa" "method" "meth" "send" "try" "object" "extend" "super" "extra" "with" "This" ;; Database "pool" "journal" "id" "seq" "lieu" "lock" "begin" "commit" "rollback" "mark" "free" "dbck" "rel" "dbs" "dbs+" "db:" "fmt64" "tree" "root" "fetch" "store" "count" "leaf" "minKey" "maxKey" "genKey" "useKey" "init" "step" "scan" "iter" "prune" "zapTree" "chkTree" "db" "aux" "collect" ;; Pilog "goal" "prove" "->" "unify" "?" ;; Debugging "pretty" "pp" "show" "loc" "debug" "vi" "ld" "trace" "lint" "lintAll" "fmt64" ;; System Functions "cmd" "argv" "opt" "gc" "raw" "alarm" "protect" "heap" "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" "call" "tick" "kill" "quit" "task" "fork" "pipe" "timeout" "mail" "test" "bye" ) t ) "\\>" ) 1 ) ) ) ) "Gaudy expressions to highlight in Picolisp modes." ) (defvar picolisp-font-lock-keywords picolisp-font-lock-keywords-1 "Default expressions to highlight in Picolisp modes." ) (defconst picolisp-sexp-comment-syntax-table (let ((st (make-syntax-table picolisp-mode-syntax-table))) (modify-syntax-entry ?\n " " st) (modify-syntax-entry ?# "." st) st ) ) (put 'lambda 'picolisp-doc-string-elt 2) ;; Docstring's pos in a `define' depends on whether it's a var or fun def. (put 'define 'picolisp-doc-string-elt (lambda () ;; The function is called with point right after "define". (forward-comment (point-max)) (if (eq (char-after) ?\() 2 0) ) ) ;; Indentation functions ;; Copied from lisp-indent-line, ;; because Picolisp doesn't care about how many comment chars you use. (defun picolisp-indent-line (&optional whole-exp) "Indent current line as Picolisp code. With argument, indent any additional lines of the same expression rigidly along with this one." (interactive "P") (let ((indent (calculate-lisp-indent)) shift-amt end (pos (- (point-max) (point))) (beg (progn (beginning-of-line) (point))) ) (skip-chars-forward " \t") (if (or (null indent) (looking-at "\\s<\\s<\\s<")) ;; Don't alter indentation of a ;;; comment line ;; or a line that starts in a string. (goto-char (- (point-max) pos)) (if (listp indent) (setq indent (car indent))) (setq shift-amt (- indent (current-column))) (if (zerop shift-amt) nil (delete-region beg (point)) (indent-to indent) ) ) ;; If initial point was within line's indentation, ;; position after the indentation. Else stay at same point in text. (if (> (- (point-max) pos) (point)) (goto-char (- (point-max) pos)) ) ;; If desired, shift remaining lines of expression the same amount. (and whole-exp (not (zerop shift-amt)) (save-excursion (goto-char beg) (forward-sexp 1) (setq end (point)) (goto-char beg) (forward-line 1) (setq beg (point)) (> end beg) ) (indent-code-rigidly beg end shift-amt) ) ) ) (defvar calculate-lisp-indent-last-sexp) ;; Copied from lisp-indent-function, but with gets of ;; picolisp-indent-{function,hook}, and minor modifications. (defun picolisp-indent-function (indent-point state) (picolisp-parensep) (let ((normal-indent (current-column))) (goto-char (1+ (elt state 1))) (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) (if (and (elt state 2) (not (looking-at "\"?\\sw\\|\\s_")) ) ;; car of form doesn't seem to be a symbol (progn (if (not (> (save-excursion (forward-line 1) (point)) calculate-lisp-indent-last-sexp ) ) (progn (goto-char calculate-lisp-indent-last-sexp) (beginning-of-line) (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t ) ) ) ;; Indent under the list or under the first sexp on the same ;; line as calculate-lisp-indent-last-sexp. Note that first ;; thing on that line has to be complete sexp since we are ;; inside the innermost containing sexp. (backward-prefix-chars) (current-column) ) (let* ((function (buffer-substring (point) (progn (forward-sexp 1) (point)) ) ) (method (or (get (intern-soft function) 'picolisp-indent-function) (get (intern-soft function) 'picolisp-indent-hook) ;;(and picolisp-indent-style 'picolisp-indent-defform) 'picolisp-indent ) ) ) (if (integerp method) (lisp-indent-specform method state indent-point normal-indent) (funcall (if (save-excursion (let ((state9 (reverse (elt state 9)))) (when (cadr state9) (goto-char (+ 1 (cadr (reverse (elt state 9))))) (and (looking-at "let\\|use") (save-excursion (forward-sexp) (forward-sexp) (backward-sexp) (when (equal (point) (car state9)) (looking-at "(") ) ) ) ) ) ) 'picolisp-indent-let method ) state indent-point normal-indent ) ) ) ) ) ) ;;; Some functions are different in picoLisp (defun picolisp-indent (state indent-point normal-indent) (let ((lisp-body-indent picolisp-body-indent)) (lisp-indent-defform state indent-point) ) ) (defun picolisp-indent-let (state indent-point normal-indent) (goto-char (cadr state)) (forward-line 1) (if (> (point) (elt state 2)) (progn (goto-char (car (cdr state))) (+ 1 (current-column)) ) ) ) ;;; This is to space closing parens when they close a previous line. (defun picolisp-parensep () (save-excursion (condition-case nil ; This is to avoid fuck-ups when there are (progn ; unbalanced expressions. (up-list) (back-to-indentation) (while (and (re-search-forward ")" (line-end-position) t) (< (point) (line-end-position)) ) (if (and (not (picolisp-in-comment-p)) (not (picolisp-in-string-p)) ) (picolisp-delete-leading-whitespace) ) ) (if (and (not (picolisp-in-comment-p)) (not (picolisp-in-string-p)) ) (picolisp-delete-leading-whitespace) ) ) (error nil) ) ) ) (defun picolisp-delete-leading-whitespace () ;; This assumes that we're on the closing delimiter already. (save-excursion (backward-char) (while (let ((syn (char-syntax (char-before)))) (and (or (eq syn ?\ ) (eq syn ?-)) ; whitespace syntax ;; The above line is a perfect example of why the ;; following test is necessary. (not (picolisp-in-char-p (1- (point)))) ) ) (backward-delete-char 1) ) ) (when (and (equal 'picolisp-mode major-mode) ; We don't want to screw-up ; the formatting of other buffers making ; use of paredit, do we? (not (picolisp-in-string-p)) ) (let ((another-line? (save-excursion (backward-sexp) (line-number-at-pos) ) ) ) (if (< another-line? (line-number-at-pos)) (save-excursion (backward-char) (when picolisp-parsep (insert " ") ) ) ) ) ) ) ;; Parser functions (defun picolisp-current-parse-state () "Return parse state of point from beginning of defun." (let ((point (point))) (beginning-of-defun) ;; Calling PARSE-PARTIAL-SEXP will advance the point to its second ;; argument (unless parsing stops due to an error, but we assume it ;; won't in picolisp-mode). (parse-partial-sexp (point) point) ) ) (defun picolisp-in-string-p (&optional state) "True if the parse state is within a double-quote-delimited string. If no parse state is supplied, compute one from the beginning of the defun to the point." ;; 3. non-nil if inside a string (the terminator character, really) (and (nth 3 (or state (picolisp-current-parse-state))) t ) ) (defun picolisp-in-comment-p (&optional state) "True if parse state STATE is within a comment. If no parse state is supplied, compute one from the beginning of the defun to the point." ;; 4. nil if outside a comment, t if inside a non-nestable comment, ;; else an integer (the current comment nesting) (and (nth 4 (or state (picolisp-current-parse-state))) t ) ) (defun picolisp-in-char-p (&optional argument) "True if the point is immediately after a character literal. A preceding escape character, not preceded by another escape character, is considered a character literal prefix. (This works for elisp, Common Lisp, and Scheme.) Assumes that `picolisp-in-string-p' is false, so that it need not handle long sequences of preceding backslashes in string escapes. (This assumes some other leading character token -- ? in elisp, # in Scheme and Common Lisp.)" (let ((argument (or argument (point)))) (and (eq (char-before argument) ?\\) (not (eq (char-before (1- argument)) ?\\)) ) ) ) (add-to-list 'auto-mode-alist '("\\.l$" . picolisp-mode)) ;; The following two functions implement the K and Q (macro) ;; functionality used in Vi while editing a buffer opened from the ;; PicoLisp command-line with the 'edit' function. (defun picolisp-edit-K () "Write symbol at point with line number in last line of edit-buffer. If the symbol is a transient symbol, write it with double-quotes, otherwise as unquoted word. The output-format is: \(<line-number> <symbol>\) e.g. \(50 edit\) \(56 \"edit\"\) when point is on the edit or \(transient\) \"edit\" symbol in the PicoLisp sourcefile edit.l and `picolisp-edit-K' is called (the line-numbers may be different in your version of edit.l). Recognition of transient symbols works by getting the text-property 'face' at point and checking if it is equal to 'font-lock-string-face'. Thus, this function works correctly only if the edit-buffer is in an Emacs major-mode that fontifies strings with 'font-lock-string-face' \(like `picolisp-mode' does\)." (interactive) (save-excursion (save-restriction (widen) (unless (mark 'FORCE) (forward-word) (forward-word -1) (mark-word)) (let* ((thing (thing-at-point 'word)) (unit (get-selection-or-unit 'word)) (line (line-number-at-pos)) (transient-p (string-equal (get-text-property (point) 'face) "font-lock-string-face")) (k-list nil)) (setq k-list (list line (if transient-p (elt unit 0) (make-symbol (elt unit 0))))) (message "K-list: %S transient: %S" k-list transient-p) (goto-char (max-char)) (newline) (insert (format "%S" k-list)) (save-buffers-kill-terminal 1))))) (defun picolisp-edit-Q () "Write '(0)' in last line of PicoLisp edit-buffer." (interactive) (save-excursion (save-restriction (widen) (goto-char (max-char)) (newline) (insert "(0)") (save-buffers-kill-terminal 1)))) ;; The following two functions have been written by Xah Lee and copied ;; from: http://ergoemacs.org/emacs/elisp_get-selection-or-unit.html (defun get-selection-or-unit (unit) "Return the string and boundary of text selection or UNIT under cursor. If `region-active-p' is true, then the region is the unit. Else, it depends on the UNIT. See `unit-at-cursor' for detail about UNIT. Returns a vector [text a b], where text is the string and a and b are its boundary. Example usage: (setq bds (get-selection-or-unit 'line)) (setq inputstr (elt bds 0) p1 (elt bds 1) p2 (elt bds 2) )" (interactive) (let ((p1 (region-beginning)) (p2 (region-end))) (if (region-active-p) (vector (buffer-substring-no-properties p1 p2) p1 p2 ) (unit-at-cursor unit) ) ) ) ;; This function get-selection-or-unit gets you the text selection if ;; there's one. If not, it calls unit-at-cursor. unit-at-cursor (defun unit-at-cursor (unit) "Return the string and boundary of UNIT under cursor. Returns a vector [text a b], where text is the string and a and b are its boundary. UNIT can be: • 'word — sequence of 0 to 9, A to Z, a to z, and hyphen. • 'glyphs — sequence of visible glyphs. Useful for file name, URL, …, that doesn't have spaces in it. • 'line — delimited by “\\n”. • 'block — delimited by “\\n\\n” or beginning/end of buffer. • 'buffer — whole buffer. (respects `narrow-to-region') • a vector [beginRegex endRegex] — The elements are regex strings used to determine the beginning/end of boundary chars. They are passed to `skip-chars-backward' and `skip-chars-forward'. For example, if you want paren as delimiter, use [\"^(\" \"^)\"] Example usage: (setq bds (unit-at-cursor 'line)) (setq myText (elt bds 0) p1 (elt bds 1) p2 (elt bds 2) ) This function is similar to `thing-at-point' and `bounds-of-thing-at-point'. The main differences are: • this function returns the text and the 2 boundaries as a vector in one shot. • 'line always returns the line without end of line character, avoiding inconsistency when the line is at end of buffer. • 'word does not depend on syntax table. • 'block does not depend on syntax table." (let (p1 p2) (save-excursion (cond ( (eq unit 'word) (let ((wordcharset "-A-Za-zÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ")) (skip-chars-backward wordcharset) (setq p1 (point)) (skip-chars-forward wordcharset) (setq p2 (point))) ) ( (eq unit 'glyphs) (progn (skip-chars-backward "[:graph:]") (setq p1 (point)) (skip-chars-forward "[:graph:]") (setq p2 (point))) ) ( (eq unit 'buffer) (progn (setq p1 (point-min)) (setq p2 (point-max)) ) ) ((eq unit 'line) (progn (setq p1 (line-beginning-position)) (setq p2 (line-end-position)))) ((eq unit 'block) (progn (if (re-search-backward "\n\n" nil t) (progn (forward-char 2) (setq p1 (point) ) ) (setq p1 (line-beginning-position) ) ) (if (re-search-forward "\n\n" nil t) (progn (backward-char) (setq p2 (point) )) (setq p2 (line-end-position) ) ) )) ((vectorp unit) (let (p0) (setq p0 (point)) (skip-chars-backward (elt unit 0)) (setq p1 (point)) (goto-char p0) (skip-chars-forward (elt unit 1)) (setq p2 (point)))) ) ) (vector (buffer-substring-no-properties p1 p2) p1 p2 ) ) ) ;; tsm-mode (require 'tsm) (ignore-errors (when tsm-lock (font-lock-add-keywords 'picolisp-mode tsm-lock) (font-lock-add-keywords 'inferior-picolisp-mode tsm-lock) ) ) (provide 'picolisp) �����������������������������������������picolisp-3.1.5.2.orig/lib/el/tsm.el�����������������������������������������������������������������0000644�0000000�0000000�00000011005�12265263724�015440� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;;;;; tsm-mode: Minor mode to display transient symbols in picolisp-mode. ;;;;;; Version: 1.0 ;;; Copyright (c) 2009, Guillermo R. Palavecino ;; This file is NOT part of GNU emacs. ;;;; Contact: ;; For comments, bug reports, questions, etc, you can contact me via IRC ;; to the user named grpala (or armadillo) on irc.freenode.net in the ;; #picolisp channel or via email to the author's nickname at gmail.com ;; ;;;; License: ;; This work is released under the GPL 2 or (at your option) any later ;; version. (defvar tsm-face 'tsm-face) (defface tsm-face '((((class color)) (:inherit font-lock-string-face :underline t) ) ) "Face for displaying transient symbols in picolisp-mode" :group 'faces ) (defun tsm-revert (beg end) (remove-text-properties beg end '(display "")) (remove-text-properties beg end '(face tsm-face)) ) (defvar tsm-regex "\"") ;;; Sorry, but the following 3 function definitions are write-only for now. (defun find-opening-dblquote () (catch 'return (while (re-search-forward "\\(\"\\)" (line-end-position) t) (when (save-excursion (and (ignore-errors (match-beginning 1)) (not (progn (goto-char (match-beginning 1)) (picolisp-in-string-p) ) ) (progn (forward-char) (picolisp-in-string-p) ) ) ) (throw 'return (point)) ) ) (backward-char) ) ) (defun find-closing-dblquote () (catch 'return (while (re-search-forward "\\(\"\\)" (line-end-position) t) (when (save-excursion (and (ignore-errors (match-beginning 1)) (progn (goto-char (match-beginning 1)) (picolisp-in-string-p) ) (not (progn (forward-char) (picolisp-in-string-p) ) ) ) ) (throw 'return (point)) ) ) ) ) (defun tsm-line () (while (and (find-opening-dblquote) (save-excursion (find-closing-dblquote)) ) (let ((opening (point)) (closing (find-closing-dblquote)) ) (add-text-properties (1- opening) opening '(display "")) (add-text-properties (1- closing) closing '(display "")) (add-text-properties (1- opening) closing '(face tsm-face)) (dotimes (i (- closing opening 1)) (let ((i (+ i opening))) (when (and (eq 92 (char-before i)) (eq 34 (char-before (1+ i))) ) (add-text-properties (1- i) i '(display "")) ) ) ) ) ) ) (defun tsm-change (beg end) (save-excursion (goto-char beg) (while (re-search-forward "^.*\"" (save-excursion (goto-char end) (line-end-position) ) t ) (beginning-of-line) (tsm-revert (line-beginning-position) (line-end-position)) (tsm-line) ) ) ) (defvar tsm-lock '(("\"" (0 (when tsm-mode (setq global-disable-point-adjustment t) (save-excursion (beginning-of-line) (remove-text-properties (line-beginning-position) (line-end-position) '(display "")) (tsm-line) ) nil ) ) ) ) ) ;;;###autoload (define-minor-mode tsm-mode "Minor mode to display transient symbols like in the terminal repl in picolisp-mode." :group 'tsm :lighter " *Tsm" (save-excursion (save-restriction (widen) ;; We erase all the properties to avoid problems. (tsm-revert (point-min) (point-max)) (if tsm-mode (progn (if (not (and (not font-lock-mode) (not global-font-lock-mode))) (font-lock-add-keywords major-mode tsm-lock) (jit-lock-register 'tsm-change) (remove-hook 'after-change-functions 'font-lock-after-change-function t ) (set (make-local-variable 'font-lock-fontified) t) ;; Tell jit-lock how we extend the region to refontify. (add-hook 'jit-lock-after-change-extend-region-functions 'font-lock-extend-jit-lock-region-after-change nil t ) ) (setq global-disable-point-adjustment t) ) (progn (if (and (not font-lock-mode) (not global-font-lock-mode)) (jit-lock-unregister 'tsm-change) (font-lock-remove-keywords major-mode tsm-lock) ) (setq global-disable-point-adjustment nil) ) ) (if font-lock-mode (font-lock-fontify-buffer)) ) ) ) ;;; Announce (provide 'tsm) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/eled.l��������������������������������������������������������������������0000644�0000000�0000000�00000054512�12265263724�015013� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 29nov12tj # Authors Thorsten Jolitz, Alexander Burger # (c) Software Lab. Alexander Burger # Line editor # emacs-mode (mapc undef '(*Led fkey revise) ) (setq "Line" NIL # Holds current input line "LPos" 1 # Position in line (1 .. length) "HPos" 1 # Position in history "UndoLine" NIL # Undo "UndoPos" 0 "Line1" NIL # Initial line "Insert" T # Insert mode flag "FKey" NIL # Function key bindings "Clip" NIL # Cut/Copy/Paste buffer "Item" NIL # Item to find "Found" NIL # Find stack "Complete" NIL # Input completion "Mark" NIL # Position of the mark "Register" NIL # Storage for text snippets "HistMax" 1000 # History limit *History # History of input lines (in (pack "+" (pil "history")) (ctl NIL (make (until (eof) (link (line T)))) ) ) "Hist0" *History ) # Switch Crtl-C off # Ctrl-C is actually not defined as a special key, but as a signal # handler. Depending on the 'stty' settings, a SIGINT signal is sent to # the process when Ctrl-C is pressed. # # If this is not desired, then some other key (or none) must be set in the # terminal settings. This can be done with # # $ stty intr ^A # # or, from inside PicoLisp # # (call 'stty "intr" "^A") (raw T) (call 'stty "intr" "^R") # ^R as replacement for ^C # Basic editing routine (de chgLine (L N) (let (D (length "Line") Tsm) (for (P (dec "LPos") (>= P 1) (dec P)) # To start of old line (unless (and *Tsm (= "\"" (get "Line" P)) (skipQ "LPos" P "Line") ) (prin "^H") ) ) (for (P . C) (setq "Line" L) # Output new line (cond ((> " " C) (dec 'D) (prin "_") ) ((or (not *Tsm) (<> "\"" C) (escQ P L)) (dec 'D) (prin C) ) (T (prin (and Tsm (cdr *Tsm)) (unless (skipQ N P L) (dec 'D) C ) (and (onOff Tsm) (car *Tsm)) ) ) ) ) (and Tsm (prin (cdr *Tsm))) (space D) # Clear rest of old line (do D (prin "^H")) (setq "LPos" (inc (length L))) (until (= N "LPos") # To new position (unless (and *Tsm (= "\"" (get "Line" "LPos")) (skipQ N "LPos" "Line") ) (prin "^H") ) (dec '"LPos") ) ) (flush) ) # Skipped double quote (de skipQ (N P L) (nor (>= (inc N) P (dec N)) (= "\"" (get L (dec P))) (= "\"" (get L (inc P))) (escQ P L) ) ) # Escaped double quote (de escQ () (let Esc NIL (for I (dec P) ((if (= "\\" (get L I)) onOff off) Esc) ) ) ) # Check for delimiter (de delim? (C) (member C '`(chop '" ^I^J^M\"'()[]`~-")) ) # dash added for emacs-style # Move left (de lMove () (chgLine "Line" (max 1 (dec "LPos"))) ) # Move to beginning (de bMove () (chgLine "Line" 1) ) # Move right (de rMove (F) (chgLine "Line" (min (inc "LPos") (if F (inc (length "Line")) (length "Line") ) ) ) ) # Move to end of line (de eMove () (chgLine "Line" (length "Line")) ) # Move beyond end of line (de xMove () (chgLine "Line" (inc (length "Line"))) ) # Move up (de uMove () (when (< "HPos" (length *History)) (setHist (inc "HPos")) ) ) # Move down (de dMove () (unless (=0 "HPos") (setHist (dec "HPos")) ) ) # Move word left (de lWord () (use (N L) (chgLine "Line" (if (>= 1 (setq N "LPos")) 1 (loop (T (= 1 (dec 'N)) 1) (setq L (nth "Line" (dec N))) (T (and (delim? (car L)) (not (delim? (cadr L)))) N ) ) ) ) ) ) # Move word right # M (Line-lenght) N (Line-positon) L (Line-tail) (de rWord () (use (M N L) (setq M (length "Line")) (chgLine "Line" (if (<= M (setq N "LPos")) (inc M) (loop (T (= M (inc 'N)) (if (delim? (get "Line" N)) M (inc M)) ) (setq L (nth "Line" (dec N))) (T (and (delim? (cadr L)) (not (delim? (car L)))) N ) ) ) ) ) ) # Match left parenthesis (de lPar () (let (N 1 I (dec "LPos")) (loop (T (=0 I)) (case (get "Line" I) (")" (inc 'N)) ("(" (dec 'N)) ) (T (=0 N) (chgLine "Line" I)) (dec 'I) ) ) ) # Match right parenthesis (de rPar () (let (N 1 I (inc "LPos")) (loop (T (> I (length "Line"))) (case (get "Line" I) ("(" (inc 'N)) (")" (dec 'N)) ) (T (=0 N) (chgLine "Line" I)) (inc 'I) ) ) ) # Clear to end of line (de clrEol () (let N (dec "LPos") (if (=0 N) (chgLine NIL 1) (chgLine (head N "Line") N) ) ) ) # Insert a char (de insChar (C) (chgLine (insert "LPos" "Line" C) (inc "LPos")) ) (de del1 (L) (ifn (nth L "LPos") L (setq "Clip" (append "Clip" (list (get L "LPos")))) (remove "LPos" L) ) ) # Delete a char (de delChar () (use L (off "Clip") (chgLine (setq L (del1 "Line")) (max 1 (min "LPos" (length L))) ) ) ) # Delete a sexp (de delSexp () (let L "Line" (off "Clip") (if (= "(" (get L "LPos")) (for (N 1 (and (setq L (del1 L)) (< 0 N))) (case (get L "LPos") ("(" (inc 'N)) (")" (dec 'N)) ) ) ) (chgLine L (max 1 (min "LPos" (length L)))) ) ) # Delete a word (F: with trailing blank) (de delWord (F) (let L "Line" ## (off "Clip") (and (delim? (get L "LPos")) (while (and (nth L "LPos") (delim? (get L "LPos"))) (setq L (del1 L)) ) ) (unless (delim? (get L "LPos")) (while (and (nth L "LPos") (not (delim? (get L "LPos")))) (setq L (del1 L)) ) ) (and F (sp? (get L "LPos")) (setq L (del1 L)) ) (chgLine L (max 1 (min "LPos" (length L)))) (and (= "LPos" (length L) (rMove T))) ) ) ## (de vi-delWord (F) ## (let L "Line" ## (off "Clip") ## (ifn (= "(" (get L "LPos")) ## (while (and (nth L "LPos") (not (delim? (get L "LPos")))) ## (setq L (del1 L)) ) ## (for (N 1 (and (setq L (del1 L)) (< 0 N))) ## (case (get L "LPos") ## ("(" (inc 'N)) ## (")" (dec 'N)) ) ) ) ## (and ## F ## (sp? (get L "LPos")) ## (setq L (del1 L)) ) ## (chgLine L (max 1 (min "LPos" (length L)))) ) ) # Replace char (de rplChar (C) (chgLine (insert "LPos" (remove "LPos" "Line") C) "LPos" ) ) # Undo mechanism (de doUndo () (setq "UndoLine" "Line" "UndoPos" "LPos") ) # Paste clip (de doPaste () (if (= 1 "LPos") (chgLine (append "Clip" "Line") 1) (chgLine (append (head (dec "LPos") "Line") "Clip" (nth "Line" "LPos") ) (+ "LPos" (length "Clip") -1) ) ) ) # Set history line (de setHist (N) (chgLine (if (=0 (setq "HPos" N)) "Line1" (chop (get *History "HPos")) ) 1 ) ) # Searching (de ledSearch (L) (let (H (nth *History (inc "HPos")) S (find '((X) (match "Item" (chop X))) H)) (chgLine (ifn S (prog (beep) L) (push '"Found" "HPos") (inc '"HPos" (index S H)) (chop S) ) 1 ) ) ) # TAB expansion (de expandTab () (let ("L" (head (dec "LPos") "Line") "S" "L") (while (find "skipFun" "S") (pop '"S") ) (ifn "S" (prog (off "Complete") (do 3 (insChar " ")) ) (ifn (default "Complete" (let "N" (inc (length "S")) (mapcar '((X) (setq X (nth (mapcan '((C) (if (or (= "\\" C) (delim? C)) (list "\\" C) (cons C) ) ) (chop X) ) "N" ) ) (cons (+ "LPos" (length X)) (append "L" X (nth "Line" "LPos")) ) ) ("tabFun" (pack "S")) ) ) ) (beep) (chgLine (cdar "Complete") (caar "Complete")) (rot "Complete") ) ) ) ) # Insert mode (de insMode ("C") (if (= "C" "^I") (expandTab) (off "Complete") (case "C" ("^?" (when (> "LPos" 1) (chgLine (remove (dec "LPos") "Line") (dec "LPos")) ) ) ## ("^V" (insChar (key))) # 'M-<char>' (Meta or Alt) keymap, implemented with ESC prefix ("^[" (and (key 500) (case @ ("[" (when (sys "TERM") (and (key 500) (case @ # arrow keys ("A" (uMove) (xMove)) ("B" (dMove) (xMove)) ("C" (rMove T)) ("D" (lMove)) ) ) ) ) # forward-word # TODO: emacs (goto end of word!) ("f" (rWord)) # backward-word ("b" (lWord)) # kill-word ("d" (doUndo) (delWord T)) # toggle case of char # TODO: capitalize/downcase/upcase word ((or "c" "l") (doUndo) (rplChar ((if (low? (setq "C" (get "Line" "LPos"))) uppc lowc ) "C" ) ) (rMove T) ) # forward-sexp ("^f" (case (get "Line" "LPos") ("(" (rPar)) (T (beep)) ) ) # backward-sexp ("^b" (case (get "Line" "LPos") (")" (lPar)) (T (beep)) ) ) # show present working directory (pwd) # delete sexp ("^d" (prinl (pwd)) (quit)) ("^k" (delSexp)) # goto/find char ("g" (ifn (setq "C" (index (key) (nth "Line" (inc "LPos")))) (beep) (chgLine "Line" (+ "C" "LPos")) ) ) # accept input pattern for history search ("^s" (let "L" "Line" (_getLine '("/") '((C) (= C "/"))) (unless (=T "Line") (setq "Item" (append '(@) (cdr "Line") '(@))) (ledSearch "L") ## (off "Insert") ) ) ) # search for next occurrence of pattern # in history-search ("s" (ledSearch "Line")) # search for previous occurrence of pattern # in history-search ("r" (if "Found" (setHist (pop '"Found")) (beep))) ) ) ) # 'C-c' (Ctrl-c) keymap ("^c" (and (key 1000) (case @ # change directory ("^d" (prinl "[(pwd) " (pwd) "]") (prin "(cd) ") (cd (read)) (quit) ) # make directory (with parents) ("+" (prinl "[(pwd) " (pwd) "]") (prin "(mkdir -p) ") (call 'mkdir (read) "-p") (quit) ) # call shell-command with arguments (("^c" "!") (prin "[cmd -args] ") (eval (append '(call) (mapcar pack (split (chop (line T)) " " ) ) ) ) (quit) ) ) ) ) # 'C-u (Ctrl-u) keymap (functions with arguments) ("^u" (and (key 1000) (case @ ("^x" (and (key 500) (case @ # list directory files with dotfiles ("^d" (printsp (dir (pwd) T)) (prinl) (quit) ) # dired-style directory listing with dotfiles ("d" (call 'ls "-al") (quit)) ) ) ) ("^h" (and (key 500) (case @ # unbug ("d" (prin "(unbug) ") (unbug (any (line T))) (quit) ) ) ) ) ) ) ) # 'C-x' (Ctrl-x) keymap ("^x" (and (key 500) (case @ # undo ("u" (let ("L" "Line" "P" "LPos") (chgLine "UndoLine" "UndoPos") (setq "UndoLine" "L" "UndoPos" "P") ) ) # list directory files ("^d" (printsp (dir (pwd))) (prinl) (quit)) # dired-style directory listing (ls -l) ("d" (call 'ls "-l") (quit)) # find file (with EMACSCLIENT) ("^f" (prog (prinl "[(pwd) " (pwd) "]") (prin "(emacsclient -c) ") (call 'emacsclient "-c" (line T)) (quit) ) ) # find-file (with ZILE) ("f" (prog (prinl "[(pwd) " (pwd) "]") (prin "(zile) ") (call 'zile (line T)) (quit) ) ) # return (a list with) the number of lines of file(s) ("l" (prinl "[(pwd) " (pwd) "]") (prin "(lines) ") (println (mapcar lines (mapcar pack (split (chop (line T)) " ") ) ) ) (quit) ) ) ) ) ## (case @ ## ((call 'test "-f" X) ## (call 'zile X) (quit) ) ## ((call 'test "-d" X) ## (prinl "Can't open directory") (quit) ) ## (T (case @ ## ((call 'test "-d" (dirname X)) ## (chdir (dirname X) ## (out (basename X) ## (call -zile X) ) ## (quit) ) ) ## (T (call 'mkdir (dirname X) "-p") ## (chdir (dirname X) ## (out (basename X)) ) ) ) ) ) ) ) ) ) ) # 'C-h' (Ctrl-h) keymap (info/help functionality) ("^h" (and (key 1000) (case @ # current contents of kill-ring (cut buffer) ("r" (prinl) (println "Clip")(quit)) # info ("i" (prin "(info) ") (let Info (info (any (line T))) (printsp (car Info) (stamp (cadr Info) (cddr Info)) ) ) (prinl) (quit) ) # doc ("f" (prin "(doc) ") (doc (line T)) (quit) ) # show ("s" (prin "(show) ") (pp (show (any (line T)))) (quit) ) # debug ("d" (prin "(debug) ") (debug (any (line T))) (quit) ) # pretty print ("p" (and (key 500) (case @ # (pp) ("p" (prin "(pp) ") (pp (any (line T))) (quit) ) # (pretty) ("r" (prin "(pretty) ") (pretty (any (line T))) (prinl) (quit) ) ) ) ) ) ) ) # 'C-v' (Ctrl-v) keymap ## ("^v" (and (key 500) ## (case @ ## # display current contents of ## # kill-ring (cut buffer) ## ("r" (prinl) (println "Clip")) ) ) ) # undo ("^_" (let ("L" "Line" "P" "LPos") (chgLine "UndoLine" "UndoPos") (setq "UndoLine" "L" "UndoPos" "P") ) ) # move-end-of-line ("^e" (eMove) (xMove)) # move-beginning-of-line ("^a" (bMove)) # kill-line ("^k" (doUndo) (clrEol) (rMove T)) # backward-char ("^b" (lMove)) # forward-char ("^f" (and (= "LPos" (length "Line")))(rMove T)) # next-line ("^n" (dMove)) # previous-line ("^p" (uMove)) # yank ("^y" (doUndo) (doPaste)) # delete-char ("^d" (doUndo) (delChar)) # clear-screen ("^l" (call 'tput 'clear) (quit)) # self-insertion (T (when (= "C" ")") (chgLine "Line" (prog1 "LPos" (lPar) (wait 200))) ) (insChar "C") ) ) ) ) #### TODO: delete, once all functionality #### #### has been transferred to Insert Mode #### # Command mode ## (de cmdMode ("C") ## (case "C" ## ("g" (prinl) (println "Clip")) ## ("$" (eMove)) ## ("%" ## (case (get "Line" "LPos") ## (")" (lPar)) ## ("(" (rPar)) ## (T (beep)) ) ) ## ("/" ## (let "L" "Line" ## (_getLine '("/") '((C) (= C "/"))) ## (unless (=T "Line") ## (setq "Item" (append '(@) (cdr "Line") '(@))) ## (ledSearch "L") ## (off "Insert") ) ) ) ## ("0" (bMove)) ## ("A" (doUndo) (xMove) (on "Insert")) ## ("a" (doUndo) ((if (= "LPos" (length "Line")) xMove rMove T)) (on "Insert")) ## ("b" (lWord)) ## ("c" (doUndo) (delWord NIL) (on "Insert")) ## ("C" (doUndo) (clrEol) (xMove) (on "Insert")) ## ("d" (doUndo) (delWord T)) ## ("D" (doUndo) (clrEol)) ## ("f" ## (ifn (setq "C" (index (key) (nth "Line" (inc "LPos")))) ## (beep) ## (chgLine "Line" (+ "C" "LPos")) ) ) ## ("h" (lMove)) ## ("i" (doUndo) (on "Insert")) ## ("I" (doUndo) (bMove) (on "Insert")) ## ("j" (unless (=0 "HPos") (setHist (dec "HPos")))) ## ("k" (when (< "HPos" (length *History)) (setHist (inc "HPos")))) ## ("l" (rMove T)) ## ("n" (ledSearch "Line")) ## ("N" (if "Found" (setHist (pop '"Found")) (beep))) ## ("p" (doUndo) ((if (= "LPos" (length "Line")) xMove rMove T)) (doPaste)) ## ("P" (doUndo) (doPaste)) ## ("r" (ifn "Line" (beep) (doUndo) (rplChar (key)))) ## ("s" (doUndo) (delChar) (on "Insert")) ## ("S" (doUndo) (chgLine NIL 1) (on "Insert")) ## ("U" (setHist "HPos")) ## ("u" ## (let ("L" "Line" "P" "LPos") ## (chgLine "UndoLine" "UndoPos") ## (setq "UndoLine" "L" "UndoPos" "P") ) ) ## ("w" (rWord)) ## ("x" (doUndo) (delChar)) ## ("X" (lMove) (doUndo) (delChar)) ## ("~" ## (doUndo) ## (rplChar ## ((if (low? (setq "C" (get "Line" "LPos"))) uppc lowc) "C") ) ## (rMove T) ) ## (T (beep)) ) ) # Get a line from console (de _getLine ("L" "skipFun") (use "C" (chgLine "L" (inc (length "L"))) (on "Insert") (until (member (setq "C" (let *Dbg "*Dbg" (key))) '("^J" "^M") ) (case "C" (NIL (bye)) ## ("^D" (prinl) (bye)) ("^Q" (prinl) (bye)) ## ("^X" (prin (cdr *Tsm)) (prinl) (quit)) ) ("^G" (prin (cdr *Tsm)) (prinl) (quit)) ) ((if "Insert" insMode insMode) "C") ) ) ) # only insert mode for emacs ## ((if "Insert" insMode cmdMode) "C") ) ) ) # Function keys (de fkey (Key . Prg) (setq "FKey" (cond ((not Key) "FKey") ((not Prg) (delete (assoc Key "FKey") "FKey")) ((assoc Key "FKey") (cons (cons Key Prg) (delete @ "FKey")) ) (T (cons (cons Key Prg) "FKey")) ) ) ) # Main editing functions (de _led ("Line1" "tabFun" "skipFun") (default "tabFun" '((S) (conc (filter '((X) (pre? S X)) (all)) (let P (rot (split (chop S) "/")) (setq S (pack (car P)) P (and (cdr P) (pack (glue "/" @) "/")) ) (extract '((X) (and (pre? S X) (pack P X)) ) (dir P T) ) ) ) ) ) (setq "LPos" 1 "HPos" 0) (_getLine "Line1" (or "skipFun" delim?)) (prinl (cdr *Tsm)) ) (de revise ("X" "tabFun" "skipFun") (let ("*Dbg" *Dbg *Dbg NIL) (_led (chop "X") "tabFun" "skipFun") (pack "Line") ) ) (de saveHistory () (in (pack "+" (pil "history")) (ctl T (let (Old (make (until (eof) (link (line T)))) New *History N "HistMax") (out (pil "history") (while (and New (n== New "Hist0")) (prinl (pop 'New)) (dec 'N) ) (setq "Hist0" *History) (do N (NIL Old) (prinl (pop 'Old)) ) ) ) ) ) ) # Enable line editing (de *Led (let ("*Dbg" *Dbg *Dbg NIL) (push1 '*Bye '(saveHistory)) (push1 '*Fork '(del '(saveHistory) '*Bye)) (_led) (let L (pack "Line") (or (>= 3 (length "Line")) (sp? (car "Line")) (= L (car *History)) (push '*History L) ) (and (nth *History "HistMax") (con @)) L ) ) ) (mapc zap (quote chgLine skipQ escQ delim? lMove bMove rMove eMove xMove uMove dMove lWord rWord lPar rPar clrEol insChar del1 delChar delWord rplChar doUndo doPaste setHist ledSearch expandTab insMode cmdMode _getLine _led saveHistory ) ) # vi:et:ts=3:sw=3 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/form.js�������������������������������������������������������������������0000644�0000000�0000000�00000041150�12265263724�015220� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������/* 01jan14abu * (c) Software Lab. Alexander Burger */ var FormReq = new XMLHttpRequest(); FormReq.upload.addEventListener("progress", dropProgress, false); FormReq.upload.addEventListener("load", dropLoad, false); var Btn = []; var Queue = []; var SesId, Key, InBtn, Auto, Chg, Drop, Hint, Hints, Item, Beg, End; function inBtn(btn,flg) {InBtn = flg;} function formKey(event) { Key = event.keyCode; if (Hint && Hint.style.visibility == "visible") { if ((Item >= 0 && Key == 13) || Key == 38 || Key == 40) return false; if (event.keyCode == 27) { Hint.style.visibility = "hidden"; return false; } } if (event.charCode || event.keyCode == 8) Chg = true; return true; } function fldChg(field) { Chg = true; if (!InBtn && Key != 13) post(field.form, false, null, null); return true; } function doBtn(btn) { Btn.push(btn); return true; } function doDrag(event) { event.stopPropagation(); event.preventDefault(); } function doDrop(btn, event) { doDrag(event); if (event.dataTransfer.files.length != 0) { Btn.push(Drop = btn); btn.value = "0 %"; post(btn.form, false, null, event.dataTransfer.files[0]); } } function dropProgress(event) { if (Drop) Drop.value = event.lengthComputable? Math.round((event.loaded * 100) / event.total) + " %" : "(?) %"; } function dropLoad(event) { Drop = null; } function hasElement(form, name) { for (var i = 0; i < form.elements.length; ++i) if (form.elements[i].name == name) return true; return false; } function setHref(fld, url) { var i = url.indexOf("~"); if (url.charAt(i = i>=0? i+1 : 0) == "+") { url = url.substr(0,i) + url.substr(i+1); fld.target = "_blank"; } fld.href = decodeURIComponent(url); } /*** Form submit ***/ function doPost(form) { for (var i = 0; ; ++i) { if (i == Btn.length) return true; if (Btn[i].form == form) return post(form, false, null, null); } } function post(form, auto, exe, file) { var i, data; if (!FormReq || !hasElement(form,"*Get") || (i = form.action.indexOf("~")) <= 0) return true; if (FormReq.readyState > 0 && FormReq.readyState < 4) { Queue.push([form, auto, exe, file]); return false; } form.style.cursor = "wait"; try {FormReq.open("POST", SesId + "!jsForm?" + form.action.substr(i+1));} catch (e) {return true;} FormReq.onload = function() { var i, j; if (FormReq.responseText == "T") { Queue.length = 0; form.submit(); } else { var txt = FormReq.responseText.split("&"); if (txt[0]) { var r = txt[0].split(":"); if (Auto) clearTimeout(Auto); if (!r[1]) Auto = null; else { Auto = setTimeout(function() { if (Chg) Auto = setTimeout(arguments.callee, r[1]); else { Btn.push(document.getElementById(r[0])); post(form, true, null, null); } }, r[1] ); } } if (!auto || !Chg) { for (i = 1; i < txt.length;) { var fld = txt[i++]; var val = decodeURIComponent(txt[i++]); if (!fld) { window[txt[i++]](val); continue; } if (!(fld = document.getElementById(fld))) continue; if (fld.tagName == "SPAN") { if (i != txt.length && txt[i].charAt(0) == "=") ++i; if (i == txt.length || txt[i].charAt(0) != "+") { if (fld.firstChild.tagName != "A") fld.firstChild.data = val? val : "\u00A0"; else fld.replaceChild(document.createTextNode(val? val : "\u00A0"), fld.firstChild); } else { var a = document.createElement("A"); setHref(a, txt[i++].substr(1)); a.appendChild(document.createTextNode(val)); fld.replaceChild(a, fld.firstChild); } } else if (fld.tagName == "A") { if (i != txt.length && txt[i].charAt(0) == "=") ++i; if (i == txt.length || txt[i].charAt(0) != "+") { fld.replaceChild(document.createTextNode(val? val : "\u00A0"), fld.firstChild); fld.removeAttribute("href"); } else { fld.firstChild.data = val; setHref(fld, txt[i++].substr(1)); } } else if (fld.tagName == "IMG") { var parent = fld.parentNode; fld.src = val; fld.alt = txt[i++]; if (parent.tagName == "A") { if (txt[i]) setHref(parent, txt[i]); else { var grand = parent.parentNode; grand.removeChild(parent); grand.appendChild(fld); } } else if (txt[i]) { var a = document.createElement("A"); parent.removeChild(fld); parent.appendChild(a); a.appendChild(fld); setHref(a, txt[i]); } ++i; } else { if (fld.type == "checkbox") { fld.checked = val != ""; document.getElementsByName(fld.name)[0].value = ""; } else if (fld.type == "select-one") { for (j = 0; j < fld.options.length; ++j) { if (fld.options[j].text == val) fld.selectedIndex = j; fld.options[j].disabled = false; } } else if (fld.type == "radio") { fld.value = val; fld.checked = txt[i++].charAt(0) != ""; } else if (fld.type == "image") fld.src = val; else if (fld.value != val) { fld.value = val; fld.scrollTop = fld.scrollHeight; } fld.disabled = false; if (i < txt.length && txt[i].charAt(0) == "=") { if (fld.type == "select-one") { for (j = 0; j < fld.options.length; ++j) if (fld.options[j].text != val) fld.options[j].disabled = true; } fld.disabled = true; InBtn = 0; // 'onblur' on won't come when disabled if (fld.type == "checkbox" && fld.checked) document.getElementsByName(fld.name)[0].value = "T"; ++i; } } while (i < txt.length && (j = "#*?".indexOf(txt[i].charAt(0))) >= 0) { switch (j) { case 0: // '#' var cls; val = txt[i++].substr(1); if ((cls = fld.getAttribute("class")) != null) { j = cls.indexOf(" "); if (!val) val = j >= 0? cls.substr(j+2) : cls; else if (j >= 0) val += cls.substr(j); else val += " " + cls; } fld.setAttribute("class", val); break; case 1: // '*' var node = fld.parentNode.parentNode.lastChild; var img = document.createElement("IMG"); if (!node.firstChild) node = fld.parentNode.parentNode.parentNode.lastChild; node.removeChild(node.firstChild); img.src = txt[i++].substr(1); if (!txt[i]) node.appendChild(img); else { var a = document.createElement("A"); setHref(a, txt[i]); a.appendChild(img); node.appendChild(a); } ++i; break; case 2: // '?' fld.title = decodeURIComponent(txt[i++].substr(1)); break; } } } Chg = false; } } form.style.cursor = ""; if (Queue.length > 0) { var a = Queue.shift(); post(a[0], a[1], a[2], a[3]); } } if (!exe) data = ""; else { data = "*Gui:0=" + exe[0]; for (var i = 1; i < exe.length; ++i) data += "&*JsArgs:" + i + "=" + exe[i]; } for (i = 0; i < Btn.length;) if (Btn[i].form != form) ++i; else { data += "&" + Btn[i].name + "=" + encodeURIComponent(Btn[i].type == "submit"? Btn[i].value : Btn[i].src); Btn.splice(i,1); } for (i = 0; i < form.elements.length; ++i) { var fld = form.elements[i]; if (fld.name && fld.type != "submit") { // "image" won't come :-( var val; if (fld.type == "checkbox") val = fld.checked? "T" : ""; else if (fld.type == "select-one") val = fld.options[fld.selectedIndex].text; else if (fld.type == "radio" && !fld.checked) continue; else val = fld.value; data += "&" + fld.name + "=" + encodeURIComponent(val.replace(/ +$/,"")); } } try { if (!file) FormReq.send(data); else { var rd = new FileReader(); rd.readAsBinaryString(file); rd.onload = function() { FormReq.setRequestHeader("X-Pil", "*ContL=T"); FormReq.sendAsBinary(data + "&*Drop=" + encodeURIComponent(file.name) + "=" + file.size + "\n" + rd.result ); } } } catch (e) { FormReq.abort(); return true; } return false; } /*** Hints ***/ function doHint(field) { if (!Hint) { Hint = document.createElement("div"); Hint.setAttribute("class", "hint"); Hint.style.visibility = "hidden"; Hint.style.position = "absolute"; Hint.style.zIndex = 9999; Hint.style.textAlign = "left"; Hints = document.createElement("div"); Hints.setAttribute("class", "hints"); Hints.style.position = "relative"; Hints.style.top = "-2px"; Hints.style.left = "-3px"; Hint.appendChild(Hints); } field.parentNode.appendChild(Hint); field.onblur = function() { Hint.style.visibility = "hidden"; } var top = field.offsetHeight; var left = 0; for (var obj = field; obj && obj.style.position != "absolute"; obj = obj.offsetParent) { top += obj.offsetTop; left += obj.offsetLeft; } Hint.style.top = top + "px"; Hint.style.left = left + "px"; } function hintKey(field, event, tok, coy) { var i, data; if (event.keyCode == 9 || event.keyCode == 27) return false; if (Hint.style.visibility == "visible") { if (Item >= 0 && event.keyCode == 13) { setHint(field, Hints.childNodes[Item]); return false; } if (event.keyCode == 38) { // Up if (Item > 0) { hintOff(Item); hintOn(--Item); } return false; } if (event.keyCode == 40) { // Down if (Item < (lst = Hints.childNodes).length-1) { if (Item >= 0) hintOff(Item); hintOn(++Item); } return false; } } if (event.keyCode == 13) return true; var req = new XMLHttpRequest(); if (tok) { for (Beg = field.selectionStart; Beg > 0 && !field.value.charAt(Beg-1).match(/\s/); --Beg); End = field.selectionEnd; } else { Beg = 0; End = field.value.length; } if (event.keyCode != 45) { // INS if (Beg == End) { Hint.style.visibility = "hidden"; return false; } if (coy && Hint.style.visibility == "hidden") return false; } try { req.open("POST", (SesId? SesId : "") + ((i = field.id.lastIndexOf("-")) < 0? "!jsHint?$" + field.id : "!jsHint?+" + field.id.substr(i+1) ) ); } catch (e) {return true;} req.onload = function() { var i, n, lst, str; if ((str = req.responseText).length == 0) Hint.style.visibility = "hidden"; else { lst = str.split("&"); while (Hints.hasChildNodes()) Hints.removeChild(Hints.firstChild); for (i = 0, n = 7; i < lst.length; ++i) { addHint(i, field, str = decodeURIComponent(lst[i])); if (str.length > n) n = str.length; } Hints.style.width = n + 3 + "ex"; Hint.style.width = n + 4 + "ex"; Hint.style.visibility = "visible"; Item = -1; } } var data = "*JsHint=" + encodeURIComponent(field.value.substring(Beg,End)); for (i = 0; i < field.form.elements.length; ++i) { var fld = field.form.elements[i]; if (fld.name == "*Get") data += "&*Get=" + fld.value; else if (fld.name == "*Form") data += "&*Form=" + fld.value; } try {req.send(data);} catch (e) { req.abort(); return true; } return (event.keyCode != 45); // INS } function addHint(i, field, str) { var item = document.createElement("div"); item.appendChild(document.createTextNode(str)); item.onmouseover = function() { if (Item >= 0) hintOff(Item); hintOn(i); field.onblur = false; field.onchange = false; Item = i; } item.onmouseout = function() { hintOff(Item); field.onblur = function() { Hint.style.visibility = "hidden"; } field.onchange = function() { return fldChg(field, item); }; Item = -1; } item.onclick = function() { setHint(field, item); } Hints.appendChild(item); } function setHint(field, item) { Hint.style.visibility = "hidden"; field.value = field.value.substr(0,Beg) + item.firstChild.nodeValue + field.value.substr(End); Chg = true; post(field.form, false, null, null); field.setSelectionRange(Beg + item.firstChild.nodeValue.length, field.value.length); field.focus(); field.onchange = function() { return fldChg(field) }; } function hintOn(i) { var s = Hints.childNodes[i].style; s.background = "black"; s.color= "white"; } function hintOff(i) { var s = Hints.childNodes[i].style; s.background = "white"; s.color= "black"; } /*** Scroll/touch ***/ var TblY; function tblTouch(event) { if (event.touches.length == 1) TblY = event.touches[0].pageY; return true; } function tblMove(table, event) { if (event.touches.length == 1) { var dy = event.touches[0].pageY - TblY; if (dy < -12 || dy > +12) { TblY = event.touches[0].pageY; for (var obj = table.parentNode; obj; obj = obj.parentNode) if (obj.tagName == "FORM") return post(obj, false, [dy > 6? "jsUp" : "jsDn"], null); } return false; } return true; } /*** Lisp calls ***/ function lisp(form, fun) { if (form) { var exe = [fun]; for (var i = 2; i < arguments.length; ++i) if (typeof arguments[i] === "number") exe[i-1] = "+" + arguments[i]; else exe[i-1] = "." + encodeURIComponent(arguments[i]); return post(form, false, exe, null); } if (arguments.length > 2) { fun += "?" + lispVal(arguments[2]); for (var i = 3; i < arguments.length; ++i) fun += "&" + lispVal(arguments[i]); } var req = new XMLHttpRequest(); try {req.open("GET", SesId + "!" + fun);} catch (e) {return true;} req.onload = function() { if (req.responseText) eval(req.responseText); } try {req.send(null);} catch (e) { req.abort(); return true; } return false; } function lispVal(x) { if (typeof x === "number") return "+" + x; if (x.charAt(0) == "-") return "%2D" + encodeURIComponent(x.substr(1)); return encodeURIComponent(x); } ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/form.l��������������������������������������������������������������������0000644�0000000�0000000�00000142120�12265263724�015036� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 02jan14abu # (c) Software Lab. Alexander Burger # *PRG *Top *Gui *Btn *Get *Got *Form *Evt *Lock *Spans # "*Cnt" "*Lst" "*App" "*Err" "*Foc" "*Post2" "*Stat" "*Ix" "*Chart" "*Cho" (allow "@img/" T) (push1 '*JS (allow "@lib/form.js")) (mapc allow (quote *Gui *Get *Got *Form "!jsForm" *Evt *Drop *JsHint "!jsHint" jsUp jsDn *JsArgs "!tzOffs" ) ) (one "*Cnt") (off "*Lst" "*Post2" "*Chart" "*Cho" "*TZO") (de *Throbber ("+---" "-+--" "--+-" "---+" "--+-" "-+--" .) ) (de tzOffs (Min) (setq "*TZO" (* Min 60)) (respond) ) # Define GUI form (de form ("Attr" . "Prg") (inc '*Form) (let "App" (if *PRG (get "*Lst" (- "*Cnt" *Get) *Form) (prog1 (setq *Top (new NIL NIL 'able T 'evt 0)) (queue (nth "*Lst" (- "*Cnt" *Get)) *Top) ) ) (let "Lst" (get "*Lst" (- "*Cnt" *Get) 1) (for ("F" . "L") "Lst" (let *Form (- "F" (length "Lst")) (cond ((and (== *PRG (car "L")) (memq "App" (get *PRG 'top))) (apply "form" "L") ) ((or (== *PRG "App") (memq "App" (get *PRG 'top))) (if (get "L" 1 'top) (apply "form" "L") (put (car "L") 'top (cons *PRG (get *PRG 'top))) (let *PRG NIL (apply "form" "L")) ) ) ) ) ) ) ("form" "App" "Attr" "Prg") ) ) (de "form" ("*App" "Attr" "Prg") (with "*App" (job (: env) (<post> "Attr" (urlMT *Url *Menu *Tab *ID) (<hidden> '*Get *Get) (<hidden> '*Form *Form) (<hidden> '*Evt (: evt)) (zero "*Ix") (if *PRG (let gui '(() (with (get "*App" 'gui (inc '"*Ix")) (for E "*Err" (when (== This (car E)) (<div> 'error (if (atom (cdr E)) (ht:Prin (eval (cdr E) 1)) (eval (cdr E) 1) ) ) ) ) (if (: id) (let *Gui (val "*App") (show> This (cons '*Gui @)) ) (setq "*Chart" This) ) This ) ) (and (== *PRG "*App") (setq *Top "*App")) (htPrin "Prg") ) (set "*App") (let gui '((X . @) (inc '"*Ix") (with (cond ((pair X) (pass new X)) ((not X) (pass new)) ((num? X) (ifn "*Chart" (quit "no chart" (rest)) (with "*Chart" (let L (last (: gui)) (when (get L X) (inc (:: rows)) (queue (:: gui) (setq L (need (: cols)))) ) (let Fld (pass new) (set (nth L X) Fld) (put Fld 'chart (list This (: rows) X)) (and (get Fld 'chg) (get Fld 'able) (=: lock)) (set> Fld (get ((: put) (get (nth (: data) (: ofs)) (: rows)) (+ (: ofs) (: rows) -1) ) X ) T ) Fld ) ) ) ) ) ((get "*App" X) (quit "gui conflict" X)) (T (put "*App" X (pass new))) ) (queue (:: home gui) This) (unless (: chart) (init> This)) (when (: id) (let *Gui (val "*App") (show> This (cons '*Gui (: id))) ) ) This ) ) (htPrin "Prg") ) ) ) (off "*Chart") (--) (eval (: show)) ) ) ) # Disable form (de disable (Flg) (and Flg (=: able)) ) # Handle form actions (de action "Prg" (off "*Chart" "*Foc") (or *PRG "*Post2" (off "*Err")) (catch "stop" (nond (*Post (unless (and *PRG (= *Form (car *Got)) (= *Get (cadr *Got))) (pushForm (cons)) ) (if *Port% (let *JS NIL (_doForm)) (_doForm) ) (off *PRG *Got) ) (*PRG (with (postForm) (ifn (= *Evt (: evt)) (noContent) (postGui) (redirect (baseHRef) *SesId (urlMT *Url *Menu *Tab *ID) "&*Evt=+" (inc (:: evt)) "&*Got=_+" *Form "_+" *Get ) ) ) ) (NIL (off *PRG) (pushForm (cons)) (_doForm) ) ) ) ) (de pushForm (L) (push '"*Lst" L) (and (nth "*Lst" 99) (con @)) (setq *Get "*Cnt") (inc '"*Cnt") ) (de _doForm () (one *Form) (run "Prg") (setq "*Stat" (cons (pair "*Err") (copy (get "*Lst" (- "*Cnt" *Get))) ) ) ) (de jsForm (Url) (if (or *PRG (not *Post)) (noContent) (setq *Url Url Url (chop Url)) (let action '(Prg (off "*Err") (with (postForm) (catch "stop" (postGui) (httpHead "text/plain; charset=utf-8") (if (and (= (car "*Stat") "*Err") (= (cdr "*Stat") (get "*Lst" (- "*Cnt" *Get))) ) (ht:Out *Chunked (when (: auto) (prin "i" *Form "-" (: auto 1 id) ":" (: auto -1)) (=: auto) ) (for S *Spans (prin "&" (car S) "&" (run (cdr S))) ) (for This (: gui) (if (: id) (prin "&i" *Form "-" @ "&" (js> This)) (setq "*Chart" This) ) ) ) (setq "*Post2" (cons *Get *Form *PRG)) (ht:Out *Chunked (prin T)) ) ) ) (off *PRG) ) (use @X (cond ((match '("-" @X "." "h" "t" "m" "l") Url) (try 'html> (extern (ht:Pack @X))) ) ((disallowed) (notAllowed *Url) (http404) ) ((= "!" (car Url)) ((intern (pack (cdr Url)))) ) ((tail '("." "l") Url) (load *Url) ) ) ) ) ) ) (de postForm () (let? Lst (get "*Lst" (- "*Cnt" (setq *Get (format *Get)))) (setq *Form (format *Form) *Evt (format *Evt) *PRG (cond ((and (= *Get (car "*Post2")) (= *Form (cadr "*Post2"))) (cddr "*Post2") ) ((off "*Post2")) ((gt0 *Form) (get Lst *Form)) (T (get Lst 1 (+ (length (car Lst)) *Form) 1)) ) ) ) ) (de postGui () (if "*Post2" (off *Gui "*Post2") (let ("Fun" NIL *Btn NIL) (for G *Gui (if (=0 (car G)) (setq "Fun" (cdr G)) (and (lt0 (car G)) (setq *Btn (cdr G))) (con (assoc (car G) (val *PRG)) (cdr G)) ) ) (off *Gui) (job (: env) (for This (: gui) (cond ((not (: id)) (setq "*Chart" This)) ((chk> This) (error @)) ((or (: rid) (: home able)) (set> This (val> This) T) ) ) ) (for This (: gui) (cond ((: id)) ((chk> (setq "*Chart" This)) (error @)) ((or (: rid) (: home able)) (set> This (val> This)) ) ) ) (if (pair "*Err") (and *Lock (with (caar "*Err") (tryLock *Lock))) (finally (when *Lock (if (lock @) (=: able (off *Lock)) (sync) (tell) ) ) (when "Fun" (when (and *Allow (not (idx *Allow "Fun"))) (notAllowed "Fun") (throw "stop") ) (apply (intern "Fun") (mapcar '((X) ((if (= "+" (car (setq X (chop (cdr X))))) format pack) (cdr X) ) ) *JsArgs ) ) ) (for This (: gui) (nond ((: id) (setq "*Chart" This)) ((ge0 (: id)) (let? A (assoc (: id) (val *PRG)) (when (cdr A) (con A) (act> This) ) ) ) ) ) ) (for This (: gui) (or (: id) (setq "*Chart" This)) (upd> This) ) ) ) ) ) ) (de error (Exe) (cond ((=T Exe) (on "*Err")) ((nT "*Err") (queue '"*Err" (cons This Exe))) ) ) (de url (Url . @) (when Url (off *PRG) (redirect (baseHRef) *SesId Url "?" (pack (make (loop (and (sym? (next)) (= `(char '*) (char (arg))) (link (arg) "=") (next) ) (link (ht:Fmt (arg))) (NIL (args)) (link "&") ) ) ) ) (throw "stop") ) ) # Actve <span> elements (de span Args (def (car Args) (list NIL (list '<span> (lit (cons 'id (car Args))) (cons 'ht:Prin (cdr Args)) ) ) ) (push '*Spans Args) ) (span expires (pack `(char 8230) # Ellipsis (let Tim (+ (time T) (/ (cadr (assoc -1 *Run)) 1000)) (if "*TZO" (tim$ (% (- Tim -86400 @) 86400)) (javascript NIL "lisp(null, 'tzOffs', (new Date()).getTimezoneOffset())" ) (pack (tim$ (% Tim 86400)) " UTC") ) ) ) ) # Return chart property (de chart @ (pass get "*Chart") ) # Table extensions (patch (cdr <table>) 'Attr '(if "*Chart" (list '("ontouchstart" . "return tblTouch(event)") '("ontouchmove" . "return tblMove(this,event)") Attr ) Attr ) ) (daemon '<table> (on "rowF") ) (de alternating () (onOff "rowF") ) # REPL form (de repl (Attr) (form Attr (gui 'view '(+FileField) '(tmp "repl") 80 25) (--) (gui 'line '(+Focus +TextField) 64 ":") (gui '(+JS +Button) "eval" '(let Str (val> (: home line)) (out (pack "+" (tmp "repl")) (prinl ": " Str) (catch '(NIL) (let Res (in "/dev/null" (eval (any Str))) (prin "-> ") (println Res) ) ) (when *Msg (prinl @) (off *Msg)) ) (clr> (: home line)) ) ) (gui '(+JS +Button) "clear" '(clr> (: home view)) ) ) ) # Dialogs (de _dlg (Attr Env) (let L (get "*Lst" (- "*Cnt" *Get)) (while (and (car L) (n== *PRG (caar @))) (pop L) ) (push L (list (new NIL NIL 'btn This 'able T 'evt 0 'env Env) Attr Prg ) ) (pushForm L) ) ) (de dialog (Env . Prg) (_dlg 'dialog Env) ) (de alert (Env . Prg) (_dlg 'alert Env) ) (de note (Str Lst) (alert (env '(Str Lst)) (<span> 'note Str) (--) (for S Lst (<br> S)) (okButton) ) ) (de ask (Str . Prg) (alert (env '(Str Prg)) (<span> 'ask Str) (--) (yesButton (cons 'prog Prg)) (noButton) ) ) (de diaform (Lst . Prg) (cond ((num? (caar Lst)) # Dst (gui (gt0 (caar Lst)) '(+ChoButton) (cons 'diaform (list 'cons (list 'cons (lit (car Lst)) '(field 1)) (lit (env (cdr Lst))) ) Prg ) ) ) ((and *PRG (not (: diaform))) (_dlg 'dialog (env Lst)) ) (T (=: env (env Lst)) (=: diaform T) (run Prg 1) ) ) ) (de saveButton (Exe) (gui '(+Button) ,"Save" Exe) ) (de closeButton (Lbl Exe) (when (get "*App" 'top) (gui '(+Rid +Close +Button) Lbl Exe) ) ) (de okButton (Exe) (when (get "*App" 'top) (if (=T Exe) (gui '(+Force +Close +Button) T "OK") (gui '(+Close +Button) "OK" Exe) ) ) ) (de cancelButton () (when (get "*App" 'top) (gui '(+Force +Close +Button) T ',"Cancel") ) ) (de yesButton (Exe) (gui '(+Close +Button) ',"Yes" Exe) ) (de noButton (Exe) (gui '(+Close +Button) ',"No" Exe) ) (de choButton (Exe) (gui '(+Rid +Tip +Button) ,"Find or create an object of the same type" ',"Select" Exe ) ) (class +Force) # force (dm T (Exe . @) (=: force Exe) (pass extra) ) (dm chk> () (when (and (cdr (assoc (: id) (val *PRG))) (eval (: force)) ) (for A (val *PRG) (and (lt0 (car A)) (<> (: id) (car A)) (con A) ) ) T ) ) (class +Close) (dm act> () (when (able) (and (get "*Lst" (- "*Cnt" *Get)) (pushForm (cons (filter '((L) (memq (car L) (: home top))) (car @) ) (cdr @) ) ) ) (extra) (for This (: home top) (for This (: gui) (or (: id) (setq "*Chart" This)) (upd> This) ) ) ) ) # Choose a value (class +ChoButton +Tiny +Tip +Button) (dm T (Exe) (super ,"Choose a suitable value" "+" Exe) (=: chg T) ) (class +PickButton +Tiny +Tip +Button) (dm T (Exe) (super ,"Adopt this value" "@" Exe) ) (class +DstButton +Set +Able +Close +PickButton) # msg obj (dm T (Dst Msg) (=: msg (or Msg 'url>)) (super '((Obj) (=: obj Obj)) '(: obj) (when Dst (or (pair Dst) (list 'chgDst (lit Dst) '(: obj)) ) ) ) ) (de chgDst (This Val) (set> This (if (: new) (@ Val) Val)) ) (dm js> () (cond ((: act) (super)) ((try (: msg) (: obj) 1) (pack "@&+" (ht:Fmt (sesId (mkUrl @)))) ) (T "@") ) ) (dm show> ("Var") (if (: act) (super "Var") (<style> (cons 'id (pack "i" *Form "-" (: id))) (if (try (: msg) (: obj) 1) (<tip> "-->" (<href> "@" (mkUrl @))) (<span> *Style "@") ) ) ) ) (class +Choice +ChoButton) # ttl hint (dm T (Ttl Exe) (=: ttl Ttl) (=: hint Exe) (super '(dialog (env 'Ttl (eval (: ttl)) 'Lst (eval (: hint)) 'Dst (field 1)) (<table> 'chart Ttl '((btn) NIL) (for X Lst (<row> NIL (gui '(+Close +PickButton) (list 'set> 'Dst (if (get Dst 'dy) (list 'pack '(str> Dst) (fin X)) (lit (fin X)) ) ) ) (ht:Prin (if (atom X) X (car X))) ) ) ) (cancelButton) ) ) ) (class +Tok) (dm T @ (=: tok T) (pass extra) ) (class +Coy) (dm T @ (=: coy T) (pass extra) ) (class +hint) # tok coy (dm show> ("Var") (<js> (list '("autocomplete" . "off") '("onfocus" . "doHint(this)") (cons "onkeyup" (pack "return hintKey(this,event" (if2 (: tok) (: coy) ",true,true" ",true" ",false,true") ")" ) ) ) (extra "Var") ) ) (de jsHint (I) (httpHead "text/plain; charset=utf-8") (ht:Out *Chunked (let? L (if (sym? I) ((; I hint) *JsHint) (let? Lst (get "*Lst" (- "*Cnt" (format *Get))) (pair (hint> (get (if (gt0 (format *Form)) (get Lst @) (get Lst 1 (+ (length (car Lst)) (format *Form)) 1) ) 'gui I ) *JsHint ) ) ) ) (prin (ht:Fmt (if (atom (car L)) (car L) (caar L) ) ) ) (for X (cdr L) (prin "&" (ht:Fmt (if (atom X) X (car X))) ) ) ) ) ) (class +Hint +hint) # hint (dm T (Fun . @) (=: hint Fun) (pass extra) ) (dm hint> (Str) ((: hint) (extra Str)) ) (de queryHint (Var CL Str) (make (for (Q (goal CL) (prove Q)) (for V (fish '((S) (and (atom S) (sub? (fold Str) (fold S)))) (get (asoq '@@ @) -1 Var) ) (unless (member V (made)) (link V) ) ) (T (nth (made) 24)) ) ) ) (de dbHint (Str Var Cls Hook) (queryHint Var (cons (list 'db Var Cls Hook Str '@@)) Str ) ) (class +DbHint +Hint) (dm T (Rel . @) (pass super (list '(Str) (list 'dbHint 'Str (lit (car Rel)) (lit (last Rel)) (and (meta (cdr Rel) (car Rel) 'hook) (next)) ) ) ) ) (class +Hint1 +hint) # hint (dm T (Exe . @) (=: hint Exe) (pass extra) ) (dm hint> (Str) (setq Str (extra Str)) (extract '((S) (pre? Str S)) (eval (: hint)) ) ) (class +Hint2 +hint) (dm hint> (Str) (setq Str (extra Str)) (extract '((X) (pre? Str (if (atom X) X (car X)))) (with (field -1) (eval (: hint))) ) ) (class +Txt) # txt (dm T (Fun . @) (=: txt Fun) (pass extra) ) (dm txt> (Val) ((: txt) Val) ) (class +Set) # set (dm T (Fun . @) (=: set Fun) (pass extra) ) (dm set> (Val Dn) (extra ((: set) Val) Dn) ) (class +Val) # val (dm T (Fun . @) (=: val Fun) (pass extra) ) (dm val> () ((: val) (extra)) ) (class +Fmt) # set val (dm T (Fun1 Fun2 . @) (=: set Fun1) (=: val Fun2) (pass extra) ) (dm set> (Val Dn) (extra ((: set) Val) Dn) ) (dm val> () ((: val) (extra)) ) (class +Chg) # old new (dm T (Fun . @) (=: new Fun) (pass extra) ) (dm set> (Val Dn) (extra (=: old Val) Dn) ) (dm val> () (let Val (extra) (if (= (: old) Val) Val ((: new) Val) ) ) ) (class +Upd) # upd (dm T (Exe . @) (=: upd Exe) (pass extra) ) (dm upd> () (set> This (eval (: upd))) ) (class +Init) # init (dm T (Val . @) (=: init Val) (pass extra) ) (dm init> () (set> This (: init)) ) (class +Dflt) # dflt (dm T (Exe . @) (=: dflt Exe) (pass extra) ) (dm set> (Val Dn) (extra (or Val (eval (: dflt))) Dn) ) (dm val> () (let Val (extra) (unless (= Val (eval (: dflt))) Val) ) ) (class +Cue) # cue (dm T (Str . @) (=: cue (pack "<" Str ">")) (pass extra) ) (dm show> ("Var") (<js> (cons (cons "placeholder" (: cue))) (extra "Var") ) ) (class +Trim) (dm val> () (pack (trim (chop (extra)))) ) (class +Enum) # enum (dm T (Lst . @) (=: enum Lst) (pass extra) ) (dm set> (N Dn) (extra (get (: enum) N) Dn) ) (dm val> () (index (extra) (: enum)) ) (class +Map) # map (dm T (Lst . @) (=: map Lst) (pass extra) ) (dm set> (Val Dn) (extra (if (find '((X) (= Val (cdr X))) (: map) ) (val (car @)) Val ) Dn ) ) (dm val> () (let Val (extra) (if (find '((X) (= Val (val (car X)))) (: map) ) (cdr @) Val ) ) ) # Case conversions (class +Uppc) (dm set> (Val Dn) (extra (uppc Val) Dn) ) (dm val> () (uppc (extra)) ) (dm hint> (Str) (extra (uppc Str)) ) (class +Lowc) (dm set> (Val Dn) (extra (lowc Val) Dn) ) (dm val> () (lowc (extra)) ) (dm hint> (Str) (extra (lowc Str)) ) # Field enable/disable (de able () (when (or (: rid) (: home able)) (eval (: able)) ) ) (class +Able) (dm T (Exe . @) (pass extra) (when (: able) (=: able (cond ((=T (: able)) Exe) ((and (pair (: able)) (== 'and (car @))) (cons 'and Exe (cdr (: able))) ) (T (list 'and Exe (: able))) ) ) ) ) (class +Lock +Able) (dm T @ (pass super NIL) ) (class +View +Lock +Upd) # Escape from form lock (class +Rid) # rid (dm T @ (=: rid T) (pass extra) ) (class +Align) (dm T @ (=: align T) (pass extra) ) (class +Limit) # lim (dm T (Exe . @) (=: lim Exe) (pass extra) ) (class +Clr0) (dm val> () (let N (extra) (unless (=0 N) N) ) ) (class +Var) # var (dm T (Var . @) (=: var Var) (pass extra) ) (dm set> (Val Dn) (extra (set (: var) Val) Dn) ) (dm upd> () (set> This (val (: var))) ) (class +Chk) # chk (dm T (Exe . @) (=: chk Exe) (pass extra) ) (dm chk> () (eval (: chk)) ) (class +Tip) # tip (dm T (Exe . @) (=: tip Exe) (pass extra) ) (dm show> ("Var") (<tip> (eval (: tip)) (extra "Var")) ) (dm js> () (pack (extra) "&?" (ht:Fmt (eval (: tip)))) ) (class +Tiny) (dm show> ("Var") (<style> 'tiny (extra "Var")) ) (class +Click) # clk (dm T (Exe . @) (=: clk Exe) (pass extra) ) (dm show> ("Var") (extra "Var") (and (atom "*Err") (eval (: clk)) (javascript NIL "window.setTimeout(\"document.getElementById(\\\"" "i" *Form "-" (: id) "\\\").click()\"," @ ")" ) ) ) (class +Focus) (dm show> ("Var") (extra "Var") (when (and (able) (not "*Foc")) (on "*Foc") (javascript NIL "window.setTimeout(\"document.getElementById(\\\"" "i" *Form "-" (: id) "\\\").focus()\",420)" ) ) ) ### Styles ### (class +Style) # style (dm T (Exe . @) (=: style Exe) (pass extra) ) (dm show> ("Var") (<style> (eval (: style)) (extra "Var")) ) (dm js> () (pack (extra) "&#" (eval (: style))) ) # Monospace font (class +Mono) (dm show> ("Var") (<style> "mono" (extra "Var")) ) (dm js> () (pack (extra) "&#mono") ) # Signum field (class +Sgn) (dm show> ("Var") (<style> (and (lt0 (val> This)) "red") (extra "Var")) ) (dm js> () (pack (extra) "&#" (and (lt0 (val> This)) "red")) ) ### Form field classes ### (de showFld "Prg" (when (: lbl) (ht:Prin (eval @)) (<nbsp>) ) (style (cons 'id (pack "i" *Form "-" (: id))) "Prg") ) (class +gui) # home id chg able chart (dm T () (push (=: home "*App") (cons (=: id "*Ix"))) (=: able T) ) (dm txt> (Val)) (dm set> (Val Dn)) (dm clr> () (set> This) ) (dm val> ()) (dm hint> (Str) Str ) (dm init> () (upd> This) ) (dm upd> ()) (dm chk> ()) (class +field +gui) (dm T () (super) (=: chg T) ) (dm txt> (Val) Val ) (dm js> () (let S (ht:Fmt (cdr (assoc (: id) (val *PRG)))) (if (able) S (pack S "&=")) ) ) (dm set> (Str Dn) (con (assoc (: id) (val (: home))) Str) (and (not Dn) (: chart) (set> (car @) (val> (car @)))) ) (dm str> () (cdr (assoc (: id) (val (: home)))) ) (dm val> () (str> This) ) # Get field (de field (X . @) (if (sym? X) (pass get (: home) X) (pass get (: home gui) (+ X (abs (: id)))) ) ) # Get current chart data row (de row (D) (+ (: chart 1 ofs) (: chart 2) -1 (or D 0)) ) (de curr @ (pass get (: chart 1 data) (row)) ) (de prev @ (pass get (: chart 1 data) (row -1)) ) (class +Button +gui) # img lbl alt act js # ([T] lbl [alt] act) (dm T @ (and (=: img (=T (next))) (next)) (=: lbl (arg)) (let X (next) (ifn (args) (=: act X) (=: alt X) (=: act (next)) ) ) (super) (set (car (val "*App")) (=: id (- (: id))) ) ) (dm js> () (if (able) (let Str (ht:Fmt (eval (: lbl))) (if (: img) (sesId Str) Str) ) (let Str (ht:Fmt (or (eval (: alt)) (eval (: lbl)))) (pack (if (: img) (sesId Str) Str) "&=") ) ) ) (dm show> ("Var") (<style> (cons 'id (pack "i" *Form "-" (: id))) (if (able) ((if (: img) <image> <submit>) (eval (: lbl)) "Var" NIL (: js) ) ((if (: img) <image> <submit>) (or (eval (: alt)) (eval (: lbl))) "Var" T (: js) ) ) ) ) (dm act> () (and (able) (eval (: act))) ) (class +OnClick) # onclick (dm T (Exe . @) (=: onclick Exe) (pass extra) ) (dm show> ("Var") (<js> (list (cons 'onclick (eval (: onclick)))) (extra "Var") ) ) (class +Drop) # "drop" drop (dm T (Fld . @) (=: "drop" Fld) (pass extra) ) (dm show> ("Var") (<js> (quote ("ondragenter" . "doDrag(event)") ("ondragover" . "doDrag(event)") ("ondrop" . "doDrop(this,event)") ) (extra "Var") ) ) (dm act> () (when (able) (=: drop (and (or *Drop (val> (eval (: "drop")))) (tmp @) ) ) (extra) (off *Drop) ) ) (class +JS) (dm T @ (=: js T) (pass extra) ) (class +Auto +JS) # auto (dm T (Fld Exe . @) (=: auto (cons Fld Exe)) (pass super) ) (dm act> () (when (able) (=: home auto (cons (eval (car (: auto))) (eval (cdr (: auto))) ) ) (extra) ) ) (class +DnButton +Tiny +Rid +JS +Able +Button) (dm T (Exe Lbl) (super '(> (length (chart 'data)) (chart 'ofs)) (or Lbl ">") (list 'scroll> (lit "*Chart") Exe) ) ) (de jsDn () (when (> (length (; "*Chart" data)) (; "*Chart" ofs)) (scroll> "*Chart" 1) ) ) (class +UpButton +Tiny +Rid +JS +Able +Button) (dm T (Exe Lbl) (super '(> (chart 'ofs) 1) (or Lbl "<") (list 'scroll> (lit "*Chart") (list '- Exe)) ) ) (de jsUp () (when (> (; "*Chart" ofs) 1) (scroll> "*Chart" -1) ) ) (class +GoButton +Tiny +Rid +JS +Able +Button) (dm T (Exe Lbl) (super (list 'and (list '>= '(length (chart 'data)) Exe) (list '<> '(chart 'ofs) Exe) ) Lbl (list 'goto> (lit "*Chart") Exe) ) ) (de scroll (N Flg) (when Flg (gui '(+Tip +GoButton) ,"Go to first line" 1 "|<") ) (gui '(+Tip +UpButton) ,"Scroll up one page" N "<<") (gui '(+Tip +UpButton) ,"Scroll up one line" 1) (gui '(+Tip +DnButton) ,"Scroll down one line" 1) (gui '(+Tip +DnButton) ,"Scroll down one page" N ">>") (when Flg (gui '(+Tip +GoButton) ,"Go to last line" (list '- '(length (chart 'data)) (dec N)) ">|" ) (<nbsp>) (gui '(+View +TextField) '(let? Len (gt0 (length (chart 'data))) (pack (chart 'ofs) "-" (min Len (dec (+ (chart 'ofs) (chart 'rows)))) " / " Len ) ) ) ) ) # Delete row (class +DelRowButton +Tiny +JS +Able +Tip +Button) # del exe (dm T (Txt Exe) (=: del Txt) (=: exe Exe) (super '(nth (: chart 1 data) (row)) ,"Delete row" "x" '(if (or (: home del) (not (curr))) (_delRow (: exe)) (ask (if (: del) (eval @) ,"Delete row?") (with (: home btn) (=: home del T) (_delRow (: exe)) ) ) ) ) ) (de _delRow (Exe) (eval Exe) (set> (: chart 1) (remove (row) (val> (: chart 1))) ) ) # Move row up (class +BubbleButton +Tiny +JS +Able +Tip +Button) (dm T () (super '(> (: chart 2) 1) ,"Shift row up" "\^" '(let L (val> (: chart 1)) (set> (: chart 1) (conc (cut (row -2) 'L) (cons (cadr L)) (cons (car L)) (cddr L) ) ) ) ) ) (class +ClrButton +JS +Tip +Button) # clr (dm T (Lbl Lst . @) (=: clr Lst) (pass super ,"Clear all input fields" Lbl '(for X (: clr) (if (atom X) (clr> (field X)) (set> (field (car X)) (eval (cdr X))) ) ) ) ) (class +ShowButton +Button) (dm T (Flg Exe) (super ,"Show" (list '=: 'home 'show (lit Exe)) ) (and Flg (=: home show Exe)) ) (class +Checkbox +field) # lbl # ([lbl]) (dm T (Lbl) (=: lbl Lbl) (super) ) (dm txt> (Val) (if Val ,"Yes" ,"No") ) (dm show> ("Var") (showFld (<check> "Var" (not (able)))) ) (dm set> (Val Dn) (super (bool Val) Dn) ) (dm val> () (bool (super)) ) (class +Radio +field) # Inited by Tomas Hlavaty <kvietaag@seznam.cz> # grp val lbl # (grp val [lbl]) (dm T (Grp Val Lbl) (super) (=: grp (if Grp (field @) This)) (=: val Val) (=: lbl Lbl) ) (dm show> ("Var") (showFld (<radio> (cons '*Gui (: grp id)) (: val) (not (able)) ) ) ) (dm js> () (pack (ht:Fmt (: val)) "&" (= (: val) (str> (: grp))) (unless (able) "&=") ) ) (dm set> (Val Dn) (when (== This (: grp)) (super Val Dn) ) ) (class +TextField +field) # dx dy lst lbl lim align # ([dx [dy] [lbl]]) # ([lst [lbl]]) (dm T (X . @) (nond ((num? X) (=: lst X) (=: lbl (next)) ) ((num? (next)) (=: dx X) (=: lbl (arg)) ) (NIL (=: dx X) (=: dy (arg)) (=: lbl (next)) ) ) (super) (or (: dx) (: lst) (=: chg)) ) (dm show> ("Var") (showFld (cond ((: dy) (<area> (: dx) (: dy) "Var" (not (able))) ) ((: dx) (<field> (if (: align) (- (: dx)) (: dx)) "Var" (eval (: lim)) (not (able)) ) ) ((: lst) (let (L (mapcar '(("X") (if (atom "X") (val "X") (cons (val (car "X")) (val (cdr "X"))) ) ) @ ) S (str> This) ) (<select> (if (or (member S L) (assoc S L)) L (cons S L) ) "Var" (not (able)) ) ) ) (T (<style> (cons 'id (pack "i" *Form "-" (: id))) (<span> *Style (if (str> This) (ht:Prin @) (<nbsp>)) ) ) ) ) ) ) (class +LinesField +TextField) (dm set> (Val Dn) (super (glue "^J" Val) Dn) ) (dm val> () (split (chop (super)) "^J") ) (class +ListTextField +TextField) # split (dm T (Lst . @) (=: split (or Lst '(" " "^I" "^J"))) (pass super) ) (dm set> (Val Dn) (super (glue (car (: split)) Val) Dn) ) (dm val> () (extract pack (apply split (: split) (chop (super))) ) ) # Password field (class +PwField +TextField) (dm show> ("Var") (showFld (<passwd> (: dx) "Var" (eval (: lim)) (not (able))) ) ) # Upload field (class +UpField +TextField) (dm show> ("Var") (showFld (<upload> (: dx) "Var" (not (able))) ) ) # Symbol fields (class +SymField +TextField) (dm val> () (let S (super) (and (<> "-" S) (intern S)) ) ) (dm set> (Val Dn) (super (name Val) Dn) ) (class +numField +Align +TextField) # scl (dm chk> () (and (str> This) (not (format @ (: scl) *Sep0 *Sep3)) ,"Numeric input expected" ) ) (class +NumField +numField) (dm txt> (Val) (format Val) ) (dm set> (Val Dn) (super (format Val) Dn) ) (dm val> () (format (super) NIL *Sep0 *Sep3) ) (class +FixField +numField) (dm T (N . @) (=: scl N) (pass super) ) (dm txt> (Val) (format Val (: scl) *Sep0 *Sep3) ) (dm set> (Val Dn) (super (format Val (: scl) *Sep0 *Sep3) Dn) ) (dm val> () (let S (super) (format (or (sub? *Sep0 S) (pack S *Sep0)) (: scl) *Sep0 *Sep3 ) ) ) (class +AtomField +Mono +TextField) (dm set> (Val Dn) (super (if (num? Val) (align (: dx) (format Val)) Val ) Dn ) ) (dm val> () (let S (super) (or (format S) S) ) ) (class +DateField +TextField) (dm txt> (Val) (datStr Val) ) (dm set> (Val Dn) (super (datStr Val) Dn) ) (dm val> () (expDat (super)) ) (dm chk> () (and (str> This) (not (val> This)) ,"Bad date format" ) ) (class +TimeField +TextField) (dm txt> (Val) (tim$ Val (> (: dx) 6)) ) (dm set> (Val Dn) (super (tim$ Val (> (: dx) 6)) Dn) ) (dm val> () ($tim (super)) ) (dm chk> () (and (str> This) (not (val> This)) ,"Bad time format" ) ) (class +Img +gui) # img alt url dx dy (dm T (Alt Url DX DY) (=: alt Alt) (=: url Url) (=: dx DX) (=: dy DY) (super) ) (dm js> () (pack (ht:Fmt (sesId (or (: img) "@img/no.png"))) "&" (eval (: alt)) "&" (and (eval (: url)) (ht:Fmt (sesId @))) ) ) (dm show> ("Var") (showFld (<img> (or (: img) "@img/no.png") (eval (: alt)) (eval (: url)) (: dx) (: dy) ) ) ) (dm set> (Val Dn) (=: img Val) ) (dm val> () (: img) ) (class +Icon) # icon url (dm T (Exe Url . @) (=: icon Exe) (=: url Url) (pass extra) ) (dm js> () (pack (extra) "&*" (ht:Fmt (sesId (eval (: icon)))) "&" (and (eval (: url)) (ht:Fmt (sesId @))) ) ) (dm show> ("Var") (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") (extra "Var") (prin "</td><td>") (<img> (eval (: icon)) 'icon (eval (: url))) (prinl "</td></table>") ) (class +FileField +TextField) # file org (dm T (Exe . @) (=: file Exe) (pass super) ) (dm set> (Val Dn) (and (<> Val (: org)) (eval (: file)) (out @ (ctl T (prin (=: org Val)))) ) (super Val Dn) ) (dm upd> () (set> This (=: org (let? F (eval (: file)) (and (info F) (in F (ctl NIL (till NIL T))) ) ) ) ) ) (class +Url) # url (dm T (Fun . @) (=: url Fun) (pass extra) ) (dm js> () (if2 (or (: dx) (: lst)) (txt> This (val> This)) (pack (extra) "&*" (ht:Fmt (sesId "@img/go.png")) "&" (ht:Fmt (sesId ((: url) @)))) (pack (extra) "&*" (ht:Fmt (sesId "@img/no.png")) "&") (pack @ "&+" (ht:Fmt (sesId ((: url) @)))) (extra) ) ) (dm show> ("Var") (cond ((or (: dx) (: lst)) (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") (extra "Var") (prin "</td><td title=\"-->\">") (if (val> This) (<img> "@img/go.png" 'url ((: url) (txt> This @))) (<img> "@img/no.png") ) (prinl "</td></table>") ) ((val> This) (showFld (<href> @ ((: url) (txt> This @)))) ) (T (extra "Var")) ) ) (class +HttpField +Url +TextField) (dm T @ (pass super '((S) (or (sub? "://" S) (pack "http://" S))) ) ) (class +MailField +Url +TextField) (dm T @ (pass super '((S) (pack "mailto:" S))) ) (class +TelField +TextField) (dm txt> (Val) (telStr Val) ) (dm set> (Val Dn) (super (telStr Val) Dn) ) (dm val> () (expTel (super)) ) (dm chk> () (and (str> This) (not (val> This)) ,"Bad phone number format" ) ) (class +SexField +Map +TextField) (dm T (Lbl) (super '((,"male" . T) (,"female" . 0)) '(NIL ,"male" ,"female") Lbl ) ) (class +JsField +gui) # js str (dm T (Nm) (super) (=: js Nm) ) (dm show> ("Var")) (dm js> () (pack (ht:Fmt NIL (: str) (: js))) ) (dm set> (Val Dn) (=: str Val) ) ### GUI charts ### (class +Chart) # home gui rows cols ofs lock put get data clip # (cols [put [get]]) (dm T (N Put Get) (setq "*Chart" This) (queue (prop (=: home "*App") 'chart) This) (=: rows 1) (when N (=: gui (list (need (=: cols N)))) ) (=: ofs 1) (=: lock T) (=: put (or Put prog1)) (=: get (or Get prog1)) ) (dm put> () (let I (: ofs) (mapc '((G D) (unless (memq NIL G) (mapc 'set> G ((: put) D I) '(T .)) ) (inc 'I) ) (: gui) (nth (: data) I) ) ) ) (dm get> () (and (or (: rid) (: home able)) (not (: lock)) (let I (: ofs) (map '((G D) (set D (trim ((: get) (mapcar 'val> (car G)) (car D) (car G) ) ) ) (mapc 'set> (car G) ((: put) (car D) I) '(T .) ) (inc 'I) ) (: gui) (nth (=: data (need (- 1 I (: rows)) (: data)) ) I ) ) (=: data (trim (: data))) ) ) ) (dm scroll> (N) (get> This) (unless (gt0 (inc (:: ofs) N)) (=: ofs 1) ) (put> This) ) (dm goto> (N) (get> This) (=: ofs (max 1 N)) (put> This) ) (dm find> ("Fun") (get> This) (let "D" (cdr (nth (: data) (: ofs))) (=: ofs (if (find "Fun" "D") (index @ (: data)) 1 ) ) ) (put> This) ) (dm txt> (Flg) (for (I . L) (: data) (map '((G D) (prin (txt> (car G) (car D))) (if (cdr G) (prin "^I") (prinl (and Flg "^M")) ) ) (: gui 1) ((: put) L I) ) ) ) (dm set> (Lst) (=: ofs (max 1 (min (: ofs) (length (=: data (copy Lst)))) ) ) (put> This) Lst ) (dm log> (Lst) (=: ofs (max (: ofs) (- (length (: data)) (: rows) -2))) (set> This (conc (val> This) (cons Lst))) ) (dm clr> () (set> This) ) (dm val> () (get> This) (: data) ) (dm init> () (upd> This) ) (dm upd> ()) (dm chk> ()) (dm cut> (N) (get> This) (=: clip (get (val> This) (: ofs))) (set> This (remove (or N (: ofs)) (val> This)) ) ) (dm paste> (Flg N) (get> This) (set> This (insert (or N (: ofs)) (val> This) (unless Flg (: clip)) ) ) ) (class +Chart1 +Chart) # (cols) (dm T (N) (super N list car) ) ### DB GUI ### (de newUrl @ (prog1 (pass new!) (lock (setq *Lock @)) (apply url (url> @ 1)) ) ) # (choDlg Dst Ttl Rel [Hook] [((+XyzField) ..) Exe Able [Rel2 [Hook2]]]) (de choDlg (Dst Ttl Rel . @) (let (Hook (and (meta (cdr Rel) (car Rel) 'hook) (next)) Fld (or (next) '((+TextField) 40)) Gui (if (next) (list '(+ObjView +TextField) @) (list (list '+ObjView (last (car Fld))) (list ': (car Rel))) ) Able (if (args) (next) T) ) (nond ((next) (setq Ttl (list Ttl (car Rel) (last Rel) Hook)) ) ((=T (arg)) (setq Ttl (list Ttl (car (arg)) (cadr (arg)) (next))) ) ) (diaform '(Dst Ttl Rel Hook Fld Gui Able) (apply gui (cons (cons '+Focus '+Var (car Fld)) (cdr (or (assoc Rel "*Cho") (push '"*Cho" (list Rel NIL)))) (cdr Fld) ) ) (searchButton '(init> (: home query))) (gui 'query '(+QueryChart) (cho) '(goal (list (list 'db (car Rel) (last Rel) Hook (val> (: home gui 1)) '@@) ) ) 2 '((Obj) (list Obj Obj)) ) (<table> 'chart (if (atom Ttl) Ttl (apply choTtl Ttl)) '((btn) NIL) (do (cho) (<row> (alternating) (gui 1 '(+DstButton) Dst) (apply gui Gui 2) ) ) ) (<spread> (scroll (cho)) (if (meta (cdr Rel) (car Rel) 'hook) (newButton Able Dst (cdr Rel) (meta (cdr Rel) (car Rel) 'hook) Hook (car Rel) (let? Val (val> (: home gui 1)) (unless (db (car Rel) (last Rel) Hook Val) Val ) ) ) (newButton Able Dst (cdr Rel) (car Rel) (let? Val (val> (: home gui 1)) (unless (db (car Rel) (last Rel) Val) Val ) ) ) ) (cancelButton) ) ) ) ) (de choTtl (Ttl Var Cls Hook) (with (or (get Cls Var) (meta Cls Var)) (if (or (isa '+Idx This) (isa '+IdxFold This)) Ttl (pack (count (tree (: var) (: cls) Hook)) " " Ttl) ) ) ) (de cho () (if (: diaform) 16 8) ) # Able object (class +AO +Able) # ao (dm T (Exe . @) (=: ao Exe) (pass super '(and (: home obj) (not (: home obj T)) (eval (: ao)) ) ) ) # Lock/Edit button prefix (class +Edit +Rid +Force +Tip) # save (dm T (Exe) (=: save Exe) (super '(nor (: home able) (lock (: home obj))) '(if (: home able) ,"Release exclusive write access for this object" ,"Gain exclusive write access for this object" ) '(if (: home able) ,"Done" ,"Edit") '(if (: home able) (when (able) (eval (: save)) (unless (pair "*Err") (rollback) (off *Lock) ) ) (tryLock (: home obj)) ) ) ) (de tryLock (Obj) (if (lock Obj) (error (text ,"Currently edited by '@2' (@1)" @ (cdr (lup *Users @)))) (sync) (tell) (setq *Lock Obj) ) ) (de editButton (Able Exe) (<style> (and (: able) 'edit) (gui '(+AO +Focus +Edit +Button) Able Exe) ) ) (de searchButton (Exe) (gui '(+Rid +JS +Tip +Button) ,"Start search" ,"Search" Exe) ) (de resetButton (Lst) (gui '(+Force +ClrButton) T ,"Reset" Lst) ) (de newButton (Able Dst . Args) (gui '(+Rid +Able +Close +Tip +Button) Able ,"Create new object" ',"New" (nond (Dst (cons 'newUrl Args)) ((pair Dst) (list 'set> (lit Dst) (cons 'new! Args)) ) (NIL (list 'prog (list '=: 'obj (cons 'new! Args)) Dst) ) ) ) ) # Clone object in form (de cloneButton (Able) (gui '(+Rid +Able +Tip +Button) (or Able T) ,"Create a new copy of this object" ,"New/Copy" '(apply url (url> (prog1 (clone!> (: home obj)) (lock (setq *Lock @)) ) 1 ) ) ) ) # Delete object in form (de delButton (Able @Txt) (gui '(+Force +Rid +Able +Tip +Button) T Able '(if (: home obj T) ,"Mark this object as \"not deleted\"" ,"Mark this object as \"deleted\"" ) '(if (: home obj T) ,"Restore" ,"Delete") (fill '(nond ((: home obj T) (ask (text ,"Delete @1?" @Txt) (lose!> (: home top 1 obj)) ) ) ((keep?> (: home obj)) (ask (text ,"Restore @1?" @Txt) (keep!> (: home top 1 obj)) ) ) (NIL (note ,"Restore" (mapcar '((X) (text "'@1' -- @2" (car X) (cdr X))) @ ) ) ) ) ) ) ) # Relations (class +/R +Able) # erVar erObj (dm T (Lst . @) (=: erVar (car Lst)) (=: erObj (cdr Lst)) (pass super '(and (eval (: erObj)) (not (get @ T))) ) ) (dm upd> () (set> This (get (eval (: erObj)) (: erVar))) ) # Symbol/Relation (class +S/R +/R) (dm set> (Val Dn) (and (eval (: erObj)) (put! @ (: erVar) Val) ) (extra Val Dn) ) # Entity/Relation (class +E/R +/R) (dm set> (Val Dn) (and (not (: lock)) (eval (: erObj)) (put!> @ (: erVar) Val) ) (extra Val Dn) ) (dm chk> () (or (extra) (and (eval (: erObj)) (mis> @ (: erVar) (val> This)) ) ) ) (class +SubE/R +E/R) # sub (dm T (Lst . @) (pass super (cons (pop 'Lst) (append '(: home obj) (cons (car Lst))) ) ) (=: sub Lst) (=: able (bool (: able))) ) (dm set> (Val Dn) (when (and Val (not (eval (: erObj)))) (dbSync) (put> (: home obj) (: sub 1) (new (or (meta (: sub -1) 'Dbf 1) 1) (: sub -1)) ) (commit 'upd) ) (super Val Dn) ) (class +BlobField +/R +TextField) # org (dm set> (Val Dn) (and (not (: lock)) (<> Val (: org)) (let? Obj (eval (: erObj)) (protect (when (put!> Obj (: erVar) (bool Val)) (out (blob Obj (: erVar)) (prin (=: org Val)) ) (blob+ Obj (: erVar)) ) ) ) ) (super Val Dn) ) (dm upd> () (set> This (=: org (let? Obj (eval (: erObj)) (when (get Obj (: erVar)) (in (blob Obj (: erVar)) (till NIL T) ) ) ) ) ) ) (class +ClassField +Map +TextField) # erObj (dm T (Exe Lst) (=: erObj Exe) (super Lst (mapcar car Lst)) ) (dm upd> () (set> This (val (eval (: erObj)))) ) (dm set> (Val Dn) (and (eval (: erObj)) (set!> @ Val) ) (super Val Dn) ) (class +obj) # msg obj # ([T|msg] ..) (dm T () (ifn (atom (next)) (=: msg 'url>) (=: msg (arg)) (next) ) ) (dm js> () (if (=T (: msg)) (extra) (if2 (or (: dx) (: lst)) (try (: msg) (: obj) 1) (pack (extra) "&*" (ht:Fmt (sesId "@img/go.png")) "&" (ht:Fmt (sesId (mkUrl @)))) (pack (extra) "&*" (ht:Fmt (sesId "@img/no.png")) "&") (pack (ht:Fmt (nonblank (str> This))) "&+" (ht:Fmt (sesId (mkUrl @)))) (extra) ) ) ) (dm show> ("Var") (cond ((=T (: msg)) (extra "Var")) ((or (: dx) (: lst)) (prin "<table cellspacing=\"0\" cellpadding=\"0\"><td>") (extra "Var") (prin "</td><td title=\"-->\">") (if (try (: msg) (: obj) 1) (<img> "@img/go.png" 'obj (mkUrl @)) (<img> "@img/no.png") ) (prinl "</td></table>") ) ((try (: msg) (: obj) 1) (showFld (<href> (nonblank (str> This)) (mkUrl @))) ) (T (extra "Var")) ) ) (class +Obj +hint +obj) # objVar objTyp objHook # ([T|msg] (var . typ) [hook] [T] ..) (dm T @ (super) (=: objVar (car (arg))) (=: objTyp (cdr (arg))) (when (meta (: objTyp) (: objVar) 'hook) (=: objHook (next)) ) (pass extra (if (nT (next)) (arg) (cons NIL (if (: objHook) (collect (: objVar) (last (: objTyp)) (eval @) NIL T (: objVar)) (collect (: objVar) (last (: objTyp)) NIL T (: objVar)) ) ) ) ) ) (dm hint> (Str) (dbHint (extra Str) (: objVar) (last (: objTyp)) (: objHook) ) ) (dm txt> (Obj) (if (ext? Obj) (get Obj (: objVar)) Obj ) ) (dm set> (Obj Dn) (extra (if (ext? (=: obj Obj)) (get Obj (: objVar)) Obj ) Dn ) ) (dm val> () (let Val (extra) (cond ((and (: obj) (not (ext? @))) Val) ((= Val (get (: obj) (: objVar))) (: obj) ) ((: objTyp) (=: obj (if (: objHook) (db (: objVar) (last (: objTyp)) (eval @) Val) (db (: objVar) (last (: objTyp)) Val) ) ) ) (T Val) ) ) ) (dm chk> () (or (extra) (let? S (str> This) (and (: objTyp) (not (val> This)) (<> "-" S) ,"Data not found" ) ) ) ) (class +ObjView +obj) # disp obj # ([T|msg] exe ..) (dm T @ (super) (=: disp (arg)) (pass extra) (=: able) ) (dm txt> (Obj) (let Exe (: disp) (if (ext? Obj) (with Obj (eval Exe)) Obj ) ) ) (dm set> (Obj Dn) (let Exe (: disp) (extra (if (ext? (=: obj Obj)) (with Obj (eval Exe)) Obj ) Dn ) ) ) (dm val> () (: obj) ) # DB query chart (class +QueryChart +Chart) # iniR iniQ query # (iniR iniQ cols [put [get]]) (dm T (R Q . @) (=: iniR R) (=: iniQ Q) (pass super) ) (dm init> () (query> This (eval (: iniQ))) ) (dm put> () (while (and (> (: ofs) (- (length (: data)) (max (: rows) (: iniR)))) (; (prove (: query)) @@) ) (queue (:: data) @) ) (super) ) (dm txt> (Flg) (for ((I . Q) (eval (: iniQ)) (prove Q)) (map '((G D) (prin (txt> (car G) (car D))) (if (cdr G) (prin "^I") (prinl (and Flg "^M")) ) ) (: gui 1) ((: put) (; @ @@) I) ) ) ) (dm all> () (make (for (Q (eval (: iniQ)) (prove Q)) (link (; @ @@)) ) ) ) (dm query> (Q) (=: query Q) (set> This) ) (dm sort> (Exe) (set> This (goal (list (list 'lst '@@ (by '((This) (eval Exe)) sort (val> This)) ) ) ) ) ) (dm clr> () (query> This (fail)) ) (====) # Form object (de <id> "Lst" (idObj "Lst") ) (de idObj ("Lst") (with (if *PRG (: obj) (=: obj *ID)) (and (: T) (prin "[")) (for "X" (if (=T (car "Lst")) (cdr "Lst") "Lst") (ht:Prin (eval "X")) ) (and (: T) (prin "]")) ) (=: able (cond ((: obj T)) ((not (: obj))) ((=T (car "Lst")) T) ((== *Lock (: obj)) T) (*Lock (rollback) (off *Lock)) ) ) ) (de panel (Able Txt Del Dlg Var Cls Hook Msg Exe) (<spread> (editButton Able Exe) (delButton (cond ((=T Able) Del) ((=T Del) Able) ((and Able Del) (list 'and Able Del)) ) (list 'text Txt (if (pair Var) (list 'with '(: home obj) (car Var)) (list ': 'home 'obj Var) ) ) ) (choButton Dlg) (stepBtn (fin Var) Cls Hook Msg) ) (--) ) # Standard ID form (de idForm ("Entity" "Cho" "Var" "Cls" "Able" "Del" "Lst" . "Prg") (ifn *ID (prog (<h3> NIL ,"Select" " " "Entity") (form 'dialog (if (pair "Cho") (eval @) (choDlg NIL "Cho" (list (fin "Var") "Cls")) ) ) ) (form NIL (<h3> NIL "Entity" ": " (idObj "Lst")) (panel "Able" (pack "Entity" " '@1'") "Del" (or (pair "Cho") (list 'choDlg NIL (lit "Cho") (lit (list (fin "Var") "Cls"))) ) "Var" "Cls" ) (run "Prg") ) ) ) ### Debug ### `*Dbg (noLint 'gui) (noLint 'choDlg 'gui) (noLint 'jsForm 'action) # vi:et:ts=3:sw=3 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/frac.l��������������������������������������������������������������������0000644�0000000�0000000�00000003126�12265263724�015010� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 26may11abu # (c) Software Lab. Alexander Burger (de gcd (A B) (until (=0 B) (let M (% A B) (setq A B B M) ) ) (abs A) ) (de lcm (A B) (*/ A B (gcd A B)) ) (de frac (N D) (if (=0 N) (cons 0 1) (and (=0 D) (quit "frac/0" N)) (let G (gcd N D) (if (gt0 N) (cons (/ N G) (/ D G)) (cons (- (/ N G)) (- (/ D G))) ) ) ) ) (de fabs (A) (cons (abs (car A)) (cdr A)) ) (de 1/f (A) (and (=0 (car A)) (quit "frac/0" A)) (if (gt0 (car A)) (cons (cdr A) (car A)) (cons (- (cdr A)) (- (car A))) ) ) (de f+ (A B) (let D (lcm (cdr A) (cdr B)) (let N (+ (* (/ D (cdr A)) (car A)) (* (/ D (cdr B)) (car B)) ) (if (=0 N) (cons 0 1) (let G (gcd N D) (cons (/ N G) (/ D G)) ) ) ) ) ) (de f- (A B) (if B (f+ A (f- B)) (cons (- (car A)) (cdr A)) ) ) (de f* (A B) (let (G (gcd (car A) (cdr B)) H (gcd (car B) (cdr A))) (cons (* (/ (car A) G) (/ (car B) H)) (* (/ (cdr A) H) (/ (cdr B) G)) ) ) ) (de f/ (A B) (f* A (1/f B)) ) (de f** (A N) (if (ge0 N) (cons (** (car A) N) (** (cdr A) N)) (cons (** (cdr A) (- N)) (** (car A) (- N))) ) ) (de fcmp (A B) (if (gt0 (* (car A) (car B))) (let Q (f/ A B) (* (if (gt0 (car A)) 1 -1) (- (car Q) (cdr Q))) ) (- (car A) (car B)) ) ) (de f< (A B) (lt0 (fcmp A B)) ) (de f<= (A B) (ge0 (fcmp B A)) ) (de f> (A B) (gt0 (fcmp A B)) ) (de f>= (A B) (ge0 (fcmp A B)) ) # vi:et:ts=3:sw=3 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/gcc.l���������������������������������������������������������������������0000644�0000000�0000000�00000003133�12265263724�014627� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 10oct08abu # (c) Software Lab. Alexander Burger (de gcc (S L . @) (out (tmp S ".c") (chdir '@ (prinl "#include \"" (pwd) "/src/pico.h\"")) (here "/**/") ) ~(case *OS (("Linux" "FreeBSD") (quote (apply call L 'gcc "-m32" "-o" (tmp S) "-shared" "-export-dynamic" "-O" "-falign-functions" "-fomit-frame-pointer" "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" "-Wuninitialized" "-Wstrict-prototypes" "-pipe" "-D_GNU_SOURCE" "-D_FILE_OFFSET_BITS=64" (tmp S ".c") ) ) ) ("Darwin" (quote (apply call L 'gcc "-o" (tmp S) "-dynamiclib" "-undefined" "dynamic_lookup" "-O" "-falign-functions" "-fomit-frame-pointer" "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" "-Wuninitialized" "-Wstrict-prototypes" "-pipe" "-D_GNU_SOURCE" "-D_FILE_OFFSET_BITS=64" (tmp S ".c") ) ) ) ("Cygwin" (quote (call 'gcc "-c" "-Os" "-falign-functions" "-fomit-frame-pointer" "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" "-Wuninitialized" "-Wstrict-prototypes" "-pipe" "-D_GNU_SOURCE" "-D_FILE_OFFSET_BITS=64" (pack "-I" (path "@src") ) "-o" (tmp S ".o") (tmp S ".c")) (apply call L 'gcc "-shared" "-o" (tmp S ".dll") (tmp S ".o") (path "@bin/picolisp.dll") ) ) ) ) (while (args) (def (next) (def (tmp S ': (arg)))) ) ) # vi:et:ts=3:sw=3 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/glyphlist.txt�������������������������������������������������������������0000644�0000000�0000000�00000230570�12265263724�016505� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# ################################################################################### # Copyright (c) 1997,1998,2002,2007 Adobe Systems Incorporated # # Permission is hereby granted, free of charge, to any person obtaining a # copy of this documentation file to use, copy, publish, distribute, # sublicense, and/or sell copies of the documentation, and to permit # others to do the same, provided that: # - No modification, editing or other alteration of this document is # allowed; and # - The above copyright notice and this permission notice shall be # included in all copies of the documentation. # # Permission is hereby granted, free of charge, to any person obtaining a # copy of this documentation file, to create their own derivative works # from the content of this document to use, copy, publish, distribute, # sublicense, and/or sell the derivative works, and to permit others to do # the same, provided that the derived work is not represented as being a # copy or version of this document. # # Adobe shall not be liable to any party for any loss of revenue or profit # or for indirect, incidental, special, consequential, or other similar # damages, whether based on tort (including without limitation negligence # or strict liability), contract or other legal or equitable grounds even # if Adobe has been advised or had reason to know of the possibility of # such damages. The Adobe materials are provided on an "AS IS" basis. # Adobe specifically disclaims all express, statutory, or implied # warranties relating to the Adobe materials, including but not limited to # those concerning merchantability or fitness for a particular purpose or # non-infringement of any third party rights regarding the Adobe # materials. # ################################################################################### # Name: Adobe Glyph List # Table version: 2.0 # Date: September 20, 2002 # # See http://partners.adobe.com/asn/developer/typeforum/unicodegn.html # # Format: Semicolon-delimited fields: # (1) glyph name # (2) Unicode scalar value A;0041 AE;00C6 AEacute;01FC AEmacron;01E2 AEsmall;F7E6 Aacute;00C1 Aacutesmall;F7E1 Abreve;0102 Abreveacute;1EAE Abrevecyrillic;04D0 Abrevedotbelow;1EB6 Abrevegrave;1EB0 Abrevehookabove;1EB2 Abrevetilde;1EB4 Acaron;01CD Acircle;24B6 Acircumflex;00C2 Acircumflexacute;1EA4 Acircumflexdotbelow;1EAC Acircumflexgrave;1EA6 Acircumflexhookabove;1EA8 Acircumflexsmall;F7E2 Acircumflextilde;1EAA Acute;F6C9 Acutesmall;F7B4 Acyrillic;0410 Adblgrave;0200 Adieresis;00C4 Adieresiscyrillic;04D2 Adieresismacron;01DE Adieresissmall;F7E4 Adotbelow;1EA0 Adotmacron;01E0 Agrave;00C0 Agravesmall;F7E0 Ahookabove;1EA2 Aiecyrillic;04D4 Ainvertedbreve;0202 Alpha;0391 Alphatonos;0386 Amacron;0100 Amonospace;FF21 Aogonek;0104 Aring;00C5 Aringacute;01FA Aringbelow;1E00 Aringsmall;F7E5 Asmall;F761 Atilde;00C3 Atildesmall;F7E3 Aybarmenian;0531 B;0042 Bcircle;24B7 Bdotaccent;1E02 Bdotbelow;1E04 Becyrillic;0411 Benarmenian;0532 Beta;0392 Bhook;0181 Blinebelow;1E06 Bmonospace;FF22 Brevesmall;F6F4 Bsmall;F762 Btopbar;0182 C;0043 Caarmenian;053E Cacute;0106 Caron;F6CA Caronsmall;F6F5 Ccaron;010C Ccedilla;00C7 Ccedillaacute;1E08 Ccedillasmall;F7E7 Ccircle;24B8 Ccircumflex;0108 Cdot;010A Cdotaccent;010A Cedillasmall;F7B8 Chaarmenian;0549 Cheabkhasiancyrillic;04BC Checyrillic;0427 Chedescenderabkhasiancyrillic;04BE Chedescendercyrillic;04B6 Chedieresiscyrillic;04F4 Cheharmenian;0543 Chekhakassiancyrillic;04CB Cheverticalstrokecyrillic;04B8 Chi;03A7 Chook;0187 Circumflexsmall;F6F6 Cmonospace;FF23 Coarmenian;0551 Csmall;F763 D;0044 DZ;01F1 DZcaron;01C4 Daarmenian;0534 Dafrican;0189 Dcaron;010E Dcedilla;1E10 Dcircle;24B9 Dcircumflexbelow;1E12 Dcroat;0110 Ddotaccent;1E0A Ddotbelow;1E0C Decyrillic;0414 Deicoptic;03EE Delta;2206 Deltagreek;0394 Dhook;018A Dieresis;F6CB DieresisAcute;F6CC DieresisGrave;F6CD Dieresissmall;F7A8 Digammagreek;03DC Djecyrillic;0402 Dlinebelow;1E0E Dmonospace;FF24 Dotaccentsmall;F6F7 Dslash;0110 Dsmall;F764 Dtopbar;018B Dz;01F2 Dzcaron;01C5 Dzeabkhasiancyrillic;04E0 Dzecyrillic;0405 Dzhecyrillic;040F E;0045 Eacute;00C9 Eacutesmall;F7E9 Ebreve;0114 Ecaron;011A Ecedillabreve;1E1C Echarmenian;0535 Ecircle;24BA Ecircumflex;00CA Ecircumflexacute;1EBE Ecircumflexbelow;1E18 Ecircumflexdotbelow;1EC6 Ecircumflexgrave;1EC0 Ecircumflexhookabove;1EC2 Ecircumflexsmall;F7EA Ecircumflextilde;1EC4 Ecyrillic;0404 Edblgrave;0204 Edieresis;00CB Edieresissmall;F7EB Edot;0116 Edotaccent;0116 Edotbelow;1EB8 Efcyrillic;0424 Egrave;00C8 Egravesmall;F7E8 Eharmenian;0537 Ehookabove;1EBA Eightroman;2167 Einvertedbreve;0206 Eiotifiedcyrillic;0464 Elcyrillic;041B Elevenroman;216A Emacron;0112 Emacronacute;1E16 Emacrongrave;1E14 Emcyrillic;041C Emonospace;FF25 Encyrillic;041D Endescendercyrillic;04A2 Eng;014A Enghecyrillic;04A4 Enhookcyrillic;04C7 Eogonek;0118 Eopen;0190 Epsilon;0395 Epsilontonos;0388 Ercyrillic;0420 Ereversed;018E Ereversedcyrillic;042D Escyrillic;0421 Esdescendercyrillic;04AA Esh;01A9 Esmall;F765 Eta;0397 Etarmenian;0538 Etatonos;0389 Eth;00D0 Ethsmall;F7F0 Etilde;1EBC Etildebelow;1E1A Euro;20AC Ezh;01B7 Ezhcaron;01EE Ezhreversed;01B8 F;0046 Fcircle;24BB Fdotaccent;1E1E Feharmenian;0556 Feicoptic;03E4 Fhook;0191 Fitacyrillic;0472 Fiveroman;2164 Fmonospace;FF26 Fourroman;2163 Fsmall;F766 G;0047 GBsquare;3387 Gacute;01F4 Gamma;0393 Gammaafrican;0194 Gangiacoptic;03EA Gbreve;011E Gcaron;01E6 Gcedilla;0122 Gcircle;24BC Gcircumflex;011C Gcommaaccent;0122 Gdot;0120 Gdotaccent;0120 Gecyrillic;0413 Ghadarmenian;0542 Ghemiddlehookcyrillic;0494 Ghestrokecyrillic;0492 Gheupturncyrillic;0490 Ghook;0193 Gimarmenian;0533 Gjecyrillic;0403 Gmacron;1E20 Gmonospace;FF27 Grave;F6CE Gravesmall;F760 Gsmall;F767 Gsmallhook;029B Gstroke;01E4 H;0048 H18533;25CF H18543;25AA H18551;25AB H22073;25A1 HPsquare;33CB Haabkhasiancyrillic;04A8 Hadescendercyrillic;04B2 Hardsigncyrillic;042A Hbar;0126 Hbrevebelow;1E2A Hcedilla;1E28 Hcircle;24BD Hcircumflex;0124 Hdieresis;1E26 Hdotaccent;1E22 Hdotbelow;1E24 Hmonospace;FF28 Hoarmenian;0540 Horicoptic;03E8 Hsmall;F768 Hungarumlaut;F6CF Hungarumlautsmall;F6F8 Hzsquare;3390 I;0049 IAcyrillic;042F IJ;0132 IUcyrillic;042E Iacute;00CD Iacutesmall;F7ED Ibreve;012C Icaron;01CF Icircle;24BE Icircumflex;00CE Icircumflexsmall;F7EE Icyrillic;0406 Idblgrave;0208 Idieresis;00CF Idieresisacute;1E2E Idieresiscyrillic;04E4 Idieresissmall;F7EF Idot;0130 Idotaccent;0130 Idotbelow;1ECA Iebrevecyrillic;04D6 Iecyrillic;0415 Ifraktur;2111 Igrave;00CC Igravesmall;F7EC Ihookabove;1EC8 Iicyrillic;0418 Iinvertedbreve;020A Iishortcyrillic;0419 Imacron;012A Imacroncyrillic;04E2 Imonospace;FF29 Iniarmenian;053B Iocyrillic;0401 Iogonek;012E Iota;0399 Iotaafrican;0196 Iotadieresis;03AA Iotatonos;038A Ismall;F769 Istroke;0197 Itilde;0128 Itildebelow;1E2C Izhitsacyrillic;0474 Izhitsadblgravecyrillic;0476 J;004A Jaarmenian;0541 Jcircle;24BF Jcircumflex;0134 Jecyrillic;0408 Jheharmenian;054B Jmonospace;FF2A Jsmall;F76A K;004B KBsquare;3385 KKsquare;33CD Kabashkircyrillic;04A0 Kacute;1E30 Kacyrillic;041A Kadescendercyrillic;049A Kahookcyrillic;04C3 Kappa;039A Kastrokecyrillic;049E Kaverticalstrokecyrillic;049C Kcaron;01E8 Kcedilla;0136 Kcircle;24C0 Kcommaaccent;0136 Kdotbelow;1E32 Keharmenian;0554 Kenarmenian;053F Khacyrillic;0425 Kheicoptic;03E6 Khook;0198 Kjecyrillic;040C Klinebelow;1E34 Kmonospace;FF2B Koppacyrillic;0480 Koppagreek;03DE Ksicyrillic;046E Ksmall;F76B L;004C LJ;01C7 LL;F6BF Lacute;0139 Lambda;039B Lcaron;013D Lcedilla;013B Lcircle;24C1 Lcircumflexbelow;1E3C Lcommaaccent;013B Ldot;013F Ldotaccent;013F Ldotbelow;1E36 Ldotbelowmacron;1E38 Liwnarmenian;053C Lj;01C8 Ljecyrillic;0409 Llinebelow;1E3A Lmonospace;FF2C Lslash;0141 Lslashsmall;F6F9 Lsmall;F76C M;004D MBsquare;3386 Macron;F6D0 Macronsmall;F7AF Macute;1E3E Mcircle;24C2 Mdotaccent;1E40 Mdotbelow;1E42 Menarmenian;0544 Mmonospace;FF2D Msmall;F76D Mturned;019C Mu;039C N;004E NJ;01CA Nacute;0143 Ncaron;0147 Ncedilla;0145 Ncircle;24C3 Ncircumflexbelow;1E4A Ncommaaccent;0145 Ndotaccent;1E44 Ndotbelow;1E46 Nhookleft;019D Nineroman;2168 Nj;01CB Njecyrillic;040A Nlinebelow;1E48 Nmonospace;FF2E Nowarmenian;0546 Nsmall;F76E Ntilde;00D1 Ntildesmall;F7F1 Nu;039D O;004F OE;0152 OEsmall;F6FA Oacute;00D3 Oacutesmall;F7F3 Obarredcyrillic;04E8 Obarreddieresiscyrillic;04EA Obreve;014E Ocaron;01D1 Ocenteredtilde;019F Ocircle;24C4 Ocircumflex;00D4 Ocircumflexacute;1ED0 Ocircumflexdotbelow;1ED8 Ocircumflexgrave;1ED2 Ocircumflexhookabove;1ED4 Ocircumflexsmall;F7F4 Ocircumflextilde;1ED6 Ocyrillic;041E Odblacute;0150 Odblgrave;020C Odieresis;00D6 Odieresiscyrillic;04E6 Odieresissmall;F7F6 Odotbelow;1ECC Ogoneksmall;F6FB Ograve;00D2 Ogravesmall;F7F2 Oharmenian;0555 Ohm;2126 Ohookabove;1ECE Ohorn;01A0 Ohornacute;1EDA Ohorndotbelow;1EE2 Ohorngrave;1EDC Ohornhookabove;1EDE Ohorntilde;1EE0 Ohungarumlaut;0150 Oi;01A2 Oinvertedbreve;020E Omacron;014C Omacronacute;1E52 Omacrongrave;1E50 Omega;2126 Omegacyrillic;0460 Omegagreek;03A9 Omegaroundcyrillic;047A Omegatitlocyrillic;047C Omegatonos;038F Omicron;039F Omicrontonos;038C Omonospace;FF2F Oneroman;2160 Oogonek;01EA Oogonekmacron;01EC Oopen;0186 Oslash;00D8 Oslashacute;01FE Oslashsmall;F7F8 Osmall;F76F Ostrokeacute;01FE Otcyrillic;047E Otilde;00D5 Otildeacute;1E4C Otildedieresis;1E4E Otildesmall;F7F5 P;0050 Pacute;1E54 Pcircle;24C5 Pdotaccent;1E56 Pecyrillic;041F Peharmenian;054A Pemiddlehookcyrillic;04A6 Phi;03A6 Phook;01A4 Pi;03A0 Piwrarmenian;0553 Pmonospace;FF30 Psi;03A8 Psicyrillic;0470 Psmall;F770 Q;0051 Qcircle;24C6 Qmonospace;FF31 Qsmall;F771 R;0052 Raarmenian;054C Racute;0154 Rcaron;0158 Rcedilla;0156 Rcircle;24C7 Rcommaaccent;0156 Rdblgrave;0210 Rdotaccent;1E58 Rdotbelow;1E5A Rdotbelowmacron;1E5C Reharmenian;0550 Rfraktur;211C Rho;03A1 Ringsmall;F6FC Rinvertedbreve;0212 Rlinebelow;1E5E Rmonospace;FF32 Rsmall;F772 Rsmallinverted;0281 Rsmallinvertedsuperior;02B6 S;0053 SF010000;250C SF020000;2514 SF030000;2510 SF040000;2518 SF050000;253C SF060000;252C SF070000;2534 SF080000;251C SF090000;2524 SF100000;2500 SF110000;2502 SF190000;2561 SF200000;2562 SF210000;2556 SF220000;2555 SF230000;2563 SF240000;2551 SF250000;2557 SF260000;255D SF270000;255C SF280000;255B SF360000;255E SF370000;255F SF380000;255A SF390000;2554 SF400000;2569 SF410000;2566 SF420000;2560 SF430000;2550 SF440000;256C SF450000;2567 SF460000;2568 SF470000;2564 SF480000;2565 SF490000;2559 SF500000;2558 SF510000;2552 SF520000;2553 SF530000;256B SF540000;256A Sacute;015A Sacutedotaccent;1E64 Sampigreek;03E0 Scaron;0160 Scarondotaccent;1E66 Scaronsmall;F6FD Scedilla;015E Schwa;018F Schwacyrillic;04D8 Schwadieresiscyrillic;04DA Scircle;24C8 Scircumflex;015C Scommaaccent;0218 Sdotaccent;1E60 Sdotbelow;1E62 Sdotbelowdotaccent;1E68 Seharmenian;054D Sevenroman;2166 Shaarmenian;0547 Shacyrillic;0428 Shchacyrillic;0429 Sheicoptic;03E2 Shhacyrillic;04BA Shimacoptic;03EC Sigma;03A3 Sixroman;2165 Smonospace;FF33 Softsigncyrillic;042C Ssmall;F773 Stigmagreek;03DA T;0054 Tau;03A4 Tbar;0166 Tcaron;0164 Tcedilla;0162 Tcircle;24C9 Tcircumflexbelow;1E70 Tcommaaccent;0162 Tdotaccent;1E6A Tdotbelow;1E6C Tecyrillic;0422 Tedescendercyrillic;04AC Tenroman;2169 Tetsecyrillic;04B4 Theta;0398 Thook;01AC Thorn;00DE Thornsmall;F7FE Threeroman;2162 Tildesmall;F6FE Tiwnarmenian;054F Tlinebelow;1E6E Tmonospace;FF34 Toarmenian;0539 Tonefive;01BC Tonesix;0184 Tonetwo;01A7 Tretroflexhook;01AE Tsecyrillic;0426 Tshecyrillic;040B Tsmall;F774 Twelveroman;216B Tworoman;2161 U;0055 Uacute;00DA Uacutesmall;F7FA Ubreve;016C Ucaron;01D3 Ucircle;24CA Ucircumflex;00DB Ucircumflexbelow;1E76 Ucircumflexsmall;F7FB Ucyrillic;0423 Udblacute;0170 Udblgrave;0214 Udieresis;00DC Udieresisacute;01D7 Udieresisbelow;1E72 Udieresiscaron;01D9 Udieresiscyrillic;04F0 Udieresisgrave;01DB Udieresismacron;01D5 Udieresissmall;F7FC Udotbelow;1EE4 Ugrave;00D9 Ugravesmall;F7F9 Uhookabove;1EE6 Uhorn;01AF Uhornacute;1EE8 Uhorndotbelow;1EF0 Uhorngrave;1EEA Uhornhookabove;1EEC Uhorntilde;1EEE Uhungarumlaut;0170 Uhungarumlautcyrillic;04F2 Uinvertedbreve;0216 Ukcyrillic;0478 Umacron;016A Umacroncyrillic;04EE Umacrondieresis;1E7A Umonospace;FF35 Uogonek;0172 Upsilon;03A5 Upsilon1;03D2 Upsilonacutehooksymbolgreek;03D3 Upsilonafrican;01B1 Upsilondieresis;03AB Upsilondieresishooksymbolgreek;03D4 Upsilonhooksymbol;03D2 Upsilontonos;038E Uring;016E Ushortcyrillic;040E Usmall;F775 Ustraightcyrillic;04AE Ustraightstrokecyrillic;04B0 Utilde;0168 Utildeacute;1E78 Utildebelow;1E74 V;0056 Vcircle;24CB Vdotbelow;1E7E Vecyrillic;0412 Vewarmenian;054E Vhook;01B2 Vmonospace;FF36 Voarmenian;0548 Vsmall;F776 Vtilde;1E7C W;0057 Wacute;1E82 Wcircle;24CC Wcircumflex;0174 Wdieresis;1E84 Wdotaccent;1E86 Wdotbelow;1E88 Wgrave;1E80 Wmonospace;FF37 Wsmall;F777 X;0058 Xcircle;24CD Xdieresis;1E8C Xdotaccent;1E8A Xeharmenian;053D Xi;039E Xmonospace;FF38 Xsmall;F778 Y;0059 Yacute;00DD Yacutesmall;F7FD Yatcyrillic;0462 Ycircle;24CE Ycircumflex;0176 Ydieresis;0178 Ydieresissmall;F7FF Ydotaccent;1E8E Ydotbelow;1EF4 Yericyrillic;042B Yerudieresiscyrillic;04F8 Ygrave;1EF2 Yhook;01B3 Yhookabove;1EF6 Yiarmenian;0545 Yicyrillic;0407 Yiwnarmenian;0552 Ymonospace;FF39 Ysmall;F779 Ytilde;1EF8 Yusbigcyrillic;046A Yusbigiotifiedcyrillic;046C Yuslittlecyrillic;0466 Yuslittleiotifiedcyrillic;0468 Z;005A Zaarmenian;0536 Zacute;0179 Zcaron;017D Zcaronsmall;F6FF Zcircle;24CF Zcircumflex;1E90 Zdot;017B Zdotaccent;017B Zdotbelow;1E92 Zecyrillic;0417 Zedescendercyrillic;0498 Zedieresiscyrillic;04DE Zeta;0396 Zhearmenian;053A Zhebrevecyrillic;04C1 Zhecyrillic;0416 Zhedescendercyrillic;0496 Zhedieresiscyrillic;04DC Zlinebelow;1E94 Zmonospace;FF3A Zsmall;F77A Zstroke;01B5 a;0061 aabengali;0986 aacute;00E1 aadeva;0906 aagujarati;0A86 aagurmukhi;0A06 aamatragurmukhi;0A3E aarusquare;3303 aavowelsignbengali;09BE aavowelsigndeva;093E aavowelsigngujarati;0ABE abbreviationmarkarmenian;055F abbreviationsigndeva;0970 abengali;0985 abopomofo;311A abreve;0103 abreveacute;1EAF abrevecyrillic;04D1 abrevedotbelow;1EB7 abrevegrave;1EB1 abrevehookabove;1EB3 abrevetilde;1EB5 acaron;01CE acircle;24D0 acircumflex;00E2 acircumflexacute;1EA5 acircumflexdotbelow;1EAD acircumflexgrave;1EA7 acircumflexhookabove;1EA9 acircumflextilde;1EAB acute;00B4 acutebelowcmb;0317 acutecmb;0301 acutecomb;0301 acutedeva;0954 acutelowmod;02CF acutetonecmb;0341 acyrillic;0430 adblgrave;0201 addakgurmukhi;0A71 adeva;0905 adieresis;00E4 adieresiscyrillic;04D3 adieresismacron;01DF adotbelow;1EA1 adotmacron;01E1 ae;00E6 aeacute;01FD aekorean;3150 aemacron;01E3 afii00208;2015 afii08941;20A4 afii10017;0410 afii10018;0411 afii10019;0412 afii10020;0413 afii10021;0414 afii10022;0415 afii10023;0401 afii10024;0416 afii10025;0417 afii10026;0418 afii10027;0419 afii10028;041A afii10029;041B afii10030;041C afii10031;041D afii10032;041E afii10033;041F afii10034;0420 afii10035;0421 afii10036;0422 afii10037;0423 afii10038;0424 afii10039;0425 afii10040;0426 afii10041;0427 afii10042;0428 afii10043;0429 afii10044;042A afii10045;042B afii10046;042C afii10047;042D afii10048;042E afii10049;042F afii10050;0490 afii10051;0402 afii10052;0403 afii10053;0404 afii10054;0405 afii10055;0406 afii10056;0407 afii10057;0408 afii10058;0409 afii10059;040A afii10060;040B afii10061;040C afii10062;040E afii10063;F6C4 afii10064;F6C5 afii10065;0430 afii10066;0431 afii10067;0432 afii10068;0433 afii10069;0434 afii10070;0435 afii10071;0451 afii10072;0436 afii10073;0437 afii10074;0438 afii10075;0439 afii10076;043A afii10077;043B afii10078;043C afii10079;043D afii10080;043E afii10081;043F afii10082;0440 afii10083;0441 afii10084;0442 afii10085;0443 afii10086;0444 afii10087;0445 afii10088;0446 afii10089;0447 afii10090;0448 afii10091;0449 afii10092;044A afii10093;044B afii10094;044C afii10095;044D afii10096;044E afii10097;044F afii10098;0491 afii10099;0452 afii10100;0453 afii10101;0454 afii10102;0455 afii10103;0456 afii10104;0457 afii10105;0458 afii10106;0459 afii10107;045A afii10108;045B afii10109;045C afii10110;045E afii10145;040F afii10146;0462 afii10147;0472 afii10148;0474 afii10192;F6C6 afii10193;045F afii10194;0463 afii10195;0473 afii10196;0475 afii10831;F6C7 afii10832;F6C8 afii10846;04D9 afii299;200E afii300;200F afii301;200D afii57381;066A afii57388;060C afii57392;0660 afii57393;0661 afii57394;0662 afii57395;0663 afii57396;0664 afii57397;0665 afii57398;0666 afii57399;0667 afii57400;0668 afii57401;0669 afii57403;061B afii57407;061F afii57409;0621 afii57410;0622 afii57411;0623 afii57412;0624 afii57413;0625 afii57414;0626 afii57415;0627 afii57416;0628 afii57417;0629 afii57418;062A afii57419;062B afii57420;062C afii57421;062D afii57422;062E afii57423;062F afii57424;0630 afii57425;0631 afii57426;0632 afii57427;0633 afii57428;0634 afii57429;0635 afii57430;0636 afii57431;0637 afii57432;0638 afii57433;0639 afii57434;063A afii57440;0640 afii57441;0641 afii57442;0642 afii57443;0643 afii57444;0644 afii57445;0645 afii57446;0646 afii57448;0648 afii57449;0649 afii57450;064A afii57451;064B afii57452;064C afii57453;064D afii57454;064E afii57455;064F afii57456;0650 afii57457;0651 afii57458;0652 afii57470;0647 afii57505;06A4 afii57506;067E afii57507;0686 afii57508;0698 afii57509;06AF afii57511;0679 afii57512;0688 afii57513;0691 afii57514;06BA afii57519;06D2 afii57534;06D5 afii57636;20AA afii57645;05BE afii57658;05C3 afii57664;05D0 afii57665;05D1 afii57666;05D2 afii57667;05D3 afii57668;05D4 afii57669;05D5 afii57670;05D6 afii57671;05D7 afii57672;05D8 afii57673;05D9 afii57674;05DA afii57675;05DB afii57676;05DC afii57677;05DD afii57678;05DE afii57679;05DF afii57680;05E0 afii57681;05E1 afii57682;05E2 afii57683;05E3 afii57684;05E4 afii57685;05E5 afii57686;05E6 afii57687;05E7 afii57688;05E8 afii57689;05E9 afii57690;05EA afii57694;FB2A afii57695;FB2B afii57700;FB4B afii57705;FB1F afii57716;05F0 afii57717;05F1 afii57718;05F2 afii57723;FB35 afii57793;05B4 afii57794;05B5 afii57795;05B6 afii57796;05BB afii57797;05B8 afii57798;05B7 afii57799;05B0 afii57800;05B2 afii57801;05B1 afii57802;05B3 afii57803;05C2 afii57804;05C1 afii57806;05B9 afii57807;05BC afii57839;05BD afii57841;05BF afii57842;05C0 afii57929;02BC afii61248;2105 afii61289;2113 afii61352;2116 afii61573;202C afii61574;202D afii61575;202E afii61664;200C afii63167;066D afii64937;02BD agrave;00E0 agujarati;0A85 agurmukhi;0A05 ahiragana;3042 ahookabove;1EA3 aibengali;0990 aibopomofo;311E aideva;0910 aiecyrillic;04D5 aigujarati;0A90 aigurmukhi;0A10 aimatragurmukhi;0A48 ainarabic;0639 ainfinalarabic;FECA aininitialarabic;FECB ainmedialarabic;FECC ainvertedbreve;0203 aivowelsignbengali;09C8 aivowelsigndeva;0948 aivowelsigngujarati;0AC8 akatakana;30A2 akatakanahalfwidth;FF71 akorean;314F alef;05D0 alefarabic;0627 alefdageshhebrew;FB30 aleffinalarabic;FE8E alefhamzaabovearabic;0623 alefhamzaabovefinalarabic;FE84 alefhamzabelowarabic;0625 alefhamzabelowfinalarabic;FE88 alefhebrew;05D0 aleflamedhebrew;FB4F alefmaddaabovearabic;0622 alefmaddaabovefinalarabic;FE82 alefmaksuraarabic;0649 alefmaksurafinalarabic;FEF0 alefmaksurainitialarabic;FEF3 alefmaksuramedialarabic;FEF4 alefpatahhebrew;FB2E alefqamatshebrew;FB2F aleph;2135 allequal;224C alpha;03B1 alphatonos;03AC amacron;0101 amonospace;FF41 ampersand;0026 ampersandmonospace;FF06 ampersandsmall;F726 amsquare;33C2 anbopomofo;3122 angbopomofo;3124 angkhankhuthai;0E5A angle;2220 anglebracketleft;3008 anglebracketleftvertical;FE3F anglebracketright;3009 anglebracketrightvertical;FE40 angleleft;2329 angleright;232A angstrom;212B anoteleia;0387 anudattadeva;0952 anusvarabengali;0982 anusvaradeva;0902 anusvaragujarati;0A82 aogonek;0105 apaatosquare;3300 aparen;249C apostrophearmenian;055A apostrophemod;02BC apple;F8FF approaches;2250 approxequal;2248 approxequalorimage;2252 approximatelyequal;2245 araeaekorean;318E araeakorean;318D arc;2312 arighthalfring;1E9A aring;00E5 aringacute;01FB aringbelow;1E01 arrowboth;2194 arrowdashdown;21E3 arrowdashleft;21E0 arrowdashright;21E2 arrowdashup;21E1 arrowdblboth;21D4 arrowdbldown;21D3 arrowdblleft;21D0 arrowdblright;21D2 arrowdblup;21D1 arrowdown;2193 arrowdownleft;2199 arrowdownright;2198 arrowdownwhite;21E9 arrowheaddownmod;02C5 arrowheadleftmod;02C2 arrowheadrightmod;02C3 arrowheadupmod;02C4 arrowhorizex;F8E7 arrowleft;2190 arrowleftdbl;21D0 arrowleftdblstroke;21CD arrowleftoverright;21C6 arrowleftwhite;21E6 arrowright;2192 arrowrightdblstroke;21CF arrowrightheavy;279E arrowrightoverleft;21C4 arrowrightwhite;21E8 arrowtableft;21E4 arrowtabright;21E5 arrowup;2191 arrowupdn;2195 arrowupdnbse;21A8 arrowupdownbase;21A8 arrowupleft;2196 arrowupleftofdown;21C5 arrowupright;2197 arrowupwhite;21E7 arrowvertex;F8E6 asciicircum;005E asciicircummonospace;FF3E asciitilde;007E asciitildemonospace;FF5E ascript;0251 ascriptturned;0252 asmallhiragana;3041 asmallkatakana;30A1 asmallkatakanahalfwidth;FF67 asterisk;002A asteriskaltonearabic;066D asteriskarabic;066D asteriskmath;2217 asteriskmonospace;FF0A asterisksmall;FE61 asterism;2042 asuperior;F6E9 asymptoticallyequal;2243 at;0040 atilde;00E3 atmonospace;FF20 atsmall;FE6B aturned;0250 aubengali;0994 aubopomofo;3120 audeva;0914 augujarati;0A94 augurmukhi;0A14 aulengthmarkbengali;09D7 aumatragurmukhi;0A4C auvowelsignbengali;09CC auvowelsigndeva;094C auvowelsigngujarati;0ACC avagrahadeva;093D aybarmenian;0561 ayin;05E2 ayinaltonehebrew;FB20 ayinhebrew;05E2 b;0062 babengali;09AC backslash;005C backslashmonospace;FF3C badeva;092C bagujarati;0AAC bagurmukhi;0A2C bahiragana;3070 bahtthai;0E3F bakatakana;30D0 bar;007C barmonospace;FF5C bbopomofo;3105 bcircle;24D1 bdotaccent;1E03 bdotbelow;1E05 beamedsixteenthnotes;266C because;2235 becyrillic;0431 beharabic;0628 behfinalarabic;FE90 behinitialarabic;FE91 behiragana;3079 behmedialarabic;FE92 behmeeminitialarabic;FC9F behmeemisolatedarabic;FC08 behnoonfinalarabic;FC6D bekatakana;30D9 benarmenian;0562 bet;05D1 beta;03B2 betasymbolgreek;03D0 betdagesh;FB31 betdageshhebrew;FB31 bethebrew;05D1 betrafehebrew;FB4C bhabengali;09AD bhadeva;092D bhagujarati;0AAD bhagurmukhi;0A2D bhook;0253 bihiragana;3073 bikatakana;30D3 bilabialclick;0298 bindigurmukhi;0A02 birusquare;3331 blackcircle;25CF blackdiamond;25C6 blackdownpointingtriangle;25BC blackleftpointingpointer;25C4 blackleftpointingtriangle;25C0 blacklenticularbracketleft;3010 blacklenticularbracketleftvertical;FE3B blacklenticularbracketright;3011 blacklenticularbracketrightvertical;FE3C blacklowerlefttriangle;25E3 blacklowerrighttriangle;25E2 blackrectangle;25AC blackrightpointingpointer;25BA blackrightpointingtriangle;25B6 blacksmallsquare;25AA blacksmilingface;263B blacksquare;25A0 blackstar;2605 blackupperlefttriangle;25E4 blackupperrighttriangle;25E5 blackuppointingsmalltriangle;25B4 blackuppointingtriangle;25B2 blank;2423 blinebelow;1E07 block;2588 bmonospace;FF42 bobaimaithai;0E1A bohiragana;307C bokatakana;30DC bparen;249D bqsquare;33C3 braceex;F8F4 braceleft;007B braceleftbt;F8F3 braceleftmid;F8F2 braceleftmonospace;FF5B braceleftsmall;FE5B bracelefttp;F8F1 braceleftvertical;FE37 braceright;007D bracerightbt;F8FE bracerightmid;F8FD bracerightmonospace;FF5D bracerightsmall;FE5C bracerighttp;F8FC bracerightvertical;FE38 bracketleft;005B bracketleftbt;F8F0 bracketleftex;F8EF bracketleftmonospace;FF3B bracketlefttp;F8EE bracketright;005D bracketrightbt;F8FB bracketrightex;F8FA bracketrightmonospace;FF3D bracketrighttp;F8F9 breve;02D8 brevebelowcmb;032E brevecmb;0306 breveinvertedbelowcmb;032F breveinvertedcmb;0311 breveinverteddoublecmb;0361 bridgebelowcmb;032A bridgeinvertedbelowcmb;033A brokenbar;00A6 bstroke;0180 bsuperior;F6EA btopbar;0183 buhiragana;3076 bukatakana;30D6 bullet;2022 bulletinverse;25D8 bulletoperator;2219 bullseye;25CE c;0063 caarmenian;056E cabengali;099A cacute;0107 cadeva;091A cagujarati;0A9A cagurmukhi;0A1A calsquare;3388 candrabindubengali;0981 candrabinducmb;0310 candrabindudeva;0901 candrabindugujarati;0A81 capslock;21EA careof;2105 caron;02C7 caronbelowcmb;032C caroncmb;030C carriagereturn;21B5 cbopomofo;3118 ccaron;010D ccedilla;00E7 ccedillaacute;1E09 ccircle;24D2 ccircumflex;0109 ccurl;0255 cdot;010B cdotaccent;010B cdsquare;33C5 cedilla;00B8 cedillacmb;0327 cent;00A2 centigrade;2103 centinferior;F6DF centmonospace;FFE0 centoldstyle;F7A2 centsuperior;F6E0 chaarmenian;0579 chabengali;099B chadeva;091B chagujarati;0A9B chagurmukhi;0A1B chbopomofo;3114 cheabkhasiancyrillic;04BD checkmark;2713 checyrillic;0447 chedescenderabkhasiancyrillic;04BF chedescendercyrillic;04B7 chedieresiscyrillic;04F5 cheharmenian;0573 chekhakassiancyrillic;04CC cheverticalstrokecyrillic;04B9 chi;03C7 chieuchacirclekorean;3277 chieuchaparenkorean;3217 chieuchcirclekorean;3269 chieuchkorean;314A chieuchparenkorean;3209 chochangthai;0E0A chochanthai;0E08 chochingthai;0E09 chochoethai;0E0C chook;0188 cieucacirclekorean;3276 cieucaparenkorean;3216 cieuccirclekorean;3268 cieuckorean;3148 cieucparenkorean;3208 cieucuparenkorean;321C circle;25CB circlemultiply;2297 circleot;2299 circleplus;2295 circlepostalmark;3036 circlewithlefthalfblack;25D0 circlewithrighthalfblack;25D1 circumflex;02C6 circumflexbelowcmb;032D circumflexcmb;0302 clear;2327 clickalveolar;01C2 clickdental;01C0 clicklateral;01C1 clickretroflex;01C3 club;2663 clubsuitblack;2663 clubsuitwhite;2667 cmcubedsquare;33A4 cmonospace;FF43 cmsquaredsquare;33A0 coarmenian;0581 colon;003A colonmonetary;20A1 colonmonospace;FF1A colonsign;20A1 colonsmall;FE55 colontriangularhalfmod;02D1 colontriangularmod;02D0 comma;002C commaabovecmb;0313 commaaboverightcmb;0315 commaaccent;F6C3 commaarabic;060C commaarmenian;055D commainferior;F6E1 commamonospace;FF0C commareversedabovecmb;0314 commareversedmod;02BD commasmall;FE50 commasuperior;F6E2 commaturnedabovecmb;0312 commaturnedmod;02BB compass;263C congruent;2245 contourintegral;222E control;2303 controlACK;0006 controlBEL;0007 controlBS;0008 controlCAN;0018 controlCR;000D controlDC1;0011 controlDC2;0012 controlDC3;0013 controlDC4;0014 controlDEL;007F controlDLE;0010 controlEM;0019 controlENQ;0005 controlEOT;0004 controlESC;001B controlETB;0017 controlETX;0003 controlFF;000C controlFS;001C controlGS;001D controlHT;0009 controlLF;000A controlNAK;0015 controlRS;001E controlSI;000F controlSO;000E controlSOT;0002 controlSTX;0001 controlSUB;001A controlSYN;0016 controlUS;001F controlVT;000B copyright;00A9 copyrightsans;F8E9 copyrightserif;F6D9 cornerbracketleft;300C cornerbracketlefthalfwidth;FF62 cornerbracketleftvertical;FE41 cornerbracketright;300D cornerbracketrighthalfwidth;FF63 cornerbracketrightvertical;FE42 corporationsquare;337F cosquare;33C7 coverkgsquare;33C6 cparen;249E cruzeiro;20A2 cstretched;0297 curlyand;22CF curlyor;22CE currency;00A4 cyrBreve;F6D1 cyrFlex;F6D2 cyrbreve;F6D4 cyrflex;F6D5 d;0064 daarmenian;0564 dabengali;09A6 dadarabic;0636 dadeva;0926 dadfinalarabic;FEBE dadinitialarabic;FEBF dadmedialarabic;FEC0 dagesh;05BC dageshhebrew;05BC dagger;2020 daggerdbl;2021 dagujarati;0AA6 dagurmukhi;0A26 dahiragana;3060 dakatakana;30C0 dalarabic;062F dalet;05D3 daletdagesh;FB33 daletdageshhebrew;FB33 dalethatafpatah;05D3 05B2 dalethatafpatahhebrew;05D3 05B2 dalethatafsegol;05D3 05B1 dalethatafsegolhebrew;05D3 05B1 dalethebrew;05D3 dalethiriq;05D3 05B4 dalethiriqhebrew;05D3 05B4 daletholam;05D3 05B9 daletholamhebrew;05D3 05B9 daletpatah;05D3 05B7 daletpatahhebrew;05D3 05B7 daletqamats;05D3 05B8 daletqamatshebrew;05D3 05B8 daletqubuts;05D3 05BB daletqubutshebrew;05D3 05BB daletsegol;05D3 05B6 daletsegolhebrew;05D3 05B6 daletsheva;05D3 05B0 daletshevahebrew;05D3 05B0 dalettsere;05D3 05B5 dalettserehebrew;05D3 05B5 dalfinalarabic;FEAA dammaarabic;064F dammalowarabic;064F dammatanaltonearabic;064C dammatanarabic;064C danda;0964 dargahebrew;05A7 dargalefthebrew;05A7 dasiapneumatacyrilliccmb;0485 dblGrave;F6D3 dblanglebracketleft;300A dblanglebracketleftvertical;FE3D dblanglebracketright;300B dblanglebracketrightvertical;FE3E dblarchinvertedbelowcmb;032B dblarrowleft;21D4 dblarrowright;21D2 dbldanda;0965 dblgrave;F6D6 dblgravecmb;030F dblintegral;222C dbllowline;2017 dbllowlinecmb;0333 dbloverlinecmb;033F dblprimemod;02BA dblverticalbar;2016 dblverticallineabovecmb;030E dbopomofo;3109 dbsquare;33C8 dcaron;010F dcedilla;1E11 dcircle;24D3 dcircumflexbelow;1E13 dcroat;0111 ddabengali;09A1 ddadeva;0921 ddagujarati;0AA1 ddagurmukhi;0A21 ddalarabic;0688 ddalfinalarabic;FB89 dddhadeva;095C ddhabengali;09A2 ddhadeva;0922 ddhagujarati;0AA2 ddhagurmukhi;0A22 ddotaccent;1E0B ddotbelow;1E0D decimalseparatorarabic;066B decimalseparatorpersian;066B decyrillic;0434 degree;00B0 dehihebrew;05AD dehiragana;3067 deicoptic;03EF dekatakana;30C7 deleteleft;232B deleteright;2326 delta;03B4 deltaturned;018D denominatorminusonenumeratorbengali;09F8 dezh;02A4 dhabengali;09A7 dhadeva;0927 dhagujarati;0AA7 dhagurmukhi;0A27 dhook;0257 dialytikatonos;0385 dialytikatonoscmb;0344 diamond;2666 diamondsuitwhite;2662 dieresis;00A8 dieresisacute;F6D7 dieresisbelowcmb;0324 dieresiscmb;0308 dieresisgrave;F6D8 dieresistonos;0385 dihiragana;3062 dikatakana;30C2 dittomark;3003 divide;00F7 divides;2223 divisionslash;2215 djecyrillic;0452 dkshade;2593 dlinebelow;1E0F dlsquare;3397 dmacron;0111 dmonospace;FF44 dnblock;2584 dochadathai;0E0E dodekthai;0E14 dohiragana;3069 dokatakana;30C9 dollar;0024 dollarinferior;F6E3 dollarmonospace;FF04 dollaroldstyle;F724 dollarsmall;FE69 dollarsuperior;F6E4 dong;20AB dorusquare;3326 dotaccent;02D9 dotaccentcmb;0307 dotbelowcmb;0323 dotbelowcomb;0323 dotkatakana;30FB dotlessi;0131 dotlessj;F6BE dotlessjstrokehook;0284 dotmath;22C5 dottedcircle;25CC doubleyodpatah;FB1F doubleyodpatahhebrew;FB1F downtackbelowcmb;031E downtackmod;02D5 dparen;249F dsuperior;F6EB dtail;0256 dtopbar;018C duhiragana;3065 dukatakana;30C5 dz;01F3 dzaltone;02A3 dzcaron;01C6 dzcurl;02A5 dzeabkhasiancyrillic;04E1 dzecyrillic;0455 dzhecyrillic;045F e;0065 eacute;00E9 earth;2641 ebengali;098F ebopomofo;311C ebreve;0115 ecandradeva;090D ecandragujarati;0A8D ecandravowelsigndeva;0945 ecandravowelsigngujarati;0AC5 ecaron;011B ecedillabreve;1E1D echarmenian;0565 echyiwnarmenian;0587 ecircle;24D4 ecircumflex;00EA ecircumflexacute;1EBF ecircumflexbelow;1E19 ecircumflexdotbelow;1EC7 ecircumflexgrave;1EC1 ecircumflexhookabove;1EC3 ecircumflextilde;1EC5 ecyrillic;0454 edblgrave;0205 edeva;090F edieresis;00EB edot;0117 edotaccent;0117 edotbelow;1EB9 eegurmukhi;0A0F eematragurmukhi;0A47 efcyrillic;0444 egrave;00E8 egujarati;0A8F eharmenian;0567 ehbopomofo;311D ehiragana;3048 ehookabove;1EBB eibopomofo;311F eight;0038 eightarabic;0668 eightbengali;09EE eightcircle;2467 eightcircleinversesansserif;2791 eightdeva;096E eighteencircle;2471 eighteenparen;2485 eighteenperiod;2499 eightgujarati;0AEE eightgurmukhi;0A6E eighthackarabic;0668 eighthangzhou;3028 eighthnotebeamed;266B eightideographicparen;3227 eightinferior;2088 eightmonospace;FF18 eightoldstyle;F738 eightparen;247B eightperiod;248F eightpersian;06F8 eightroman;2177 eightsuperior;2078 eightthai;0E58 einvertedbreve;0207 eiotifiedcyrillic;0465 ekatakana;30A8 ekatakanahalfwidth;FF74 ekonkargurmukhi;0A74 ekorean;3154 elcyrillic;043B element;2208 elevencircle;246A elevenparen;247E elevenperiod;2492 elevenroman;217A ellipsis;2026 ellipsisvertical;22EE emacron;0113 emacronacute;1E17 emacrongrave;1E15 emcyrillic;043C emdash;2014 emdashvertical;FE31 emonospace;FF45 emphasismarkarmenian;055B emptyset;2205 enbopomofo;3123 encyrillic;043D endash;2013 endashvertical;FE32 endescendercyrillic;04A3 eng;014B engbopomofo;3125 enghecyrillic;04A5 enhookcyrillic;04C8 enspace;2002 eogonek;0119 eokorean;3153 eopen;025B eopenclosed;029A eopenreversed;025C eopenreversedclosed;025E eopenreversedhook;025D eparen;24A0 epsilon;03B5 epsilontonos;03AD equal;003D equalmonospace;FF1D equalsmall;FE66 equalsuperior;207C equivalence;2261 erbopomofo;3126 ercyrillic;0440 ereversed;0258 ereversedcyrillic;044D escyrillic;0441 esdescendercyrillic;04AB esh;0283 eshcurl;0286 eshortdeva;090E eshortvowelsigndeva;0946 eshreversedloop;01AA eshsquatreversed;0285 esmallhiragana;3047 esmallkatakana;30A7 esmallkatakanahalfwidth;FF6A estimated;212E esuperior;F6EC eta;03B7 etarmenian;0568 etatonos;03AE eth;00F0 etilde;1EBD etildebelow;1E1B etnahtafoukhhebrew;0591 etnahtafoukhlefthebrew;0591 etnahtahebrew;0591 etnahtalefthebrew;0591 eturned;01DD eukorean;3161 euro;20AC evowelsignbengali;09C7 evowelsigndeva;0947 evowelsigngujarati;0AC7 exclam;0021 exclamarmenian;055C exclamdbl;203C exclamdown;00A1 exclamdownsmall;F7A1 exclammonospace;FF01 exclamsmall;F721 existential;2203 ezh;0292 ezhcaron;01EF ezhcurl;0293 ezhreversed;01B9 ezhtail;01BA f;0066 fadeva;095E fagurmukhi;0A5E fahrenheit;2109 fathaarabic;064E fathalowarabic;064E fathatanarabic;064B fbopomofo;3108 fcircle;24D5 fdotaccent;1E1F feharabic;0641 feharmenian;0586 fehfinalarabic;FED2 fehinitialarabic;FED3 fehmedialarabic;FED4 feicoptic;03E5 female;2640 ff;FB00 ffi;FB03 ffl;FB04 fi;FB01 fifteencircle;246E fifteenparen;2482 fifteenperiod;2496 figuredash;2012 filledbox;25A0 filledrect;25AC finalkaf;05DA finalkafdagesh;FB3A finalkafdageshhebrew;FB3A finalkafhebrew;05DA finalkafqamats;05DA 05B8 finalkafqamatshebrew;05DA 05B8 finalkafsheva;05DA 05B0 finalkafshevahebrew;05DA 05B0 finalmem;05DD finalmemhebrew;05DD finalnun;05DF finalnunhebrew;05DF finalpe;05E3 finalpehebrew;05E3 finaltsadi;05E5 finaltsadihebrew;05E5 firsttonechinese;02C9 fisheye;25C9 fitacyrillic;0473 five;0035 fivearabic;0665 fivebengali;09EB fivecircle;2464 fivecircleinversesansserif;278E fivedeva;096B fiveeighths;215D fivegujarati;0AEB fivegurmukhi;0A6B fivehackarabic;0665 fivehangzhou;3025 fiveideographicparen;3224 fiveinferior;2085 fivemonospace;FF15 fiveoldstyle;F735 fiveparen;2478 fiveperiod;248C fivepersian;06F5 fiveroman;2174 fivesuperior;2075 fivethai;0E55 fl;FB02 florin;0192 fmonospace;FF46 fmsquare;3399 fofanthai;0E1F fofathai;0E1D fongmanthai;0E4F forall;2200 four;0034 fourarabic;0664 fourbengali;09EA fourcircle;2463 fourcircleinversesansserif;278D fourdeva;096A fourgujarati;0AEA fourgurmukhi;0A6A fourhackarabic;0664 fourhangzhou;3024 fourideographicparen;3223 fourinferior;2084 fourmonospace;FF14 fournumeratorbengali;09F7 fouroldstyle;F734 fourparen;2477 fourperiod;248B fourpersian;06F4 fourroman;2173 foursuperior;2074 fourteencircle;246D fourteenparen;2481 fourteenperiod;2495 fourthai;0E54 fourthtonechinese;02CB fparen;24A1 fraction;2044 franc;20A3 g;0067 gabengali;0997 gacute;01F5 gadeva;0917 gafarabic;06AF gaffinalarabic;FB93 gafinitialarabic;FB94 gafmedialarabic;FB95 gagujarati;0A97 gagurmukhi;0A17 gahiragana;304C gakatakana;30AC gamma;03B3 gammalatinsmall;0263 gammasuperior;02E0 gangiacoptic;03EB gbopomofo;310D gbreve;011F gcaron;01E7 gcedilla;0123 gcircle;24D6 gcircumflex;011D gcommaaccent;0123 gdot;0121 gdotaccent;0121 gecyrillic;0433 gehiragana;3052 gekatakana;30B2 geometricallyequal;2251 gereshaccenthebrew;059C gereshhebrew;05F3 gereshmuqdamhebrew;059D germandbls;00DF gershayimaccenthebrew;059E gershayimhebrew;05F4 getamark;3013 ghabengali;0998 ghadarmenian;0572 ghadeva;0918 ghagujarati;0A98 ghagurmukhi;0A18 ghainarabic;063A ghainfinalarabic;FECE ghaininitialarabic;FECF ghainmedialarabic;FED0 ghemiddlehookcyrillic;0495 ghestrokecyrillic;0493 gheupturncyrillic;0491 ghhadeva;095A ghhagurmukhi;0A5A ghook;0260 ghzsquare;3393 gihiragana;304E gikatakana;30AE gimarmenian;0563 gimel;05D2 gimeldagesh;FB32 gimeldageshhebrew;FB32 gimelhebrew;05D2 gjecyrillic;0453 glottalinvertedstroke;01BE glottalstop;0294 glottalstopinverted;0296 glottalstopmod;02C0 glottalstopreversed;0295 glottalstopreversedmod;02C1 glottalstopreversedsuperior;02E4 glottalstopstroke;02A1 glottalstopstrokereversed;02A2 gmacron;1E21 gmonospace;FF47 gohiragana;3054 gokatakana;30B4 gparen;24A2 gpasquare;33AC gradient;2207 grave;0060 gravebelowcmb;0316 gravecmb;0300 gravecomb;0300 gravedeva;0953 gravelowmod;02CE gravemonospace;FF40 gravetonecmb;0340 greater;003E greaterequal;2265 greaterequalorless;22DB greatermonospace;FF1E greaterorequivalent;2273 greaterorless;2277 greateroverequal;2267 greatersmall;FE65 gscript;0261 gstroke;01E5 guhiragana;3050 guillemotleft;00AB guillemotright;00BB guilsinglleft;2039 guilsinglright;203A gukatakana;30B0 guramusquare;3318 gysquare;33C9 h;0068 haabkhasiancyrillic;04A9 haaltonearabic;06C1 habengali;09B9 hadescendercyrillic;04B3 hadeva;0939 hagujarati;0AB9 hagurmukhi;0A39 haharabic;062D hahfinalarabic;FEA2 hahinitialarabic;FEA3 hahiragana;306F hahmedialarabic;FEA4 haitusquare;332A hakatakana;30CF hakatakanahalfwidth;FF8A halantgurmukhi;0A4D hamzaarabic;0621 hamzadammaarabic;0621 064F hamzadammatanarabic;0621 064C hamzafathaarabic;0621 064E hamzafathatanarabic;0621 064B hamzalowarabic;0621 hamzalowkasraarabic;0621 0650 hamzalowkasratanarabic;0621 064D hamzasukunarabic;0621 0652 hangulfiller;3164 hardsigncyrillic;044A harpoonleftbarbup;21BC harpoonrightbarbup;21C0 hasquare;33CA hatafpatah;05B2 hatafpatah16;05B2 hatafpatah23;05B2 hatafpatah2f;05B2 hatafpatahhebrew;05B2 hatafpatahnarrowhebrew;05B2 hatafpatahquarterhebrew;05B2 hatafpatahwidehebrew;05B2 hatafqamats;05B3 hatafqamats1b;05B3 hatafqamats28;05B3 hatafqamats34;05B3 hatafqamatshebrew;05B3 hatafqamatsnarrowhebrew;05B3 hatafqamatsquarterhebrew;05B3 hatafqamatswidehebrew;05B3 hatafsegol;05B1 hatafsegol17;05B1 hatafsegol24;05B1 hatafsegol30;05B1 hatafsegolhebrew;05B1 hatafsegolnarrowhebrew;05B1 hatafsegolquarterhebrew;05B1 hatafsegolwidehebrew;05B1 hbar;0127 hbopomofo;310F hbrevebelow;1E2B hcedilla;1E29 hcircle;24D7 hcircumflex;0125 hdieresis;1E27 hdotaccent;1E23 hdotbelow;1E25 he;05D4 heart;2665 heartsuitblack;2665 heartsuitwhite;2661 hedagesh;FB34 hedageshhebrew;FB34 hehaltonearabic;06C1 heharabic;0647 hehebrew;05D4 hehfinalaltonearabic;FBA7 hehfinalalttwoarabic;FEEA hehfinalarabic;FEEA hehhamzaabovefinalarabic;FBA5 hehhamzaaboveisolatedarabic;FBA4 hehinitialaltonearabic;FBA8 hehinitialarabic;FEEB hehiragana;3078 hehmedialaltonearabic;FBA9 hehmedialarabic;FEEC heiseierasquare;337B hekatakana;30D8 hekatakanahalfwidth;FF8D hekutaarusquare;3336 henghook;0267 herutusquare;3339 het;05D7 hethebrew;05D7 hhook;0266 hhooksuperior;02B1 hieuhacirclekorean;327B hieuhaparenkorean;321B hieuhcirclekorean;326D hieuhkorean;314E hieuhparenkorean;320D hihiragana;3072 hikatakana;30D2 hikatakanahalfwidth;FF8B hiriq;05B4 hiriq14;05B4 hiriq21;05B4 hiriq2d;05B4 hiriqhebrew;05B4 hiriqnarrowhebrew;05B4 hiriqquarterhebrew;05B4 hiriqwidehebrew;05B4 hlinebelow;1E96 hmonospace;FF48 hoarmenian;0570 hohipthai;0E2B hohiragana;307B hokatakana;30DB hokatakanahalfwidth;FF8E holam;05B9 holam19;05B9 holam26;05B9 holam32;05B9 holamhebrew;05B9 holamnarrowhebrew;05B9 holamquarterhebrew;05B9 holamwidehebrew;05B9 honokhukthai;0E2E hookabovecomb;0309 hookcmb;0309 hookpalatalizedbelowcmb;0321 hookretroflexbelowcmb;0322 hoonsquare;3342 horicoptic;03E9 horizontalbar;2015 horncmb;031B hotsprings;2668 house;2302 hparen;24A3 hsuperior;02B0 hturned;0265 huhiragana;3075 huiitosquare;3333 hukatakana;30D5 hukatakanahalfwidth;FF8C hungarumlaut;02DD hungarumlautcmb;030B hv;0195 hyphen;002D hypheninferior;F6E5 hyphenmonospace;FF0D hyphensmall;FE63 hyphensuperior;F6E6 hyphentwo;2010 i;0069 iacute;00ED iacyrillic;044F ibengali;0987 ibopomofo;3127 ibreve;012D icaron;01D0 icircle;24D8 icircumflex;00EE icyrillic;0456 idblgrave;0209 ideographearthcircle;328F ideographfirecircle;328B ideographicallianceparen;323F ideographiccallparen;323A ideographiccentrecircle;32A5 ideographicclose;3006 ideographiccomma;3001 ideographiccommaleft;FF64 ideographiccongratulationparen;3237 ideographiccorrectcircle;32A3 ideographicearthparen;322F ideographicenterpriseparen;323D ideographicexcellentcircle;329D ideographicfestivalparen;3240 ideographicfinancialcircle;3296 ideographicfinancialparen;3236 ideographicfireparen;322B ideographichaveparen;3232 ideographichighcircle;32A4 ideographiciterationmark;3005 ideographiclaborcircle;3298 ideographiclaborparen;3238 ideographicleftcircle;32A7 ideographiclowcircle;32A6 ideographicmedicinecircle;32A9 ideographicmetalparen;322E ideographicmoonparen;322A ideographicnameparen;3234 ideographicperiod;3002 ideographicprintcircle;329E ideographicreachparen;3243 ideographicrepresentparen;3239 ideographicresourceparen;323E ideographicrightcircle;32A8 ideographicsecretcircle;3299 ideographicselfparen;3242 ideographicsocietyparen;3233 ideographicspace;3000 ideographicspecialparen;3235 ideographicstockparen;3231 ideographicstudyparen;323B ideographicsunparen;3230 ideographicsuperviseparen;323C ideographicwaterparen;322C ideographicwoodparen;322D ideographiczero;3007 ideographmetalcircle;328E ideographmooncircle;328A ideographnamecircle;3294 ideographsuncircle;3290 ideographwatercircle;328C ideographwoodcircle;328D ideva;0907 idieresis;00EF idieresisacute;1E2F idieresiscyrillic;04E5 idotbelow;1ECB iebrevecyrillic;04D7 iecyrillic;0435 ieungacirclekorean;3275 ieungaparenkorean;3215 ieungcirclekorean;3267 ieungkorean;3147 ieungparenkorean;3207 igrave;00EC igujarati;0A87 igurmukhi;0A07 ihiragana;3044 ihookabove;1EC9 iibengali;0988 iicyrillic;0438 iideva;0908 iigujarati;0A88 iigurmukhi;0A08 iimatragurmukhi;0A40 iinvertedbreve;020B iishortcyrillic;0439 iivowelsignbengali;09C0 iivowelsigndeva;0940 iivowelsigngujarati;0AC0 ij;0133 ikatakana;30A4 ikatakanahalfwidth;FF72 ikorean;3163 ilde;02DC iluyhebrew;05AC imacron;012B imacroncyrillic;04E3 imageorapproximatelyequal;2253 imatragurmukhi;0A3F imonospace;FF49 increment;2206 infinity;221E iniarmenian;056B integral;222B integralbottom;2321 integralbt;2321 integralex;F8F5 integraltop;2320 integraltp;2320 intersection;2229 intisquare;3305 invbullet;25D8 invcircle;25D9 invsmileface;263B iocyrillic;0451 iogonek;012F iota;03B9 iotadieresis;03CA iotadieresistonos;0390 iotalatin;0269 iotatonos;03AF iparen;24A4 irigurmukhi;0A72 ismallhiragana;3043 ismallkatakana;30A3 ismallkatakanahalfwidth;FF68 issharbengali;09FA istroke;0268 isuperior;F6ED iterationhiragana;309D iterationkatakana;30FD itilde;0129 itildebelow;1E2D iubopomofo;3129 iucyrillic;044E ivowelsignbengali;09BF ivowelsigndeva;093F ivowelsigngujarati;0ABF izhitsacyrillic;0475 izhitsadblgravecyrillic;0477 j;006A jaarmenian;0571 jabengali;099C jadeva;091C jagujarati;0A9C jagurmukhi;0A1C jbopomofo;3110 jcaron;01F0 jcircle;24D9 jcircumflex;0135 jcrossedtail;029D jdotlessstroke;025F jecyrillic;0458 jeemarabic;062C jeemfinalarabic;FE9E jeeminitialarabic;FE9F jeemmedialarabic;FEA0 jeharabic;0698 jehfinalarabic;FB8B jhabengali;099D jhadeva;091D jhagujarati;0A9D jhagurmukhi;0A1D jheharmenian;057B jis;3004 jmonospace;FF4A jparen;24A5 jsuperior;02B2 k;006B kabashkircyrillic;04A1 kabengali;0995 kacute;1E31 kacyrillic;043A kadescendercyrillic;049B kadeva;0915 kaf;05DB kafarabic;0643 kafdagesh;FB3B kafdageshhebrew;FB3B kaffinalarabic;FEDA kafhebrew;05DB kafinitialarabic;FEDB kafmedialarabic;FEDC kafrafehebrew;FB4D kagujarati;0A95 kagurmukhi;0A15 kahiragana;304B kahookcyrillic;04C4 kakatakana;30AB kakatakanahalfwidth;FF76 kappa;03BA kappasymbolgreek;03F0 kapyeounmieumkorean;3171 kapyeounphieuphkorean;3184 kapyeounpieupkorean;3178 kapyeounssangpieupkorean;3179 karoriisquare;330D kashidaautoarabic;0640 kashidaautonosidebearingarabic;0640 kasmallkatakana;30F5 kasquare;3384 kasraarabic;0650 kasratanarabic;064D kastrokecyrillic;049F katahiraprolongmarkhalfwidth;FF70 kaverticalstrokecyrillic;049D kbopomofo;310E kcalsquare;3389 kcaron;01E9 kcedilla;0137 kcircle;24DA kcommaaccent;0137 kdotbelow;1E33 keharmenian;0584 kehiragana;3051 kekatakana;30B1 kekatakanahalfwidth;FF79 kenarmenian;056F kesmallkatakana;30F6 kgreenlandic;0138 khabengali;0996 khacyrillic;0445 khadeva;0916 khagujarati;0A96 khagurmukhi;0A16 khaharabic;062E khahfinalarabic;FEA6 khahinitialarabic;FEA7 khahmedialarabic;FEA8 kheicoptic;03E7 khhadeva;0959 khhagurmukhi;0A59 khieukhacirclekorean;3278 khieukhaparenkorean;3218 khieukhcirclekorean;326A khieukhkorean;314B khieukhparenkorean;320A khokhaithai;0E02 khokhonthai;0E05 khokhuatthai;0E03 khokhwaithai;0E04 khomutthai;0E5B khook;0199 khorakhangthai;0E06 khzsquare;3391 kihiragana;304D kikatakana;30AD kikatakanahalfwidth;FF77 kiroguramusquare;3315 kiromeetorusquare;3316 kirosquare;3314 kiyeokacirclekorean;326E kiyeokaparenkorean;320E kiyeokcirclekorean;3260 kiyeokkorean;3131 kiyeokparenkorean;3200 kiyeoksioskorean;3133 kjecyrillic;045C klinebelow;1E35 klsquare;3398 kmcubedsquare;33A6 kmonospace;FF4B kmsquaredsquare;33A2 kohiragana;3053 kohmsquare;33C0 kokaithai;0E01 kokatakana;30B3 kokatakanahalfwidth;FF7A kooposquare;331E koppacyrillic;0481 koreanstandardsymbol;327F koroniscmb;0343 kparen;24A6 kpasquare;33AA ksicyrillic;046F ktsquare;33CF kturned;029E kuhiragana;304F kukatakana;30AF kukatakanahalfwidth;FF78 kvsquare;33B8 kwsquare;33BE l;006C labengali;09B2 lacute;013A ladeva;0932 lagujarati;0AB2 lagurmukhi;0A32 lakkhangyaothai;0E45 lamaleffinalarabic;FEFC lamalefhamzaabovefinalarabic;FEF8 lamalefhamzaaboveisolatedarabic;FEF7 lamalefhamzabelowfinalarabic;FEFA lamalefhamzabelowisolatedarabic;FEF9 lamalefisolatedarabic;FEFB lamalefmaddaabovefinalarabic;FEF6 lamalefmaddaaboveisolatedarabic;FEF5 lamarabic;0644 lambda;03BB lambdastroke;019B lamed;05DC lameddagesh;FB3C lameddageshhebrew;FB3C lamedhebrew;05DC lamedholam;05DC 05B9 lamedholamdagesh;05DC 05B9 05BC lamedholamdageshhebrew;05DC 05B9 05BC lamedholamhebrew;05DC 05B9 lamfinalarabic;FEDE lamhahinitialarabic;FCCA laminitialarabic;FEDF lamjeeminitialarabic;FCC9 lamkhahinitialarabic;FCCB lamlamhehisolatedarabic;FDF2 lammedialarabic;FEE0 lammeemhahinitialarabic;FD88 lammeeminitialarabic;FCCC lammeemjeeminitialarabic;FEDF FEE4 FEA0 lammeemkhahinitialarabic;FEDF FEE4 FEA8 largecircle;25EF lbar;019A lbelt;026C lbopomofo;310C lcaron;013E lcedilla;013C lcircle;24DB lcircumflexbelow;1E3D lcommaaccent;013C ldot;0140 ldotaccent;0140 ldotbelow;1E37 ldotbelowmacron;1E39 leftangleabovecmb;031A lefttackbelowcmb;0318 less;003C lessequal;2264 lessequalorgreater;22DA lessmonospace;FF1C lessorequivalent;2272 lessorgreater;2276 lessoverequal;2266 lesssmall;FE64 lezh;026E lfblock;258C lhookretroflex;026D lira;20A4 liwnarmenian;056C lj;01C9 ljecyrillic;0459 ll;F6C0 lladeva;0933 llagujarati;0AB3 llinebelow;1E3B llladeva;0934 llvocalicbengali;09E1 llvocalicdeva;0961 llvocalicvowelsignbengali;09E3 llvocalicvowelsigndeva;0963 lmiddletilde;026B lmonospace;FF4C lmsquare;33D0 lochulathai;0E2C logicaland;2227 logicalnot;00AC logicalnotreversed;2310 logicalor;2228 lolingthai;0E25 longs;017F lowlinecenterline;FE4E lowlinecmb;0332 lowlinedashed;FE4D lozenge;25CA lparen;24A7 lslash;0142 lsquare;2113 lsuperior;F6EE ltshade;2591 luthai;0E26 lvocalicbengali;098C lvocalicdeva;090C lvocalicvowelsignbengali;09E2 lvocalicvowelsigndeva;0962 lxsquare;33D3 m;006D mabengali;09AE macron;00AF macronbelowcmb;0331 macroncmb;0304 macronlowmod;02CD macronmonospace;FFE3 macute;1E3F madeva;092E magujarati;0AAE magurmukhi;0A2E mahapakhhebrew;05A4 mahapakhlefthebrew;05A4 mahiragana;307E maichattawalowleftthai;F895 maichattawalowrightthai;F894 maichattawathai;0E4B maichattawaupperleftthai;F893 maieklowleftthai;F88C maieklowrightthai;F88B maiekthai;0E48 maiekupperleftthai;F88A maihanakatleftthai;F884 maihanakatthai;0E31 maitaikhuleftthai;F889 maitaikhuthai;0E47 maitholowleftthai;F88F maitholowrightthai;F88E maithothai;0E49 maithoupperleftthai;F88D maitrilowleftthai;F892 maitrilowrightthai;F891 maitrithai;0E4A maitriupperleftthai;F890 maiyamokthai;0E46 makatakana;30DE makatakanahalfwidth;FF8F male;2642 mansyonsquare;3347 maqafhebrew;05BE mars;2642 masoracirclehebrew;05AF masquare;3383 mbopomofo;3107 mbsquare;33D4 mcircle;24DC mcubedsquare;33A5 mdotaccent;1E41 mdotbelow;1E43 meemarabic;0645 meemfinalarabic;FEE2 meeminitialarabic;FEE3 meemmedialarabic;FEE4 meemmeeminitialarabic;FCD1 meemmeemisolatedarabic;FC48 meetorusquare;334D mehiragana;3081 meizierasquare;337E mekatakana;30E1 mekatakanahalfwidth;FF92 mem;05DE memdagesh;FB3E memdageshhebrew;FB3E memhebrew;05DE menarmenian;0574 merkhahebrew;05A5 merkhakefulahebrew;05A6 merkhakefulalefthebrew;05A6 merkhalefthebrew;05A5 mhook;0271 mhzsquare;3392 middledotkatakanahalfwidth;FF65 middot;00B7 mieumacirclekorean;3272 mieumaparenkorean;3212 mieumcirclekorean;3264 mieumkorean;3141 mieumpansioskorean;3170 mieumparenkorean;3204 mieumpieupkorean;316E mieumsioskorean;316F mihiragana;307F mikatakana;30DF mikatakanahalfwidth;FF90 minus;2212 minusbelowcmb;0320 minuscircle;2296 minusmod;02D7 minusplus;2213 minute;2032 miribaarusquare;334A mirisquare;3349 mlonglegturned;0270 mlsquare;3396 mmcubedsquare;33A3 mmonospace;FF4D mmsquaredsquare;339F mohiragana;3082 mohmsquare;33C1 mokatakana;30E2 mokatakanahalfwidth;FF93 molsquare;33D6 momathai;0E21 moverssquare;33A7 moverssquaredsquare;33A8 mparen;24A8 mpasquare;33AB mssquare;33B3 msuperior;F6EF mturned;026F mu;00B5 mu1;00B5 muasquare;3382 muchgreater;226B muchless;226A mufsquare;338C mugreek;03BC mugsquare;338D muhiragana;3080 mukatakana;30E0 mukatakanahalfwidth;FF91 mulsquare;3395 multiply;00D7 mumsquare;339B munahhebrew;05A3 munahlefthebrew;05A3 musicalnote;266A musicalnotedbl;266B musicflatsign;266D musicsharpsign;266F mussquare;33B2 muvsquare;33B6 muwsquare;33BC mvmegasquare;33B9 mvsquare;33B7 mwmegasquare;33BF mwsquare;33BD n;006E nabengali;09A8 nabla;2207 nacute;0144 nadeva;0928 nagujarati;0AA8 nagurmukhi;0A28 nahiragana;306A nakatakana;30CA nakatakanahalfwidth;FF85 napostrophe;0149 nasquare;3381 nbopomofo;310B nbspace;00A0 ncaron;0148 ncedilla;0146 ncircle;24DD ncircumflexbelow;1E4B ncommaaccent;0146 ndotaccent;1E45 ndotbelow;1E47 nehiragana;306D nekatakana;30CD nekatakanahalfwidth;FF88 newsheqelsign;20AA nfsquare;338B ngabengali;0999 ngadeva;0919 ngagujarati;0A99 ngagurmukhi;0A19 ngonguthai;0E07 nhiragana;3093 nhookleft;0272 nhookretroflex;0273 nieunacirclekorean;326F nieunaparenkorean;320F nieuncieuckorean;3135 nieuncirclekorean;3261 nieunhieuhkorean;3136 nieunkorean;3134 nieunpansioskorean;3168 nieunparenkorean;3201 nieunsioskorean;3167 nieuntikeutkorean;3166 nihiragana;306B nikatakana;30CB nikatakanahalfwidth;FF86 nikhahitleftthai;F899 nikhahitthai;0E4D nine;0039 ninearabic;0669 ninebengali;09EF ninecircle;2468 ninecircleinversesansserif;2792 ninedeva;096F ninegujarati;0AEF ninegurmukhi;0A6F ninehackarabic;0669 ninehangzhou;3029 nineideographicparen;3228 nineinferior;2089 ninemonospace;FF19 nineoldstyle;F739 nineparen;247C nineperiod;2490 ninepersian;06F9 nineroman;2178 ninesuperior;2079 nineteencircle;2472 nineteenparen;2486 nineteenperiod;249A ninethai;0E59 nj;01CC njecyrillic;045A nkatakana;30F3 nkatakanahalfwidth;FF9D nlegrightlong;019E nlinebelow;1E49 nmonospace;FF4E nmsquare;339A nnabengali;09A3 nnadeva;0923 nnagujarati;0AA3 nnagurmukhi;0A23 nnnadeva;0929 nohiragana;306E nokatakana;30CE nokatakanahalfwidth;FF89 nonbreakingspace;00A0 nonenthai;0E13 nonuthai;0E19 noonarabic;0646 noonfinalarabic;FEE6 noonghunnaarabic;06BA noonghunnafinalarabic;FB9F noonhehinitialarabic;FEE7 FEEC nooninitialarabic;FEE7 noonjeeminitialarabic;FCD2 noonjeemisolatedarabic;FC4B noonmedialarabic;FEE8 noonmeeminitialarabic;FCD5 noonmeemisolatedarabic;FC4E noonnoonfinalarabic;FC8D notcontains;220C notelement;2209 notelementof;2209 notequal;2260 notgreater;226F notgreaternorequal;2271 notgreaternorless;2279 notidentical;2262 notless;226E notlessnorequal;2270 notparallel;2226 notprecedes;2280 notsubset;2284 notsucceeds;2281 notsuperset;2285 nowarmenian;0576 nparen;24A9 nssquare;33B1 nsuperior;207F ntilde;00F1 nu;03BD nuhiragana;306C nukatakana;30CC nukatakanahalfwidth;FF87 nuktabengali;09BC nuktadeva;093C nuktagujarati;0ABC nuktagurmukhi;0A3C numbersign;0023 numbersignmonospace;FF03 numbersignsmall;FE5F numeralsigngreek;0374 numeralsignlowergreek;0375 numero;2116 nun;05E0 nundagesh;FB40 nundageshhebrew;FB40 nunhebrew;05E0 nvsquare;33B5 nwsquare;33BB nyabengali;099E nyadeva;091E nyagujarati;0A9E nyagurmukhi;0A1E o;006F oacute;00F3 oangthai;0E2D obarred;0275 obarredcyrillic;04E9 obarreddieresiscyrillic;04EB obengali;0993 obopomofo;311B obreve;014F ocandradeva;0911 ocandragujarati;0A91 ocandravowelsigndeva;0949 ocandravowelsigngujarati;0AC9 ocaron;01D2 ocircle;24DE ocircumflex;00F4 ocircumflexacute;1ED1 ocircumflexdotbelow;1ED9 ocircumflexgrave;1ED3 ocircumflexhookabove;1ED5 ocircumflextilde;1ED7 ocyrillic;043E odblacute;0151 odblgrave;020D odeva;0913 odieresis;00F6 odieresiscyrillic;04E7 odotbelow;1ECD oe;0153 oekorean;315A ogonek;02DB ogonekcmb;0328 ograve;00F2 ogujarati;0A93 oharmenian;0585 ohiragana;304A ohookabove;1ECF ohorn;01A1 ohornacute;1EDB ohorndotbelow;1EE3 ohorngrave;1EDD ohornhookabove;1EDF ohorntilde;1EE1 ohungarumlaut;0151 oi;01A3 oinvertedbreve;020F okatakana;30AA okatakanahalfwidth;FF75 okorean;3157 olehebrew;05AB omacron;014D omacronacute;1E53 omacrongrave;1E51 omdeva;0950 omega;03C9 omega1;03D6 omegacyrillic;0461 omegalatinclosed;0277 omegaroundcyrillic;047B omegatitlocyrillic;047D omegatonos;03CE omgujarati;0AD0 omicron;03BF omicrontonos;03CC omonospace;FF4F one;0031 onearabic;0661 onebengali;09E7 onecircle;2460 onecircleinversesansserif;278A onedeva;0967 onedotenleader;2024 oneeighth;215B onefitted;F6DC onegujarati;0AE7 onegurmukhi;0A67 onehackarabic;0661 onehalf;00BD onehangzhou;3021 oneideographicparen;3220 oneinferior;2081 onemonospace;FF11 onenumeratorbengali;09F4 oneoldstyle;F731 oneparen;2474 oneperiod;2488 onepersian;06F1 onequarter;00BC oneroman;2170 onesuperior;00B9 onethai;0E51 onethird;2153 oogonek;01EB oogonekmacron;01ED oogurmukhi;0A13 oomatragurmukhi;0A4B oopen;0254 oparen;24AA openbullet;25E6 option;2325 ordfeminine;00AA ordmasculine;00BA orthogonal;221F oshortdeva;0912 oshortvowelsigndeva;094A oslash;00F8 oslashacute;01FF osmallhiragana;3049 osmallkatakana;30A9 osmallkatakanahalfwidth;FF6B ostrokeacute;01FF osuperior;F6F0 otcyrillic;047F otilde;00F5 otildeacute;1E4D otildedieresis;1E4F oubopomofo;3121 overline;203E overlinecenterline;FE4A overlinecmb;0305 overlinedashed;FE49 overlinedblwavy;FE4C overlinewavy;FE4B overscore;00AF ovowelsignbengali;09CB ovowelsigndeva;094B ovowelsigngujarati;0ACB p;0070 paampssquare;3380 paasentosquare;332B pabengali;09AA pacute;1E55 padeva;092A pagedown;21DF pageup;21DE pagujarati;0AAA pagurmukhi;0A2A pahiragana;3071 paiyannoithai;0E2F pakatakana;30D1 palatalizationcyrilliccmb;0484 palochkacyrillic;04C0 pansioskorean;317F paragraph;00B6 parallel;2225 parenleft;0028 parenleftaltonearabic;FD3E parenleftbt;F8ED parenleftex;F8EC parenleftinferior;208D parenleftmonospace;FF08 parenleftsmall;FE59 parenleftsuperior;207D parenlefttp;F8EB parenleftvertical;FE35 parenright;0029 parenrightaltonearabic;FD3F parenrightbt;F8F8 parenrightex;F8F7 parenrightinferior;208E parenrightmonospace;FF09 parenrightsmall;FE5A parenrightsuperior;207E parenrighttp;F8F6 parenrightvertical;FE36 partialdiff;2202 paseqhebrew;05C0 pashtahebrew;0599 pasquare;33A9 patah;05B7 patah11;05B7 patah1d;05B7 patah2a;05B7 patahhebrew;05B7 patahnarrowhebrew;05B7 patahquarterhebrew;05B7 patahwidehebrew;05B7 pazerhebrew;05A1 pbopomofo;3106 pcircle;24DF pdotaccent;1E57 pe;05E4 pecyrillic;043F pedagesh;FB44 pedageshhebrew;FB44 peezisquare;333B pefinaldageshhebrew;FB43 peharabic;067E peharmenian;057A pehebrew;05E4 pehfinalarabic;FB57 pehinitialarabic;FB58 pehiragana;307A pehmedialarabic;FB59 pekatakana;30DA pemiddlehookcyrillic;04A7 perafehebrew;FB4E percent;0025 percentarabic;066A percentmonospace;FF05 percentsmall;FE6A period;002E periodarmenian;0589 periodcentered;00B7 periodhalfwidth;FF61 periodinferior;F6E7 periodmonospace;FF0E periodsmall;FE52 periodsuperior;F6E8 perispomenigreekcmb;0342 perpendicular;22A5 perthousand;2030 peseta;20A7 pfsquare;338A phabengali;09AB phadeva;092B phagujarati;0AAB phagurmukhi;0A2B phi;03C6 phi1;03D5 phieuphacirclekorean;327A phieuphaparenkorean;321A phieuphcirclekorean;326C phieuphkorean;314D phieuphparenkorean;320C philatin;0278 phinthuthai;0E3A phisymbolgreek;03D5 phook;01A5 phophanthai;0E1E phophungthai;0E1C phosamphaothai;0E20 pi;03C0 pieupacirclekorean;3273 pieupaparenkorean;3213 pieupcieuckorean;3176 pieupcirclekorean;3265 pieupkiyeokkorean;3172 pieupkorean;3142 pieupparenkorean;3205 pieupsioskiyeokkorean;3174 pieupsioskorean;3144 pieupsiostikeutkorean;3175 pieupthieuthkorean;3177 pieuptikeutkorean;3173 pihiragana;3074 pikatakana;30D4 pisymbolgreek;03D6 piwrarmenian;0583 plus;002B plusbelowcmb;031F pluscircle;2295 plusminus;00B1 plusmod;02D6 plusmonospace;FF0B plussmall;FE62 plussuperior;207A pmonospace;FF50 pmsquare;33D8 pohiragana;307D pointingindexdownwhite;261F pointingindexleftwhite;261C pointingindexrightwhite;261E pointingindexupwhite;261D pokatakana;30DD poplathai;0E1B postalmark;3012 postalmarkface;3020 pparen;24AB precedes;227A prescription;211E primemod;02B9 primereversed;2035 product;220F projective;2305 prolongedkana;30FC propellor;2318 propersubset;2282 propersuperset;2283 proportion;2237 proportional;221D psi;03C8 psicyrillic;0471 psilipneumatacyrilliccmb;0486 pssquare;33B0 puhiragana;3077 pukatakana;30D7 pvsquare;33B4 pwsquare;33BA q;0071 qadeva;0958 qadmahebrew;05A8 qafarabic;0642 qaffinalarabic;FED6 qafinitialarabic;FED7 qafmedialarabic;FED8 qamats;05B8 qamats10;05B8 qamats1a;05B8 qamats1c;05B8 qamats27;05B8 qamats29;05B8 qamats33;05B8 qamatsde;05B8 qamatshebrew;05B8 qamatsnarrowhebrew;05B8 qamatsqatanhebrew;05B8 qamatsqatannarrowhebrew;05B8 qamatsqatanquarterhebrew;05B8 qamatsqatanwidehebrew;05B8 qamatsquarterhebrew;05B8 qamatswidehebrew;05B8 qarneyparahebrew;059F qbopomofo;3111 qcircle;24E0 qhook;02A0 qmonospace;FF51 qof;05E7 qofdagesh;FB47 qofdageshhebrew;FB47 qofhatafpatah;05E7 05B2 qofhatafpatahhebrew;05E7 05B2 qofhatafsegol;05E7 05B1 qofhatafsegolhebrew;05E7 05B1 qofhebrew;05E7 qofhiriq;05E7 05B4 qofhiriqhebrew;05E7 05B4 qofholam;05E7 05B9 qofholamhebrew;05E7 05B9 qofpatah;05E7 05B7 qofpatahhebrew;05E7 05B7 qofqamats;05E7 05B8 qofqamatshebrew;05E7 05B8 qofqubuts;05E7 05BB qofqubutshebrew;05E7 05BB qofsegol;05E7 05B6 qofsegolhebrew;05E7 05B6 qofsheva;05E7 05B0 qofshevahebrew;05E7 05B0 qoftsere;05E7 05B5 qoftserehebrew;05E7 05B5 qparen;24AC quarternote;2669 qubuts;05BB qubuts18;05BB qubuts25;05BB qubuts31;05BB qubutshebrew;05BB qubutsnarrowhebrew;05BB qubutsquarterhebrew;05BB qubutswidehebrew;05BB question;003F questionarabic;061F questionarmenian;055E questiondown;00BF questiondownsmall;F7BF questiongreek;037E questionmonospace;FF1F questionsmall;F73F quotedbl;0022 quotedblbase;201E quotedblleft;201C quotedblmonospace;FF02 quotedblprime;301E quotedblprimereversed;301D quotedblright;201D quoteleft;2018 quoteleftreversed;201B quotereversed;201B quoteright;2019 quoterightn;0149 quotesinglbase;201A quotesingle;0027 quotesinglemonospace;FF07 r;0072 raarmenian;057C rabengali;09B0 racute;0155 radeva;0930 radical;221A radicalex;F8E5 radoverssquare;33AE radoverssquaredsquare;33AF radsquare;33AD rafe;05BF rafehebrew;05BF ragujarati;0AB0 ragurmukhi;0A30 rahiragana;3089 rakatakana;30E9 rakatakanahalfwidth;FF97 ralowerdiagonalbengali;09F1 ramiddlediagonalbengali;09F0 ramshorn;0264 ratio;2236 rbopomofo;3116 rcaron;0159 rcedilla;0157 rcircle;24E1 rcommaaccent;0157 rdblgrave;0211 rdotaccent;1E59 rdotbelow;1E5B rdotbelowmacron;1E5D referencemark;203B reflexsubset;2286 reflexsuperset;2287 registered;00AE registersans;F8E8 registerserif;F6DA reharabic;0631 reharmenian;0580 rehfinalarabic;FEAE rehiragana;308C rehyehaleflamarabic;0631 FEF3 FE8E 0644 rekatakana;30EC rekatakanahalfwidth;FF9A resh;05E8 reshdageshhebrew;FB48 reshhatafpatah;05E8 05B2 reshhatafpatahhebrew;05E8 05B2 reshhatafsegol;05E8 05B1 reshhatafsegolhebrew;05E8 05B1 reshhebrew;05E8 reshhiriq;05E8 05B4 reshhiriqhebrew;05E8 05B4 reshholam;05E8 05B9 reshholamhebrew;05E8 05B9 reshpatah;05E8 05B7 reshpatahhebrew;05E8 05B7 reshqamats;05E8 05B8 reshqamatshebrew;05E8 05B8 reshqubuts;05E8 05BB reshqubutshebrew;05E8 05BB reshsegol;05E8 05B6 reshsegolhebrew;05E8 05B6 reshsheva;05E8 05B0 reshshevahebrew;05E8 05B0 reshtsere;05E8 05B5 reshtserehebrew;05E8 05B5 reversedtilde;223D reviahebrew;0597 reviamugrashhebrew;0597 revlogicalnot;2310 rfishhook;027E rfishhookreversed;027F rhabengali;09DD rhadeva;095D rho;03C1 rhook;027D rhookturned;027B rhookturnedsuperior;02B5 rhosymbolgreek;03F1 rhotichookmod;02DE rieulacirclekorean;3271 rieulaparenkorean;3211 rieulcirclekorean;3263 rieulhieuhkorean;3140 rieulkiyeokkorean;313A rieulkiyeoksioskorean;3169 rieulkorean;3139 rieulmieumkorean;313B rieulpansioskorean;316C rieulparenkorean;3203 rieulphieuphkorean;313F rieulpieupkorean;313C rieulpieupsioskorean;316B rieulsioskorean;313D rieulthieuthkorean;313E rieultikeutkorean;316A rieulyeorinhieuhkorean;316D rightangle;221F righttackbelowcmb;0319 righttriangle;22BF rihiragana;308A rikatakana;30EA rikatakanahalfwidth;FF98 ring;02DA ringbelowcmb;0325 ringcmb;030A ringhalfleft;02BF ringhalfleftarmenian;0559 ringhalfleftbelowcmb;031C ringhalfleftcentered;02D3 ringhalfright;02BE ringhalfrightbelowcmb;0339 ringhalfrightcentered;02D2 rinvertedbreve;0213 rittorusquare;3351 rlinebelow;1E5F rlongleg;027C rlonglegturned;027A rmonospace;FF52 rohiragana;308D rokatakana;30ED rokatakanahalfwidth;FF9B roruathai;0E23 rparen;24AD rrabengali;09DC rradeva;0931 rragurmukhi;0A5C rreharabic;0691 rrehfinalarabic;FB8D rrvocalicbengali;09E0 rrvocalicdeva;0960 rrvocalicgujarati;0AE0 rrvocalicvowelsignbengali;09C4 rrvocalicvowelsigndeva;0944 rrvocalicvowelsigngujarati;0AC4 rsuperior;F6F1 rtblock;2590 rturned;0279 rturnedsuperior;02B4 ruhiragana;308B rukatakana;30EB rukatakanahalfwidth;FF99 rupeemarkbengali;09F2 rupeesignbengali;09F3 rupiah;F6DD ruthai;0E24 rvocalicbengali;098B rvocalicdeva;090B rvocalicgujarati;0A8B rvocalicvowelsignbengali;09C3 rvocalicvowelsigndeva;0943 rvocalicvowelsigngujarati;0AC3 s;0073 sabengali;09B8 sacute;015B sacutedotaccent;1E65 sadarabic;0635 sadeva;0938 sadfinalarabic;FEBA sadinitialarabic;FEBB sadmedialarabic;FEBC sagujarati;0AB8 sagurmukhi;0A38 sahiragana;3055 sakatakana;30B5 sakatakanahalfwidth;FF7B sallallahoualayhewasallamarabic;FDFA samekh;05E1 samekhdagesh;FB41 samekhdageshhebrew;FB41 samekhhebrew;05E1 saraaathai;0E32 saraaethai;0E41 saraaimaimalaithai;0E44 saraaimaimuanthai;0E43 saraamthai;0E33 saraathai;0E30 saraethai;0E40 saraiileftthai;F886 saraiithai;0E35 saraileftthai;F885 saraithai;0E34 saraothai;0E42 saraueeleftthai;F888 saraueethai;0E37 saraueleftthai;F887 sarauethai;0E36 sarauthai;0E38 sarauuthai;0E39 sbopomofo;3119 scaron;0161 scarondotaccent;1E67 scedilla;015F schwa;0259 schwacyrillic;04D9 schwadieresiscyrillic;04DB schwahook;025A scircle;24E2 scircumflex;015D scommaaccent;0219 sdotaccent;1E61 sdotbelow;1E63 sdotbelowdotaccent;1E69 seagullbelowcmb;033C second;2033 secondtonechinese;02CA section;00A7 seenarabic;0633 seenfinalarabic;FEB2 seeninitialarabic;FEB3 seenmedialarabic;FEB4 segol;05B6 segol13;05B6 segol1f;05B6 segol2c;05B6 segolhebrew;05B6 segolnarrowhebrew;05B6 segolquarterhebrew;05B6 segoltahebrew;0592 segolwidehebrew;05B6 seharmenian;057D sehiragana;305B sekatakana;30BB sekatakanahalfwidth;FF7E semicolon;003B semicolonarabic;061B semicolonmonospace;FF1B semicolonsmall;FE54 semivoicedmarkkana;309C semivoicedmarkkanahalfwidth;FF9F sentisquare;3322 sentosquare;3323 seven;0037 sevenarabic;0667 sevenbengali;09ED sevencircle;2466 sevencircleinversesansserif;2790 sevendeva;096D seveneighths;215E sevengujarati;0AED sevengurmukhi;0A6D sevenhackarabic;0667 sevenhangzhou;3027 sevenideographicparen;3226 seveninferior;2087 sevenmonospace;FF17 sevenoldstyle;F737 sevenparen;247A sevenperiod;248E sevenpersian;06F7 sevenroman;2176 sevensuperior;2077 seventeencircle;2470 seventeenparen;2484 seventeenperiod;2498 seventhai;0E57 sfthyphen;00AD shaarmenian;0577 shabengali;09B6 shacyrillic;0448 shaddaarabic;0651 shaddadammaarabic;FC61 shaddadammatanarabic;FC5E shaddafathaarabic;FC60 shaddafathatanarabic;0651 064B shaddakasraarabic;FC62 shaddakasratanarabic;FC5F shade;2592 shadedark;2593 shadelight;2591 shademedium;2592 shadeva;0936 shagujarati;0AB6 shagurmukhi;0A36 shalshelethebrew;0593 shbopomofo;3115 shchacyrillic;0449 sheenarabic;0634 sheenfinalarabic;FEB6 sheeninitialarabic;FEB7 sheenmedialarabic;FEB8 sheicoptic;03E3 sheqel;20AA sheqelhebrew;20AA sheva;05B0 sheva115;05B0 sheva15;05B0 sheva22;05B0 sheva2e;05B0 shevahebrew;05B0 shevanarrowhebrew;05B0 shevaquarterhebrew;05B0 shevawidehebrew;05B0 shhacyrillic;04BB shimacoptic;03ED shin;05E9 shindagesh;FB49 shindageshhebrew;FB49 shindageshshindot;FB2C shindageshshindothebrew;FB2C shindageshsindot;FB2D shindageshsindothebrew;FB2D shindothebrew;05C1 shinhebrew;05E9 shinshindot;FB2A shinshindothebrew;FB2A shinsindot;FB2B shinsindothebrew;FB2B shook;0282 sigma;03C3 sigma1;03C2 sigmafinal;03C2 sigmalunatesymbolgreek;03F2 sihiragana;3057 sikatakana;30B7 sikatakanahalfwidth;FF7C siluqhebrew;05BD siluqlefthebrew;05BD similar;223C sindothebrew;05C2 siosacirclekorean;3274 siosaparenkorean;3214 sioscieuckorean;317E sioscirclekorean;3266 sioskiyeokkorean;317A sioskorean;3145 siosnieunkorean;317B siosparenkorean;3206 siospieupkorean;317D siostikeutkorean;317C six;0036 sixarabic;0666 sixbengali;09EC sixcircle;2465 sixcircleinversesansserif;278F sixdeva;096C sixgujarati;0AEC sixgurmukhi;0A6C sixhackarabic;0666 sixhangzhou;3026 sixideographicparen;3225 sixinferior;2086 sixmonospace;FF16 sixoldstyle;F736 sixparen;2479 sixperiod;248D sixpersian;06F6 sixroman;2175 sixsuperior;2076 sixteencircle;246F sixteencurrencydenominatorbengali;09F9 sixteenparen;2483 sixteenperiod;2497 sixthai;0E56 slash;002F slashmonospace;FF0F slong;017F slongdotaccent;1E9B smileface;263A smonospace;FF53 sofpasuqhebrew;05C3 softhyphen;00AD softsigncyrillic;044C sohiragana;305D sokatakana;30BD sokatakanahalfwidth;FF7F soliduslongoverlaycmb;0338 solidusshortoverlaycmb;0337 sorusithai;0E29 sosalathai;0E28 sosothai;0E0B sosuathai;0E2A space;0020 spacehackarabic;0020 spade;2660 spadesuitblack;2660 spadesuitwhite;2664 sparen;24AE squarebelowcmb;033B squarecc;33C4 squarecm;339D squarediagonalcrosshatchfill;25A9 squarehorizontalfill;25A4 squarekg;338F squarekm;339E squarekmcapital;33CE squareln;33D1 squarelog;33D2 squaremg;338E squaremil;33D5 squaremm;339C squaremsquared;33A1 squareorthogonalcrosshatchfill;25A6 squareupperlefttolowerrightfill;25A7 squareupperrighttolowerleftfill;25A8 squareverticalfill;25A5 squarewhitewithsmallblack;25A3 srsquare;33DB ssabengali;09B7 ssadeva;0937 ssagujarati;0AB7 ssangcieuckorean;3149 ssanghieuhkorean;3185 ssangieungkorean;3180 ssangkiyeokkorean;3132 ssangnieunkorean;3165 ssangpieupkorean;3143 ssangsioskorean;3146 ssangtikeutkorean;3138 ssuperior;F6F2 sterling;00A3 sterlingmonospace;FFE1 strokelongoverlaycmb;0336 strokeshortoverlaycmb;0335 subset;2282 subsetnotequal;228A subsetorequal;2286 succeeds;227B suchthat;220B suhiragana;3059 sukatakana;30B9 sukatakanahalfwidth;FF7D sukunarabic;0652 summation;2211 sun;263C superset;2283 supersetnotequal;228B supersetorequal;2287 svsquare;33DC syouwaerasquare;337C t;0074 tabengali;09A4 tackdown;22A4 tackleft;22A3 tadeva;0924 tagujarati;0AA4 tagurmukhi;0A24 taharabic;0637 tahfinalarabic;FEC2 tahinitialarabic;FEC3 tahiragana;305F tahmedialarabic;FEC4 taisyouerasquare;337D takatakana;30BF takatakanahalfwidth;FF80 tatweelarabic;0640 tau;03C4 tav;05EA tavdages;FB4A tavdagesh;FB4A tavdageshhebrew;FB4A tavhebrew;05EA tbar;0167 tbopomofo;310A tcaron;0165 tccurl;02A8 tcedilla;0163 tcheharabic;0686 tchehfinalarabic;FB7B tchehinitialarabic;FB7C tchehmedialarabic;FB7D tchehmeeminitialarabic;FB7C FEE4 tcircle;24E3 tcircumflexbelow;1E71 tcommaaccent;0163 tdieresis;1E97 tdotaccent;1E6B tdotbelow;1E6D tecyrillic;0442 tedescendercyrillic;04AD teharabic;062A tehfinalarabic;FE96 tehhahinitialarabic;FCA2 tehhahisolatedarabic;FC0C tehinitialarabic;FE97 tehiragana;3066 tehjeeminitialarabic;FCA1 tehjeemisolatedarabic;FC0B tehmarbutaarabic;0629 tehmarbutafinalarabic;FE94 tehmedialarabic;FE98 tehmeeminitialarabic;FCA4 tehmeemisolatedarabic;FC0E tehnoonfinalarabic;FC73 tekatakana;30C6 tekatakanahalfwidth;FF83 telephone;2121 telephoneblack;260E telishagedolahebrew;05A0 telishaqetanahebrew;05A9 tencircle;2469 tenideographicparen;3229 tenparen;247D tenperiod;2491 tenroman;2179 tesh;02A7 tet;05D8 tetdagesh;FB38 tetdageshhebrew;FB38 tethebrew;05D8 tetsecyrillic;04B5 tevirhebrew;059B tevirlefthebrew;059B thabengali;09A5 thadeva;0925 thagujarati;0AA5 thagurmukhi;0A25 thalarabic;0630 thalfinalarabic;FEAC thanthakhatlowleftthai;F898 thanthakhatlowrightthai;F897 thanthakhatthai;0E4C thanthakhatupperleftthai;F896 theharabic;062B thehfinalarabic;FE9A thehinitialarabic;FE9B thehmedialarabic;FE9C thereexists;2203 therefore;2234 theta;03B8 theta1;03D1 thetasymbolgreek;03D1 thieuthacirclekorean;3279 thieuthaparenkorean;3219 thieuthcirclekorean;326B thieuthkorean;314C thieuthparenkorean;320B thirteencircle;246C thirteenparen;2480 thirteenperiod;2494 thonangmonthothai;0E11 thook;01AD thophuthaothai;0E12 thorn;00FE thothahanthai;0E17 thothanthai;0E10 thothongthai;0E18 thothungthai;0E16 thousandcyrillic;0482 thousandsseparatorarabic;066C thousandsseparatorpersian;066C three;0033 threearabic;0663 threebengali;09E9 threecircle;2462 threecircleinversesansserif;278C threedeva;0969 threeeighths;215C threegujarati;0AE9 threegurmukhi;0A69 threehackarabic;0663 threehangzhou;3023 threeideographicparen;3222 threeinferior;2083 threemonospace;FF13 threenumeratorbengali;09F6 threeoldstyle;F733 threeparen;2476 threeperiod;248A threepersian;06F3 threequarters;00BE threequartersemdash;F6DE threeroman;2172 threesuperior;00B3 threethai;0E53 thzsquare;3394 tihiragana;3061 tikatakana;30C1 tikatakanahalfwidth;FF81 tikeutacirclekorean;3270 tikeutaparenkorean;3210 tikeutcirclekorean;3262 tikeutkorean;3137 tikeutparenkorean;3202 tilde;02DC tildebelowcmb;0330 tildecmb;0303 tildecomb;0303 tildedoublecmb;0360 tildeoperator;223C tildeoverlaycmb;0334 tildeverticalcmb;033E timescircle;2297 tipehahebrew;0596 tipehalefthebrew;0596 tippigurmukhi;0A70 titlocyrilliccmb;0483 tiwnarmenian;057F tlinebelow;1E6F tmonospace;FF54 toarmenian;0569 tohiragana;3068 tokatakana;30C8 tokatakanahalfwidth;FF84 tonebarextrahighmod;02E5 tonebarextralowmod;02E9 tonebarhighmod;02E6 tonebarlowmod;02E8 tonebarmidmod;02E7 tonefive;01BD tonesix;0185 tonetwo;01A8 tonos;0384 tonsquare;3327 topatakthai;0E0F tortoiseshellbracketleft;3014 tortoiseshellbracketleftsmall;FE5D tortoiseshellbracketleftvertical;FE39 tortoiseshellbracketright;3015 tortoiseshellbracketrightsmall;FE5E tortoiseshellbracketrightvertical;FE3A totaothai;0E15 tpalatalhook;01AB tparen;24AF trademark;2122 trademarksans;F8EA trademarkserif;F6DB tretroflexhook;0288 triagdn;25BC triaglf;25C4 triagrt;25BA triagup;25B2 ts;02A6 tsadi;05E6 tsadidagesh;FB46 tsadidageshhebrew;FB46 tsadihebrew;05E6 tsecyrillic;0446 tsere;05B5 tsere12;05B5 tsere1e;05B5 tsere2b;05B5 tserehebrew;05B5 tserenarrowhebrew;05B5 tserequarterhebrew;05B5 tserewidehebrew;05B5 tshecyrillic;045B tsuperior;F6F3 ttabengali;099F ttadeva;091F ttagujarati;0A9F ttagurmukhi;0A1F tteharabic;0679 ttehfinalarabic;FB67 ttehinitialarabic;FB68 ttehmedialarabic;FB69 tthabengali;09A0 tthadeva;0920 tthagujarati;0AA0 tthagurmukhi;0A20 tturned;0287 tuhiragana;3064 tukatakana;30C4 tukatakanahalfwidth;FF82 tusmallhiragana;3063 tusmallkatakana;30C3 tusmallkatakanahalfwidth;FF6F twelvecircle;246B twelveparen;247F twelveperiod;2493 twelveroman;217B twentycircle;2473 twentyhangzhou;5344 twentyparen;2487 twentyperiod;249B two;0032 twoarabic;0662 twobengali;09E8 twocircle;2461 twocircleinversesansserif;278B twodeva;0968 twodotenleader;2025 twodotleader;2025 twodotleadervertical;FE30 twogujarati;0AE8 twogurmukhi;0A68 twohackarabic;0662 twohangzhou;3022 twoideographicparen;3221 twoinferior;2082 twomonospace;FF12 twonumeratorbengali;09F5 twooldstyle;F732 twoparen;2475 twoperiod;2489 twopersian;06F2 tworoman;2171 twostroke;01BB twosuperior;00B2 twothai;0E52 twothirds;2154 u;0075 uacute;00FA ubar;0289 ubengali;0989 ubopomofo;3128 ubreve;016D ucaron;01D4 ucircle;24E4 ucircumflex;00FB ucircumflexbelow;1E77 ucyrillic;0443 udattadeva;0951 udblacute;0171 udblgrave;0215 udeva;0909 udieresis;00FC udieresisacute;01D8 udieresisbelow;1E73 udieresiscaron;01DA udieresiscyrillic;04F1 udieresisgrave;01DC udieresismacron;01D6 udotbelow;1EE5 ugrave;00F9 ugujarati;0A89 ugurmukhi;0A09 uhiragana;3046 uhookabove;1EE7 uhorn;01B0 uhornacute;1EE9 uhorndotbelow;1EF1 uhorngrave;1EEB uhornhookabove;1EED uhorntilde;1EEF uhungarumlaut;0171 uhungarumlautcyrillic;04F3 uinvertedbreve;0217 ukatakana;30A6 ukatakanahalfwidth;FF73 ukcyrillic;0479 ukorean;315C umacron;016B umacroncyrillic;04EF umacrondieresis;1E7B umatragurmukhi;0A41 umonospace;FF55 underscore;005F underscoredbl;2017 underscoremonospace;FF3F underscorevertical;FE33 underscorewavy;FE4F union;222A universal;2200 uogonek;0173 uparen;24B0 upblock;2580 upperdothebrew;05C4 upsilon;03C5 upsilondieresis;03CB upsilondieresistonos;03B0 upsilonlatin;028A upsilontonos;03CD uptackbelowcmb;031D uptackmod;02D4 uragurmukhi;0A73 uring;016F ushortcyrillic;045E usmallhiragana;3045 usmallkatakana;30A5 usmallkatakanahalfwidth;FF69 ustraightcyrillic;04AF ustraightstrokecyrillic;04B1 utilde;0169 utildeacute;1E79 utildebelow;1E75 uubengali;098A uudeva;090A uugujarati;0A8A uugurmukhi;0A0A uumatragurmukhi;0A42 uuvowelsignbengali;09C2 uuvowelsigndeva;0942 uuvowelsigngujarati;0AC2 uvowelsignbengali;09C1 uvowelsigndeva;0941 uvowelsigngujarati;0AC1 v;0076 vadeva;0935 vagujarati;0AB5 vagurmukhi;0A35 vakatakana;30F7 vav;05D5 vavdagesh;FB35 vavdagesh65;FB35 vavdageshhebrew;FB35 vavhebrew;05D5 vavholam;FB4B vavholamhebrew;FB4B vavvavhebrew;05F0 vavyodhebrew;05F1 vcircle;24E5 vdotbelow;1E7F vecyrillic;0432 veharabic;06A4 vehfinalarabic;FB6B vehinitialarabic;FB6C vehmedialarabic;FB6D vekatakana;30F9 venus;2640 verticalbar;007C verticallineabovecmb;030D verticallinebelowcmb;0329 verticallinelowmod;02CC verticallinemod;02C8 vewarmenian;057E vhook;028B vikatakana;30F8 viramabengali;09CD viramadeva;094D viramagujarati;0ACD visargabengali;0983 visargadeva;0903 visargagujarati;0A83 vmonospace;FF56 voarmenian;0578 voicediterationhiragana;309E voicediterationkatakana;30FE voicedmarkkana;309B voicedmarkkanahalfwidth;FF9E vokatakana;30FA vparen;24B1 vtilde;1E7D vturned;028C vuhiragana;3094 vukatakana;30F4 w;0077 wacute;1E83 waekorean;3159 wahiragana;308F wakatakana;30EF wakatakanahalfwidth;FF9C wakorean;3158 wasmallhiragana;308E wasmallkatakana;30EE wattosquare;3357 wavedash;301C wavyunderscorevertical;FE34 wawarabic;0648 wawfinalarabic;FEEE wawhamzaabovearabic;0624 wawhamzaabovefinalarabic;FE86 wbsquare;33DD wcircle;24E6 wcircumflex;0175 wdieresis;1E85 wdotaccent;1E87 wdotbelow;1E89 wehiragana;3091 weierstrass;2118 wekatakana;30F1 wekorean;315E weokorean;315D wgrave;1E81 whitebullet;25E6 whitecircle;25CB whitecircleinverse;25D9 whitecornerbracketleft;300E whitecornerbracketleftvertical;FE43 whitecornerbracketright;300F whitecornerbracketrightvertical;FE44 whitediamond;25C7 whitediamondcontainingblacksmalldiamond;25C8 whitedownpointingsmalltriangle;25BF whitedownpointingtriangle;25BD whiteleftpointingsmalltriangle;25C3 whiteleftpointingtriangle;25C1 whitelenticularbracketleft;3016 whitelenticularbracketright;3017 whiterightpointingsmalltriangle;25B9 whiterightpointingtriangle;25B7 whitesmallsquare;25AB whitesmilingface;263A whitesquare;25A1 whitestar;2606 whitetelephone;260F whitetortoiseshellbracketleft;3018 whitetortoiseshellbracketright;3019 whiteuppointingsmalltriangle;25B5 whiteuppointingtriangle;25B3 wihiragana;3090 wikatakana;30F0 wikorean;315F wmonospace;FF57 wohiragana;3092 wokatakana;30F2 wokatakanahalfwidth;FF66 won;20A9 wonmonospace;FFE6 wowaenthai;0E27 wparen;24B2 wring;1E98 wsuperior;02B7 wturned;028D wynn;01BF x;0078 xabovecmb;033D xbopomofo;3112 xcircle;24E7 xdieresis;1E8D xdotaccent;1E8B xeharmenian;056D xi;03BE xmonospace;FF58 xparen;24B3 xsuperior;02E3 y;0079 yaadosquare;334E yabengali;09AF yacute;00FD yadeva;092F yaekorean;3152 yagujarati;0AAF yagurmukhi;0A2F yahiragana;3084 yakatakana;30E4 yakatakanahalfwidth;FF94 yakorean;3151 yamakkanthai;0E4E yasmallhiragana;3083 yasmallkatakana;30E3 yasmallkatakanahalfwidth;FF6C yatcyrillic;0463 ycircle;24E8 ycircumflex;0177 ydieresis;00FF ydotaccent;1E8F ydotbelow;1EF5 yeharabic;064A yehbarreearabic;06D2 yehbarreefinalarabic;FBAF yehfinalarabic;FEF2 yehhamzaabovearabic;0626 yehhamzaabovefinalarabic;FE8A yehhamzaaboveinitialarabic;FE8B yehhamzaabovemedialarabic;FE8C yehinitialarabic;FEF3 yehmedialarabic;FEF4 yehmeeminitialarabic;FCDD yehmeemisolatedarabic;FC58 yehnoonfinalarabic;FC94 yehthreedotsbelowarabic;06D1 yekorean;3156 yen;00A5 yenmonospace;FFE5 yeokorean;3155 yeorinhieuhkorean;3186 yerahbenyomohebrew;05AA yerahbenyomolefthebrew;05AA yericyrillic;044B yerudieresiscyrillic;04F9 yesieungkorean;3181 yesieungpansioskorean;3183 yesieungsioskorean;3182 yetivhebrew;059A ygrave;1EF3 yhook;01B4 yhookabove;1EF7 yiarmenian;0575 yicyrillic;0457 yikorean;3162 yinyang;262F yiwnarmenian;0582 ymonospace;FF59 yod;05D9 yoddagesh;FB39 yoddageshhebrew;FB39 yodhebrew;05D9 yodyodhebrew;05F2 yodyodpatahhebrew;FB1F yohiragana;3088 yoikorean;3189 yokatakana;30E8 yokatakanahalfwidth;FF96 yokorean;315B yosmallhiragana;3087 yosmallkatakana;30E7 yosmallkatakanahalfwidth;FF6E yotgreek;03F3 yoyaekorean;3188 yoyakorean;3187 yoyakthai;0E22 yoyingthai;0E0D yparen;24B4 ypogegrammeni;037A ypogegrammenigreekcmb;0345 yr;01A6 yring;1E99 ysuperior;02B8 ytilde;1EF9 yturned;028E yuhiragana;3086 yuikorean;318C yukatakana;30E6 yukatakanahalfwidth;FF95 yukorean;3160 yusbigcyrillic;046B yusbigiotifiedcyrillic;046D yuslittlecyrillic;0467 yuslittleiotifiedcyrillic;0469 yusmallhiragana;3085 yusmallkatakana;30E5 yusmallkatakanahalfwidth;FF6D yuyekorean;318B yuyeokorean;318A yyabengali;09DF yyadeva;095F z;007A zaarmenian;0566 zacute;017A zadeva;095B zagurmukhi;0A5B zaharabic;0638 zahfinalarabic;FEC6 zahinitialarabic;FEC7 zahiragana;3056 zahmedialarabic;FEC8 zainarabic;0632 zainfinalarabic;FEB0 zakatakana;30B6 zaqefgadolhebrew;0595 zaqefqatanhebrew;0594 zarqahebrew;0598 zayin;05D6 zayindagesh;FB36 zayindageshhebrew;FB36 zayinhebrew;05D6 zbopomofo;3117 zcaron;017E zcircle;24E9 zcircumflex;1E91 zcurl;0291 zdot;017C zdotaccent;017C zdotbelow;1E93 zecyrillic;0437 zedescendercyrillic;0499 zedieresiscyrillic;04DF zehiragana;305C zekatakana;30BC zero;0030 zeroarabic;0660 zerobengali;09E6 zerodeva;0966 zerogujarati;0AE6 zerogurmukhi;0A66 zerohackarabic;0660 zeroinferior;2080 zeromonospace;FF10 zerooldstyle;F730 zeropersian;06F0 zerosuperior;2070 zerothai;0E50 zerowidthjoiner;FEFF zerowidthnonjoiner;200C zerowidthspace;200B zeta;03B6 zhbopomofo;3113 zhearmenian;056A zhebrevecyrillic;04C2 zhecyrillic;0436 zhedescendercyrillic;0497 zhedieresiscyrillic;04DD zihiragana;3058 zikatakana;30B8 zinorhebrew;05AE zlinebelow;1E95 zmonospace;FF5A zohiragana;305E zokatakana;30BE zparen;24B5 zretroflexhook;0290 zstroke;01B6 zuhiragana;305A zukatakana;30BA #--end ����������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/head.ps�������������������������������������������������������������������0000644�0000000�0000000�00000001201�12265263724�015155� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������%%DocumentFonts: (atend) /PicoEncoding ISOLatin1Encoding dup length array copy def /isoLatin1 { dup dup findfont dup length dict begin {1 index /FID ne {def} {pop pop} ifelse} forall /Encoding PicoEncoding def currentdict end definefont } def /glyphArrayShow { { dup type /stringtype eq {show} {glyphshow} ifelse } forall } def /glyphArrayWidth { 0 exch { dup type /stringtype eq { stringwidth pop } { matrix currentmatrix gsave newpath nulldevice setmatrix 0 0 moveto glyphshow currentpoint grestore pop } ifelse add } forall } def �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/heartbeat.l���������������������������������������������������������������0000644�0000000�0000000�00000000650�12265263724�016033� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 16feb08abu # (c) Software Lab. Alexander Burger (ifn (info "fifo/beat") (de heartbeat ()) (de heartbeat @ (out "fifo/beat" (pr (cons *Pid (cons (+ (* 86400 (date T)) (time T) 300) # Busy period 5 minutes (rest) ) ) ) ) ) (task -54321 0 (heartbeat)) (push1 '*Bye '(out "fifo/beat" (pr *Pid))) ) (de nobeat () (task -54321) ) ����������������������������������������������������������������������������������������picolisp-3.1.5.2.orig/lib/http.l��������������������������������������������������������������������0000644�0000000�0000000�00000034140�12265263724�015054� 0����������������������������������������������������������������������������������������������������ustar �root����������������������������root�������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 01jan14abu # (c) Software Lab. Alexander Burger # *Home *Gate *Host *Port *Port1 *Port% *Http1 *Chunked # *Sock *Agent *ContL *ContLen *MPartLim *MPartEnd "*HtSet" # *Post *Url *Timeout *SesAdr *SesId *ConId # *Referer *Cookies "*Cookies" (default *HPorts 0 *Timeout (* 300 1000) ) (mapc allow '(*Adr *Gate *Host *ContL)) (zero *Http1) (de *Mimes (`(chop "html") "text/html; charset=utf-8") (`(chop "au") "audio/basic" 3600) (`(chop "wav") "audio/x-wav" 3600) (`(chop "mp3") "audio/x-mpeg" 3600) (`(chop "gif") "image/gif" 3600) (`(chop "tif") "image/tiff" 3600) (`(chop "tiff") "image/tiff" 3600) (`(chop "bmp") "image/bmp" 86400) (`(chop "png") "image/png" 86400) (`(chop "jpg") "image/jpeg" 3600) (`(chop "jpeg") "image/jpeg" 3600) (`(chop "txt") "text/octet-stream" 1 T) (`(chop "csv") "text/csv; charset=utf-8" 1 T) (`(chop "css") "text/css" 3600) (`(chop "js") "application/x-javascript" 86400) (`(chop "ps") "application/postscript" 1) (`(chop "pdf") "application/pdf" 1) (`(chop "zip") "application/zip" 1) (`(chop "jar") "application/java-archive" 86400) ) (de mime (S . @) (let L (chop S) (if (assoc L *Mimes) (con @ (rest)) (push '*Mimes (cons L (rest))) ) ) ) (de mimetype (File) (in (list 'file "--brief" "--mime" File) (line T) ) ) ### HTTP-Client ### (de client (Host Port How . Prg) (let? Sock (connect Host Port) (prog1 (out Sock (if (atom How) (prinl "GET /" How " HTTP/1.0^M") (prinl "POST /" (car How) " HTTP/1.0^M") (prinl "Content-Length: " (size (cdr How)) "^M") ) (prinl "User-Agent: PicoLisp^M") (prinl "Host: " Host "^M") (prinl "Accept-Charset: utf-8^M") (prinl "^M") (and (pair How) (prin (cdr @))) (flush) (in Sock (run Prg 1)) ) (close Sock) ) ) ) # Local Password (de pw (N) (if N (out ".pw" (prinl (fmt64 (in "/dev/urandom" (rd N))))) (in ".pw" (line T)) ) ) # PicoLisp Shell (de psh (Pw Tty) (off *Run) (when (and (= Pw (pw)) (ctty Tty)) (prinl *Pid) (load "@dbg.l") (off *Err) (quit) ) ) ### HTTP-Server ### (de -server () (server (format (opt)) (opt)) ) (de server (P H) (setq *Port P *Port1 P *Home (cons H (chop H)) P (port *Port) ) (gc) (loop (setq *Sock (listen P)) (NIL (fork) (close P)) (close *Sock) ) (task *Sock (http @)) (http *Sock) (or *SesId (bye)) (task *Sock (when (accept *Sock) (task @ (http @)) ) ) ) (de baseHRef (Port . @) (pass pack (or *Gate "http") "://" *Host (if *Gate "/" ":") (or Port *Port) "/" ) ) (de https @ (pass pack "https://" *Host "/" *Port "/" *SesId) ) (de ext.html (Sym) (pack (ht:Fmt Sym) ".html") ) (de disallowed () (and *Allow (not (idx *Allow *Url)) (or (sub? ".." *Url) (nor (and *Tmp (pre? *Tmp *Url)) (find pre? (cdr *Allow) (circ *Url)) ) ) ) ) (de notAllowed (X) (unless (= X "favicon.ico") (msg X " [" *Adr "] not allowed") ) ) # Application startup (de app () (unless *SesId (setq *Port% (not *Gate) *SesAdr *Adr *SesId (pack (in "/dev/urandom" (rd 7)) "~") *Sock (port *HPorts '*Port) ) (timeout *Timeout) ) ) # Set a cookie (de cookie @ (if (assoc (next) "*Cookies") (con @ (rest)) (push '"*Cookies" (cons (arg) (rest))) ) ) # Handle HTTP-Transaction (de http (S) (use (*Post L @U @H @X) (off *Post *Port% *ContL *ContLen *Cookies "*Cookies" "*HtSet") (catch 'http (in S (cond ((not (setq L (line))) (task (close S)) (off S) (throw 'http) ) ((match '("G" "E" "T" " " "/" @U " " "H" "T" "T" "P" "/" "1" "." @H) L) (_htHead) ) ((match '("P" "O" "S" "T" " " "/" @U " " "H" "T" "T" "P" "/" "1" "." @H) L) (on *Post) (off *MPartLim *MPartEnd) (_htHead) (cond (*MPartLim (_htMultipart)) ((=0 *ContLen)) ((cond (*ContL (line)) (*ContLen (ht:Read @))) (for L (split @ '&) (when (setq L (split L "=")) (let? S (_htSet (car L) (ht:Pack (cadr L))) (and (cddr L) (format (car @)) (unless (out (tmp S) (echo @)) (call 'rm "-f" (tmp S)) ) ) ) ) ) ) (T (throw 'http)) ) ) (T (out S (if (and (match '(@U " " @ " " "H" "T" "T" "P" . @) L) (member @U (quote ("O" "P" "T" "I" "O" "N" "S") ("H" "E" "A" "D") ("P" "U" "T") ("D" "E" "L" "E" "T" "E") ("T" "R" "A" "C" "E") ("C" "O" "N" "N" "E" "C" "T") ) ) ) (httpStat 501 "Method Not Implemented" "Allow: GET, POST") (httpStat 400 "Bad Request") ) ) (task (close S)) (off S) (throw 'http) ) ) (if (or (<> *ConId *SesId) (and *SesAdr (<> @ *Adr))) (prog (task (close S)) (off S)) (setq L (split @U "?") @U (car L) L (mapcan '((A) (cond ((cdr (setq A (split A "="))) (nil (_htSet (car A) (htArg (cadr A)))) ) ((tail '`(chop ".html") (car A)) (cons (pack (car A))) ) (T (cons (htArg (car A)))) ) ) (split (cadr L) "&") ) ) (unless (setq *Url (ht:Pack @U)) (setq *Url (car *Home) @U (cdr *Home)) ) (out S (cond ((match '("-" @X "." "h" "t" "m" "l") @U) (and *SesId (timeout *Timeout)) (apply try L 'html> (extern (ht:Pack @X))) ) ((disallowed) (notAllowed *Url) (http404) ) ((= '! (car @U)) (and *SesId (timeout *Timeout)) (apply (val (intern (ht:Pack (cdr @U)))) L) ) ((tail '("." "l") @U) (and *SesId (timeout *Timeout)) (apply script L *Url) ) ((=T (car (info *Url))) (if (info (setq *Url (pack *Url "/default"))) (apply script L *Url) (http404) ) ) ((assoc (stem @U ".") *Mimes) (apply httpEcho (cdr @) *Url) ) (T (httpEcho *Url "application/octet-stream" 1 T)) ) ) ) ) ) (and S (=0 *Http1) (task (close S))) ) ) (de _htHead () (use (L @X @Y) (setq *Http1 (format (car @H)) *Chunked (gt0 *Http1)) (if (index "~" @U) (setq *ConId (head @ @U) @U (cdr (nth @U @)) *ConId (pack (if (member "/" *ConId) (cdr @) *ConId)) ) (off *ConId) ) (while (setq L (line)) (cond ((match '(~(chop "Host: ") . @X) L) (setq *Host @X) ) ((match '(~(chop "Referer: ") . @X) L) (setq *Referer @X) ) ((match '(~(chop "Cookie: ") . @X) L) (setq *Cookies (mapcar '((L) (setq L (split L "=")) (cons (htArg (clip (car L))) (htArg (cadr L))) ) (split @X ";") ) ) ) ((match '(~(chop "User-Agent: ") . @X) L) (setq *Agent @X) ) ((match '(~(chop "Content-@ength: ") . @X) L) (setq *ContLen (format @X)) ) ((match '(~(chop "Content-@ype: multipart/form-data; boundary=") . @X) L) (setq *MPartLim (append '(- -) @X) *MPartEnd (append *MPartLim '(- -)) ) ) ((match '(~(chop "X-Pil: ") @X "=" . @Y) L) (_htSet @X (ht:Pack @Y)) ) ) ) (unless *Gate (and (member ":" *Host) (con (prior @ *Host))) ) ) ) # rfc1867 multipart/form-data (de _htMultipart () (use (L @X @N @V) (setq L (line)) (while (= *MPartLim L) (unless (match '(~(chop "Content-Disposition: form-data; name=") . @X) (line)) (throw 'http) ) (while (line)) (cond ((not (member ";" @X)) (match '("\"" @X "\"") @X) (_htSet @X (pack (make (until (or (= *MPartLim (setq L (line))) (= *MPartEnd L) ) (when (eof) (throw 'http) ) (when (made) (link "^J") ) (link (trim L)) ) ) ) ) ) ((match '(@N ~(chop "; filename=") . @V) @X) (match '("\"" @N "\"") @N) (match '("\"" @V "\"") @V) (if (_htSet @N (pack (stem @V "/" "\\"))) (let F (tmp @) (unless (out F (echo (pack "^M^J" *MPartLim))) (call 'rm "-f" F) ) ) (out "/dev/null" (echo (pack "^M^J" *MPartLim))) ) (setq L (if (= "-" (car (line))) *MPartEnd *MPartLim)) ) ) ) ) ) (de _htSet (L Val) (let "Var" (intern (ht:Pack (car (setq L (split L ":"))))) (cond ((and *Allow (not (idx *Allow "Var"))) (notAllowed "Var") (throw 'http) ) ((cadr L) (let? N (format (car (setq L (split @ ".")))) (case (caadr L) ("x" (setq Val (cons (format Val)))) ("y" (setq Val (cons NIL (format Val)))) ) (nond ((memq "Var" "*HtSet") (push '"*HtSet" "Var") (set "Var" (cons (cons N Val))) Val ) ((assoc N (val "Var")) (queue "Var" (cons N Val)) Val ) (NIL (let X @ (cond ((nand (cadr L) (cdr X)) (con X Val)) ((car Val) (set (cdr X) @)) (T (con (cdr X) (cdr Val))) ) ) ) ) ) ) (T (if (= "*" (caar L)) (set "Var" Val) (put "Var" 'http Val) ) ) ) ) ) (de htArg (Lst) (case (car Lst) ("$" (intern (ht:Pack (cdr Lst)))) ("+" (format (cdr Lst))) ("-" (extern (ht:Pack (cdr Lst)))) ("_" (mapcar htArg (split (cdr Lst) "_"))) (T (ht:Pack Lst)) ) ) # Http Transfer Header (de http1 (Typ Upd File Att) (prinl "HTTP/1." *Http1 " 200 OK^M") (prinl "Server: PicoLisp^M") (prin "Date: ") (httpDate (date T) (time T)) (when Upd (prinl "Cache-Control: max-age=" Upd "^M") (when (=0 Upd) (prinl "Cache-Control: private, no-store, no-cache^M") ) ) (prinl "Content-Type: " (or Typ "text/html; charset=utf-8") "^M") (when File (prinl "Content-Disposition: " (if Att "attachment" "inline") "; filename=\"" File "\"^M" ) ) ) (de httpCookies () (mapc '((L) (prin "Set-Cookie: " (ht:Fmt (pop 'L)) "=" (ht:Fmt (pop 'L)) "; path=" (or (pop 'L) "/") ) (and (pop 'L) (prin "; expires=" @)) (and (pop 'L) (prin "; domain=" @)) (and (pop 'L) (prin "; secure")) (and (pop 'L) (prin "; HttpOnly")) (prinl) ) "*Cookies" ) ) (de respond (S) (http1 "application/octet-stream" 0) (prinl "Content-Length: " (size S) "^M^J^M") (prin S) ) (de httpHead (Typ Upd File Att) (http1 Typ Upd File Att) (and *Chunked (prinl "Transfer-Encoding: chunked^M")) (httpCookies) (prinl "^M") ) (de httpDate (Dat Tim) (let D (date Dat) (prinl (day Dat *Day) ", " (pad 2 (caddr D)) " " (get *Mon (cadr D)) " " (car D) " " (tim$ Tim T) " GMT^M" ) ) ) # Http Echo (de httpEcho (File Typ Upd Att) (and *Tmp (pre? *Tmp File) (one Upd)) (ifn (info File) (http404) (let I @ (http1 (or Typ (mimetype File)) Upd (stem (chop File) "/") Att) (prinl "Content-Length: " (car I) "^M") (prin "Last-Modified: ") (httpDate (cadr I) (cddr I)) (prinl "^M") (in File (echo)) ) ) ) (de srcUrl (Url) (if (or (pre? "http:" Url) (pre? "https:" Url)) Url (baseHRef *Port1 Url) ) ) (de sesId (Url) (if (or (pre? "http:" Url) (pre? "https:" Url) (pre? "mailto:" Url) (pre? "javascript:" Url) ) Url (pack *SesId Url) ) ) (de httpStat (N Str . @) (prinl "HTTP/1." *Http1 " " N " " Str "^M") (prinl "Server: PicoLisp^M") (while (args) (prinl (next) "^M") ) (prinl "Content-Type: text/html^M") (httpCookies) (prinl "Content-Length: " (+ 68 (length N) (* 2 (length Str))) "^M") (prinl "^M") (prinl "<HTML>") (prinl "<HEAD><TITLE>" N " " Str "") (prinl "

      " Str "

      ") (prinl "") ) (de noContent () (httpStat 204 "No Content") ) (de redirect @ (httpStat 303 "See Other" (pass pack "Location: ")) ) (de forbidden () (httpStat 403 "No Permission") (throw 'http) ) (de http404 () (httpStat 404 "Not Found") ) ### Debug ### `*Dbg (noLint 'http '"O") # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/import.l0000644000000000000000000000112012265263724015377 0ustar rootroot# 15jul05abu # (c) Software Lab. Alexander Burger ### Import Parsing ### (de getStr (N Lst) (pack (clip (get Lst N))) ) (de getSym (N Lst) (intern (pack (replace (clip (get Lst N)) " " '_)) ) ) (de getStrLst (N Lst) (mapcar pack (split (clip (get Lst N)) " ")) ) (de getSymLst (N Lst) (mapcar '((L) (intern (pack L))) (split (clip (get Lst N)) " ") ) ) (de getNum (N Lst) (format (getStr N Lst)) ) (de getFlt (P N Lst) (format (getStr N Lst) P *Sep0 *Sep3) ) (de getDat (L Lst) (date (mapcar '((N) (getNum N Lst)) L ) ) ) picolisp-3.1.5.2.orig/lib/led.l0000644000000000000000000003050312265263724014640 0ustar rootroot# 16jul13abu # (c) Software Lab. Alexander Burger # Line editor # vi-mode, just a subset: # - Only single-key commands # - No repeat count (mapc undef '(*Led fkey revise) ) (setq "Line" NIL # Holds current input line "LPos" 1 # Position in line (1 .. length) "HPos" 1 # Position in history "UndoLine" NIL # Undo "UndoPos" 0 "Line1" NIL # Initial line "Insert" T # Insert mode flag "FKey" NIL # Function key bindings "Clip" NIL # Cut/Copy/Paste buffer "Item" NIL # Item to find "Found" NIL # Find stack "Complete" NIL # Input completion "HistMax" 1000 # History limit *History # History of input lines (in (pack "+" (pil "history")) (ctl NIL (make (until (eof) (link (line T)))) ) ) "Hist0" *History ) # Basic editing routine (de chgLine (L N) (let (D (length "Line") Tsm) (for (P (dec "LPos") (>= P 1) (dec P)) # To start of old line (unless (and *Tsm (= "\"" (get "Line" P)) (skipQ "LPos" P "Line") ) (prin "^H") ) ) (for (P . C) (setq "Line" L) # Output new line (cond ((> " " C) (dec 'D) (prin "_") ) ((or (not *Tsm) (<> "\"" C) (escQ P L)) (dec 'D) (prin C) ) (T (prin (and Tsm (cdr *Tsm)) (unless (skipQ N P L) (dec 'D) C ) (and (onOff Tsm) (car *Tsm)) ) ) ) ) (and Tsm (prin (cdr *Tsm))) (space D) # Clear rest of old line (do D (prin "^H")) (setq "LPos" (inc (length L))) (until (= N "LPos") # To new position (unless (and *Tsm (= "\"" (get "Line" "LPos")) (skipQ N "LPos" "Line") ) (prin "^H") ) (dec '"LPos") ) ) (flush) ) # Skipped double quote (de skipQ (N P L) (nor (>= (inc N) P (dec N)) (= "\"" (get L (dec P))) (= "\"" (get L (inc P))) (escQ P L) ) ) # Escaped double quote (de escQ () (let Esc NIL (for I (dec P) ((if (= "\\" (get L I)) onOff off) Esc) ) ) ) # Check for delimiter (de delim? (C) (member C '`(chop '" ^I^J^M\"'()[]`~")) ) # Move left (de lMove () (chgLine "Line" (max 1 (dec "LPos"))) ) # Move to beginning (de bMove () (chgLine "Line" 1) ) # Move right (de rMove (F) (chgLine "Line" (min (inc "LPos") (if F (inc (length "Line")) (length "Line") ) ) ) ) # Move to end of line (de eMove () (chgLine "Line" (length "Line")) ) # Move beyond end of line (de xMove () (chgLine "Line" (inc (length "Line"))) ) # Move up (de uMove () (when (< "HPos" (length *History)) (setHist (inc "HPos")) ) ) # Move down (de dMove () (unless (=0 "HPos") (setHist (dec "HPos")) ) ) # Move word left (de lWord () (use (N L) (chgLine "Line" (if (>= 1 (setq N "LPos")) 1 (loop (T (= 1 (dec 'N)) 1) (setq L (nth "Line" (dec N))) (T (and (delim? (car L)) (not (delim? (cadr L)))) N ) ) ) ) ) ) # Move word right (de rWord () (use (M N L) (setq M (length "Line")) (chgLine "Line" (if (<= M (setq N "LPos")) M (loop (T (= M (inc 'N)) M) (setq L (nth "Line" (dec N))) (T (and (delim? (car L)) (not (delim? (cadr L)))) N ) ) ) ) ) ) # Match left parenthesis (de lPar () (let (N 1 I (dec "LPos")) (loop (T (=0 I)) (case (get "Line" I) (")" (inc 'N)) ("(" (dec 'N)) ) (T (=0 N) (chgLine "Line" I)) (dec 'I) ) ) ) # Match right parenthesis (de rPar () (let (N 1 I (inc "LPos")) (loop (T (> I (length "Line"))) (case (get "Line" I) ("(" (inc 'N)) (")" (dec 'N)) ) (T (=0 N) (chgLine "Line" I)) (inc 'I) ) ) ) # Clear to end of line (de clrEol () (let N (dec "LPos") (if (=0 N) (chgLine NIL 1) (chgLine (head N "Line") N) ) ) ) # Insert a char (de insChar (C) (chgLine (insert "LPos" "Line" C) (inc "LPos")) ) (de del1 (L) (ifn (nth L "LPos") L (setq "Clip" (append "Clip" (list (get L "LPos")))) (remove "LPos" L) ) ) # Delete a char (de delChar () (use L (off "Clip") (chgLine (setq L (del1 "Line")) (max 1 (min "LPos" (length L))) ) ) ) # Delete a word (F: with trailing blank) (de delWord (F) (let L "Line" (off "Clip") (ifn (= "(" (get L "LPos")) (while (and (nth L "LPos") (not (delim? (get L "LPos")))) (setq L (del1 L)) ) (for (N 1 (and (setq L (del1 L)) (< 0 N))) (case (get L "LPos") ("(" (inc 'N)) (")" (dec 'N)) ) ) ) (and F (sp? (get L "LPos")) (setq L (del1 L)) ) (chgLine L (max 1 (min "LPos" (length L)))) ) ) # Replace char (de rplChar (C) (chgLine (insert "LPos" (remove "LPos" "Line") C) "LPos" ) ) # Undo mechanism (de doUndo () (setq "UndoLine" "Line" "UndoPos" "LPos") ) # Paste clip (de doPaste () (if (= 1 "LPos") (chgLine (append "Clip" "Line") 1) (chgLine (append (head (dec "LPos") "Line") "Clip" (nth "Line" "LPos") ) (+ "LPos" (length "Clip") -1) ) ) ) # Set history line (de setHist (N) (chgLine (if (=0 (setq "HPos" N)) "Line1" (chop (get *History "HPos")) ) 1 ) ) # Searching (de ledSearch (L) (let (H (nth *History (inc "HPos")) S (find '((X) (match "Item" (chop X))) H)) (chgLine (ifn S (prog (beep) L) (push '"Found" "HPos") (inc '"HPos" (index S H)) (chop S) ) 1 ) ) ) # TAB expansion (de expandTab () (let ("L" (head (dec "LPos") "Line") "S" "L") (while (find "skipFun" "S") (pop '"S") ) (ifn "S" (prog (off "Complete") (do 3 (insChar " ")) ) (ifn (default "Complete" (let "N" (inc (length "S")) (mapcar '((X) (setq X (nth (mapcan '((C) (if (or (= "\\" C) (delim? C)) (list "\\" C) (cons C) ) ) (chop X) ) "N" ) ) (cons (+ "LPos" (length X)) (append "L" X (nth "Line" "LPos")) ) ) ("tabFun" (pack "S")) ) ) ) (beep) (chgLine (cdar "Complete") (caar "Complete")) (rot "Complete") ) ) ) ) # Insert mode (de insMode ("C") (if (= "C" "^I") (expandTab) (off "Complete") (case "C" (("^H" "^?") (when (> "LPos" 1) (chgLine (remove (dec "LPos") "Line") (dec "LPos")) ) ) ("^V" (insChar (key))) ("^E" (and edit (edit '*History))) ("^[" (loop (NIL (make (while (and (setq "C" (key 40)) (<> "C" "^[")) (link "C") ) ) (off "Insert") (lMove) ) (when (assoc (pack "^[" @) "FKey") (let *Dbg "*Dbg" (run (cdr @))) ) (NIL "C") ) ) (T (if (assoc "C" "FKey") (let *Dbg "*Dbg" (run (cdr @))) (when (= "C" ")") (chgLine "Line" (prog1 "LPos" (lPar) (wait 200))) ) (insChar "C") ) ) ) ) ) # Command mode (de cmdMode ("C") (case "C" ("g" (prinl) (println "Clip")) ("$" (eMove)) ("%" (case (get "Line" "LPos") (")" (lPar)) ("(" (rPar)) (T (beep)) ) ) ("/" (let "L" "Line" (_getLine '("/") '((C) (= C "/"))) (unless (=T "Line") (setq "Item" (append '(@) (cdr "Line") '(@))) (ledSearch "L") (off "Insert") ) ) ) ("0" (bMove)) ("A" (doUndo) (xMove) (on "Insert")) ("a" (doUndo) ((if (= "LPos" (length "Line")) xMove rMove)) (on "Insert")) ("b" (lWord)) ("c" (doUndo) (delWord NIL) (on "Insert")) ("C" (doUndo) (clrEol) (xMove) (on "Insert")) ("d" (doUndo) (delWord T)) ("D" (doUndo) (clrEol)) ("f" (ifn (setq "C" (index (key) (nth "Line" (inc "LPos")))) (beep) (chgLine "Line" (+ "C" "LPos")) ) ) ("h" (lMove)) ("i" (doUndo) (on "Insert")) ("I" (doUndo) (bMove) (on "Insert")) ("j" (dMove)) ("k" (uMove)) ("l" (rMove)) ("n" (ledSearch "Line")) ("N" (if "Found" (setHist (pop '"Found")) (beep))) ("p" (doUndo) ((if (= "LPos" (length "Line")) xMove rMove)) (doPaste)) ("P" (doUndo) (doPaste)) ("r" (ifn "Line" (beep) (doUndo) (rplChar (key)))) ("s" (doUndo) (delChar) (on "Insert")) ("S" (doUndo) (chgLine NIL 1) (on "Insert")) ("U" (setHist "HPos")) ("u" (let ("L" "Line" "P" "LPos") (chgLine "UndoLine" "UndoPos") (setq "UndoLine" "L" "UndoPos" "P") ) ) ("w" (rWord)) ("x" (doUndo) (delChar)) ("X" (lMove) (doUndo) (delChar)) ("~" (doUndo) (rplChar ((if (low? (setq "C" (get "Line" "LPos"))) uppc lowc) "C") ) (rMove) ) (T (beep)) ) ) # Get a line from console (de _getLine ("L" "skipFun") (use "C" (chgLine "L" (inc (length "L"))) (on "Insert") (until (member (setq "C" (let *Dbg "*Dbg" (key))) '("^J" "^M")) (case "C" (NIL (bye)) ("^D" (prinl) (bye)) ("^X" (prin (cdr *Tsm)) (prinl) (quit)) ) ((if "Insert" insMode cmdMode) "C") ) (eMove) ) ) # Function keys (de fkey (Key . Prg) (setq "FKey" (cond ((not Key) "FKey") ((not Prg) (delete (assoc Key "FKey") "FKey")) ((assoc Key "FKey") (cons (cons Key Prg) (delete @ "FKey")) ) (T (cons (cons Key Prg) "FKey")) ) ) ) (when (sys "TERM") (fkey "^[[A" (uMove) (xMove)) (fkey "^[[B" (dMove) (xMove)) (fkey "^[[C" (rMove T)) (fkey "^[[D" (lMove)) ) # Main editing functions (de _led ("Line1" "tabFun" "skipFun") (default "tabFun" '((S) (conc (filter '((X) (pre? S X)) (all)) (let P (rot (split (chop S) "/")) (setq S (pack (car P)) P (and (cdr P) (pack (glue "/" @) "/")) ) (extract '((X) (and (pre? S X) (pack P X))) (dir P T) ) ) ) ) ) (setq "LPos" 1 "HPos" 0) (_getLine "Line1" (or "skipFun" delim?)) (prinl (cdr *Tsm)) ) (de revise ("X" "tabFun" "skipFun") (let ("*Dbg" *Dbg *Dbg NIL) (_led (chop "X") "tabFun" "skipFun") (pack "Line") ) ) (de saveHistory () (in (pack "+" (pil "history")) (ctl T (let (Old (make (until (eof) (link (line T)))) New *History N "HistMax") (out (pil "history") (while (and New (n== New "Hist0")) (prinl (pop 'New)) (dec 'N) ) (setq "Hist0" *History) (do N (NIL Old) (prinl (pop 'Old)) ) ) ) ) ) ) # Enable line editing (de *Led (let ("*Dbg" *Dbg *Dbg NIL) (push1 '*Bye '(saveHistory)) (push1 '*Fork '(del '(saveHistory) '*Bye)) (_led) (let L (pack "Line") (or (>= 3 (length "Line")) (sp? (car "Line")) (= L (car *History)) (push '*History L) ) (and (nth *History "HistMax") (con @)) L ) ) ) (mapc zap (quote chgLine skipQ escQ delim? lMove bMove rMove eMove xMove uMove dMove lWord rWord lPar rPar clrEol insChar del1 delChar delWord rplChar doUndo doPaste setHist ledSearch expandTab insMode cmdMode _getLine _led saveHistory ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/led.min.l0000644000000000000000000000076212265263724015426 0ustar rootroot# 05feb05abu # (c) Software Lab. Alexander Burger # *Line # Line input editing (de mkChar (C) (prin C) (queue '*Line C) ) # Enable line editing (de *Led (use C (until (member (setq C (key)) '("^J" "^M")) (case C (("^H" "^?") (when *Line (prin "^H ^H") (setq *Line (cdr (rot *Line))) ) ) ("^I" (do 3 (mkChar " "))) (T (mkChar C)) ) ) ) (prinl) (prog1 (pack *Line) (off *Line)) ) picolisp-3.1.5.2.orig/lib/lint.l0000644000000000000000000002071112265263724015042 0ustar rootroot# 31jul13abu # (c) Software Lab. Alexander Burger # *NoLint (de noLint (X V) (if V (push1 '*NoLint (cons X V)) (or (memq X *NoLint) (push '*NoLint X)) ) ) (de global? (S) (or (memq S '(NIL ^ @ @@ @@@ This T)) (member (char S) '(`(char '*) `(char '+))) ) ) (de local? (S) (or (str? S) (member (char S) '(`(char '*) `(char '_))) ) ) (de dlsym? (S) (and (car (setq S (split (chop S) ':))) (cadr S) (low? (caar S)) ) ) (de lint1 ("X") (cond ((atom "X") (when (sym? "X") (cond ((memq "X" "*L") (setq "*Use" (delq "X" "*Use"))) ((local? "X") (lint2 (val "X"))) (T (or (getd "X") (global? "X") (member (cons "*X" "X") *NoLint) (memq "X" "*Bnd") (push '"*Bnd" "X") ) ) ) ) ) ((num? (car "X"))) (T (casq (car "X") ((: ::)) (; (lint1 (cadr "X"))) (quote (let F (fun? (cdr "X")) (if (or (and (pair F) (not (fin @))) (== '@ F)) (use "*L" (lintFun (cdr "X"))) (lint2 (cdr "X")) ) ) ) ((de dm) (let "*X" (cadr "X") (lintFun (cddr "X")) ) ) (recur (let recurse (cdr "X") (lintFun recurse) ) ) (task (lint1 (cadr "X")) (let "Y" (cddr "X") (use "*L" (while (num? (car "Y")) (pop '"Y") ) (while (and (car "Y") (sym? @)) (lintVar (pop '"Y")) (pop '"Y") ) (mapc lint1 "Y") ) ) ) (let? (use "*L" (lintVar (cadr "X")) (mapc lint1 (cddr "X")) ) ) (let (use "*L" (if (atom (cadr "X")) (lintVar (cadr "X")) (for (L (cadr "X") L (cddr L)) (lintDup (car L) (extract '((X F) (and F X)) (cddr L) '(T NIL .) ) ) (lintVar (car L)) (lint1 (cadr L)) ) ) (mapc lint1 (cddr "X")) ) ) (use (use "*L" (if (atom (cadr "X")) (lintVar (cadr "X")) (mapc lintVar (cadr "X")) ) (mapc lint1 (cddr "X")) ) ) (for (use "*L" (let "Y" (cadr "X") (cond ((atom "Y") # (for X (1 2 ..) ..) (lint1 (caddr "X")) (lintVar "Y") (lintLoop (cdddr "X")) ) ((atom (cdr "Y")) # (for (I . X) (1 2 ..) ..) (lintVar (car "Y")) (lint1 (caddr "X")) (lintVar (cdr "Y")) (lintLoop (cdddr "X")) ) ((atom (car "Y")) # (for (X (1 2 ..) ..) ..) (lint1 (cadr "Y")) (lintVar (car "Y")) (mapc lint1 (cddr "Y")) (lintLoop (cddr "X")) ) (T # (for ((I . L) (1 2 ..) ..) ..) (lintVar (caar "Y")) (lint1 (cadr "Y")) (lintVar (cdar "Y")) (mapc lint1 (cddr "Y")) (lintLoop (cddr "X")) ) ) ) ) ) ((case casq state) (lint1 (cadr "X")) (for "X" (cddr "X") (mapc lint1 (cdr "X")) ) ) ((cond nond) (for "X" (cdr "X") (mapc lint1 "X") ) ) (loop (lintLoop (cdr "X")) ) (do (lint1 (cadr "X")) (lintLoop (cddr "X")) ) (=: (lint1 (last (cddr "X"))) ) ((dec inc pop push push1 queue fifo val idx accu) (_lintq '(T)) ) ((cut port) (_lintq '(NIL T)) ) (set (_lintq '(T NIL .)) ) (xchg (_lintq '(T T .)) ) (T (cond ((pair (car "X")) (lint1 @) (mapc lint2 (cdr "X")) ) ((memq (car "X") "*L") (setq "*Use" (delq (car "X") "*Use")) (mapc lint2 (cdr "X")) ) ((fun? (val (car "X"))) (if (num? @) (mapc lint1 (cdr "X")) (when (local? (car "X")) (lint2 (val (car "X"))) ) (let "Y" (car (getd (pop '"X"))) (while (and (pair "X") (pair "Y")) (lint1 (pop '"X")) (pop '"Y") ) (if (or (== '@ "Y") (= "Prg" "Y") (= "*Prg" "Y")) (mapc lint1 "X") (lint2 "X") ) ) ) ) (T (or (str? (car "X")) (dlsym? (car "X")) (== '@ (car "X")) (memq (car "X") *NoLint) (memq (car "X") "*Def") (push '"*Def" (car "X")) ) (mapc lint1 (cdr "X")) ) ) ) ) ) ) ) (de lint2 (X Mark) (cond ((memq X Mark)) ((atom X) (and (memq X "*L") (setq "*Use" (delq X "*Use"))) ) (T (lint2 (car X)) (lint2 (cdr X) (cons X Mark)) ) ) ) (de lintVar (X Flg) (cond ((or (not (sym? X)) (memq X '(NIL *DB *Solo ^ meth quote T))) (push '"*Var" X) ) ((not (global? X)) (or Flg (member (cons "*X" X) *NoLint) (memq X "*Use") (push '"*Use" X) ) (push '"*L" X) ) ) ) (de lintDup (X Lst) (and (memq X Lst) (not (member (cons "*X" X) *NoLint)) (push '"*Dup" X) ) ) (de lintLoop ("Lst") (for "Y" "Lst" (if (and (pair "Y") (or (=T (car "Y")) (not (car "Y")))) (mapc lint1 (cdr "Y")) (lint1 "Y") ) ) ) (de _lintq (Lst) (mapc '((X Flg) (lint1 (if Flg (strip X) X)) ) (cdr "X") Lst ) ) (de lintFun ("Lst") (let "A" (and (pair "Lst") (car "Lst")) (while (pair "A") (lintDup (car "A") (cdr "A")) (lintVar (pop '"A") T) ) (when "A" (lintVar "A") ) (mapc lint1 (cdr "Lst")) ) ) (de lint ("X" "C") (let ("*L" NIL "*Var" NIL "*Dup" NIL "*Def" NIL "*Bnd" NIL "*Use" NIL) (when (pair "X") (setq "C" (cdr "X") "X" (car "X")) ) (cond ("C" # Method (let "*X" (cons "X" "C") (lintFun (method "X" "C")) ) ) ((pair (val "X")) # Function (let "*X" "X" (lintFun (val "X")) ) ) ((info "X") # File name (let "*X" "X" (in "X" (while (read) (lint1 @))) ) ) (T (quit "Can't lint" "X")) ) (when (or "*Var" "*Dup" "*Def" "*Bnd" "*Use") (make # Bad variables (and "*Var" (link (cons 'var "*Var"))) # Duplicate parameters (and "*Dup" (link (cons 'dup "*Dup"))) # Undefined functions (and "*Def" (link (cons 'def "*Def"))) # Unbound variables (and "*Bnd" (<> `(char '_) (char "X")) (link (cons 'bnd "*Bnd"))) # Unused variables (and "*Use" (link (cons 'use "*Use"))) ) ) ) ) (de lintAll @ (let *Dbg NIL (make (for "X" (all) (cond ((= `(char "+") (char "X")) (for "Y" (val "X") (and (pair "Y") (fun? (cdr "Y")) (lint (car "Y") "X") (link (cons (cons (car "Y") "X") @)) ) ) ) ((and (not (global? "X")) (pair (getd "X")) (lint "X")) (link (cons "X" @)) ) ) ) (while (args) (and (lint (next)) (link (cons (arg) @))) ) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/lib/map0000644000000000000000000002451112265263724014421 0ustar rootroot! (2963 . "@src64/flow.l") $ (3065 . "@src64/flow.l") % (2572 . "@src64/big.l") & (2807 . "@src64/big.l") * (2389 . "@src64/big.l") */ (2446 . "@src64/big.l") + (2171 . "@src64/big.l") - (2209 . "@src64/big.l") -> (3909 . "@src64/subr.l") / (2513 . "@src64/big.l") : (3095 . "@src64/sym.l") :: (3119 . "@src64/sym.l") ; (3012 . "@src64/sym.l") < (2208 . "@src64/subr.l") <= (2238 . "@src64/subr.l") <> (2145 . "@src64/subr.l") = (2116 . "@src64/subr.l") =0 (2174 . "@src64/subr.l") =: (3041 . "@src64/sym.l") == (2060 . "@src64/subr.l") ==== (1099 . "@src64/sym.l") =T (2182 . "@src64/subr.l") > (2268 . "@src64/subr.l") >= (2298 . "@src64/subr.l") >> (2627 . "@src64/big.l") abs (2731 . "@src64/big.l") accept (148 . "@src64/net.l") adr (597 . "@src64/main.l") alarm (477 . "@src64/main.l") all (788 . "@src64/sym.l") and (1626 . "@src64/flow.l") any (4015 . "@src64/io.l") append (1339 . "@src64/subr.l") apply (713 . "@src64/apply.l") arg (2614 . "@src64/main.l") args (2590 . "@src64/main.l") argv (3251 . "@src64/main.l") as (139 . "@src64/flow.l") asoq (3021 . "@src64/subr.l") assoc (2986 . "@src64/subr.l") at (2151 . "@src64/flow.l") atom (2386 . "@src64/subr.l") bind (1364 . "@src64/flow.l") bit? (2748 . "@src64/big.l") bool (1726 . "@src64/flow.l") box (830 . "@src64/flow.l") box? (1131 . "@src64/sym.l") by (1669 . "@src64/apply.l") bye (3513 . "@src64/flow.l") bytes (2973 . "@src64/subr.l") caaaar (271 . "@src64/subr.l") caaadr (288 . "@src64/subr.l") caaar (99 . "@src64/subr.l") caadar (311 . "@src64/subr.l") caaddr (334 . "@src64/subr.l") caadr (116 . "@src64/subr.l") caar (31 . "@src64/subr.l") cadaar (360 . "@src64/subr.l") cadadr (383 . "@src64/subr.l") cadar (136 . "@src64/subr.l") caddar (409 . "@src64/subr.l") cadddr (435 . "@src64/subr.l") caddr (156 . "@src64/subr.l") cadr (45 . "@src64/subr.l") call (3165 . "@src64/flow.l") car (5 . "@src64/subr.l") case (1967 . "@src64/flow.l") casq (2011 . "@src64/flow.l") catch (2509 . "@src64/flow.l") cd (2994 . "@src64/main.l") cdaaar (464 . "@src64/subr.l") cdaadr (487 . "@src64/subr.l") cdaar (179 . "@src64/subr.l") cdadar (513 . "@src64/subr.l") cdaddr (539 . "@src64/subr.l") cdadr (199 . "@src64/subr.l") cdar (62 . "@src64/subr.l") cddaar (568 . "@src64/subr.l") cddadr (594 . "@src64/subr.l") cddar (222 . "@src64/subr.l") cdddar (623 . "@src64/subr.l") cddddr (652 . "@src64/subr.l") cdddr (245 . "@src64/subr.l") cddr (79 . "@src64/subr.l") cdr (17 . "@src64/subr.l") chain (1142 . "@src64/subr.l") char (3497 . "@src64/io.l") chop (1228 . "@src64/sym.l") circ (817 . "@src64/subr.l") circ? (2403 . "@src64/subr.l") clip (1800 . "@src64/subr.l") close (4442 . "@src64/io.l") cmd (3233 . "@src64/main.l") cnt (1413 . "@src64/apply.l") co (2590 . "@src64/flow.l") commit (1403 . "@src64/db.l") con (725 . "@src64/subr.l") conc (781 . "@src64/subr.l") cond (1921 . "@src64/flow.l") connect (227 . "@src64/net.l") cons (747 . "@src64/subr.l") copy (1226 . "@src64/subr.l") ctl (4315 . "@src64/io.l") ctty (3019 . "@src64/main.l") cut (1958 . "@src64/sym.l") date (2728 . "@src64/main.l") dbck (2020 . "@src64/db.l") de (534 . "@src64/flow.l") dec (2323 . "@src64/big.l") def (448 . "@src64/flow.l") default (1822 . "@src64/sym.l") del (2013 . "@src64/sym.l") delete (1402 . "@src64/subr.l") delq (1453 . "@src64/subr.l") diff (2590 . "@src64/subr.l") dir (3163 . "@src64/main.l") dm (547 . "@src64/flow.l") do (2183 . "@src64/flow.l") e (3026 . "@src64/flow.l") echo (4473 . "@src64/io.l") env (609 . "@src64/main.l") eof (3574 . "@src64/io.l") eol (3565 . "@src64/io.l") err (4295 . "@src64/io.l") errno (1614 . "@src64/main.l") eval (175 . "@src64/flow.l") ext (5213 . "@src64/io.l") ext? (1166 . "@src64/sym.l") extern (1032 . "@src64/sym.l") extra (1271 . "@src64/flow.l") extract (1218 . "@src64/apply.l") fifo (2123 . "@src64/sym.l") file (3110 . "@src64/main.l") fill (3256 . "@src64/subr.l") filter (1161 . "@src64/apply.l") fin (2034 . "@src64/subr.l") finally (2566 . "@src64/flow.l") find (1322 . "@src64/apply.l") fish (1613 . "@src64/apply.l") flg? (2446 . "@src64/subr.l") flip (1700 . "@src64/subr.l") flush (5188 . "@src64/io.l") fold (3561 . "@src64/sym.l") for (2272 . "@src64/flow.l") fork (3339 . "@src64/flow.l") format (2089 . "@src64/big.l") free (1962 . "@src64/db.l") from (3593 . "@src64/io.l") full (1076 . "@src64/subr.l") fun? (750 . "@src64/sym.l") gc (450 . "@src64/gc.l") ge0 (2707 . "@src64/big.l") get (2931 . "@src64/sym.l") getd (758 . "@src64/sym.l") getl (3244 . "@src64/sym.l") glue (1369 . "@src64/sym.l") gt0 (2718 . "@src64/big.l") hash (3107 . "@src64/big.l") head (1821 . "@src64/subr.l") heap (523 . "@src64/main.l") hear (3278 . "@src64/io.l") host (193 . "@src64/net.l") id (1028 . "@src64/db.l") idx (2197 . "@src64/sym.l") if (1807 . "@src64/flow.l") if2 (1826 . "@src64/flow.l") ifn (1867 . "@src64/flow.l") in (4255 . "@src64/io.l") inc (2256 . "@src64/big.l") index (2638 . "@src64/subr.l") info (3056 . "@src64/main.l") intern (1007 . "@src64/sym.l") ipid (3284 . "@src64/flow.l") isa (969 . "@src64/flow.l") job (1431 . "@src64/flow.l") journal (971 . "@src64/db.l") key (3426 . "@src64/io.l") kill (3316 . "@src64/flow.l") last (2045 . "@src64/subr.l") le0 (2693 . "@src64/big.l") length (2742 . "@src64/subr.l") let (1481 . "@src64/flow.l") let? (1542 . "@src64/flow.l") lieu (1157 . "@src64/db.l") line (3749 . "@src64/io.l") lines (3902 . "@src64/io.l") link (1173 . "@src64/subr.l") lisp (2283 . "@src64/main.l") list (888 . "@src64/subr.l") listen (160 . "@src64/net.l") lit (150 . "@src64/flow.l") load (4232 . "@src64/io.l") lock (1185 . "@src64/db.l") loop (2215 . "@src64/flow.l") low? (3427 . "@src64/sym.l") lowc (3457 . "@src64/sym.l") lst? (2416 . "@src64/subr.l") lt0 (2682 . "@src64/big.l") lup (2386 . "@src64/sym.l") made (1108 . "@src64/subr.l") make (1089 . "@src64/subr.l") map (849 . "@src64/apply.l") mapc (891 . "@src64/apply.l") mapcan (1101 . "@src64/apply.l") mapcar (987 . "@src64/apply.l") mapcon (1041 . "@src64/apply.l") maplist (933 . "@src64/apply.l") maps (790 . "@src64/apply.l") mark (1880 . "@src64/db.l") match (3141 . "@src64/subr.l") max (2328 . "@src64/subr.l") maxi (1511 . "@src64/apply.l") member (2456 . "@src64/subr.l") memq (2478 . "@src64/subr.l") meta (3347 . "@src64/sym.l") meth (1097 . "@src64/flow.l") method (1061 . "@src64/flow.l") min (2357 . "@src64/subr.l") mini (1562 . "@src64/apply.l") mix (1261 . "@src64/subr.l") mmeq (2506 . "@src64/subr.l") n0 (2190 . "@src64/subr.l") n== (2088 . "@src64/subr.l") nT (2199 . "@src64/subr.l") name (502 . "@src64/sym.l") nand (1661 . "@src64/flow.l") native (1622 . "@src64/main.l") need (920 . "@src64/subr.l") new (841 . "@src64/flow.l") next (2597 . "@src64/main.l") nil (1744 . "@src64/flow.l") nond (1944 . "@src64/flow.l") nor (1682 . "@src64/flow.l") not (1734 . "@src64/flow.l") nth (685 . "@src64/subr.l") num? (2427 . "@src64/subr.l") off (1759 . "@src64/sym.l") offset (2678 . "@src64/subr.l") on (1744 . "@src64/sym.l") onOff (1774 . "@src64/sym.l") one (1807 . "@src64/sym.l") open (4399 . "@src64/io.l") opid (3300 . "@src64/flow.l") opt (3354 . "@src64/main.l") or (1642 . "@src64/flow.l") out (4275 . "@src64/io.l") pack (1279 . "@src64/sym.l") pair (2395 . "@src64/subr.l") pass (754 . "@src64/apply.l") pat? (736 . "@src64/sym.l") path (1288 . "@src64/io.l") peek (3481 . "@src64/io.l") pick (1369 . "@src64/apply.l") pipe (4336 . "@src64/io.l") poll (3370 . "@src64/io.l") pool (651 . "@src64/db.l") pop (1934 . "@src64/sym.l") port (5 . "@src64/net.l") pr (5299 . "@src64/io.l") pre? (1545 . "@src64/sym.l") prin (5112 . "@src64/io.l") prinl (5126 . "@src64/io.l") print (5152 . "@src64/io.l") println (5183 . "@src64/io.l") printsp (5168 . "@src64/io.l") prior (2714 . "@src64/subr.l") prog (1762 . "@src64/flow.l") prog1 (1770 . "@src64/flow.l") prog2 (1787 . "@src64/flow.l") prop (2962 . "@src64/sym.l") protect (513 . "@src64/main.l") prove (3543 . "@src64/subr.l") push (1849 . "@src64/sym.l") push1 (1885 . "@src64/sym.l") put (2870 . "@src64/sym.l") putl (3162 . "@src64/sym.l") pwd (2983 . "@src64/main.l") queue (2081 . "@src64/sym.l") quit (1324 . "@src64/main.l") quote (134 . "@src64/flow.l") rand (3134 . "@src64/big.l") range (998 . "@src64/subr.l") rank (3049 . "@src64/subr.l") raw (455 . "@src64/main.l") rd (5230 . "@src64/io.l") read (2688 . "@src64/io.l") replace (1500 . "@src64/subr.l") rest (2643 . "@src64/main.l") reverse (1679 . "@src64/subr.l") rewind (5196 . "@src64/io.l") rollback (1803 . "@src64/db.l") rot (849 . "@src64/subr.l") run (306 . "@src64/flow.l") sect (2542 . "@src64/subr.l") seed (3092 . "@src64/big.l") seek (1275 . "@src64/apply.l") send (1136 . "@src64/flow.l") seq (1084 . "@src64/db.l") set (1616 . "@src64/sym.l") setq (1649 . "@src64/sym.l") sigio (493 . "@src64/main.l") size (2809 . "@src64/subr.l") skip (3551 . "@src64/io.l") sort (3958 . "@src64/subr.l") sp? (727 . "@src64/sym.l") space (5130 . "@src64/io.l") split (1593 . "@src64/subr.l") sqrt (2927 . "@src64/big.l") stack (552 . "@src64/main.l") state (2051 . "@src64/flow.l") stem (1990 . "@src64/subr.l") str (4069 . "@src64/io.l") str? (1145 . "@src64/sym.l") strip (1577 . "@src64/subr.l") struct (2074 . "@src64/main.l") sub? (1578 . "@src64/sym.l") sum (1460 . "@src64/apply.l") super (1227 . "@src64/flow.l") swap (1672 . "@src64/sym.l") sym (4055 . "@src64/io.l") sym? (2435 . "@src64/subr.l") symbols (942 . "@src64/sym.l") sync (3238 . "@src64/io.l") sys (856 . "@src64/main.l") t (1753 . "@src64/flow.l") tail (1912 . "@src64/subr.l") tell (3310 . "@src64/io.l") text (1407 . "@src64/sym.l") throw (2535 . "@src64/flow.l") tick (3252 . "@src64/flow.l") till (3660 . "@src64/io.l") time (2861 . "@src64/main.l") touch (1181 . "@src64/sym.l") trail (708 . "@src64/main.l") trim (1760 . "@src64/subr.l") try (1179 . "@src64/flow.l") type (922 . "@src64/flow.l") udp (304 . "@src64/net.l") unify (3931 . "@src64/subr.l") unless (1903 . "@src64/flow.l") until (2127 . "@src64/flow.l") up (776 . "@src64/main.l") upp? (3442 . "@src64/sym.l") uppc (3509 . "@src64/sym.l") use (1575 . "@src64/flow.l") usec (2965 . "@src64/main.l") val (1597 . "@src64/sym.l") version (3368 . "@src64/main.l") wait (3200 . "@src64/io.l") when (1886 . "@src64/flow.l") while (2103 . "@src64/flow.l") wipe (3302 . "@src64/sym.l") with (1334 . "@src64/flow.l") wr (5316 . "@src64/io.l") xchg (1699 . "@src64/sym.l") xor (1703 . "@src64/flow.l") x| (2887 . "@src64/big.l") yield (2795 . "@src64/flow.l") yoke (1197 . "@src64/subr.l") zap (1195 . "@src64/sym.l") zero (1792 . "@src64/sym.l") | (2847 . "@src64/big.l") picolisp-3.1.5.2.orig/COPYING0000644000000000000000000000206612265263724014207 0ustar rootrootPicoLisp Copyright (c) Software Lab. Alexander Burger Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. picolisp-3.1.5.2.orig/CREDITS0000644000000000000000000000164712265263724014200 0ustar rootroot# The PicoLisp system is originally written and maintained by Alexander Burger # For many years, ideas and application concepts were contributed by Josef Bartl # Build procedure for Mac OS X (Darwin) Rick Hanson # Port to Cygwin/Win32 Doug Snead # Documentation, CSS styles, Mac OS support, OpenGL library, Norwegian localization Jon Kleiser # Russian localization, FreeBSD port Mansur Mamkin # XML parser (and other) improvements Tomas Hlavaty # Spanish localization and emacs picolisp-mode Armadillo # Documentation Christophe Gragnic # Port of 64-bit version to SunOS Nikolai Zobnin # Package maintenance Kan-Ru Chen # Emacs-style editing Thorsten Jolitz picolisp-3.1.5.2.orig/src/0000755000000000000000000000000012265263724013737 5ustar rootrootpicolisp-3.1.5.2.orig/src/balance.c0000644000000000000000000000401012265263724015463 0ustar rootroot/* balance.c * 06jul05abu */ #include #include #include #include #include #include #include int Len, Siz; char *Line, **Data; static void giveup(char *msg) { fprintf(stderr, "balance: %s\n", msg); exit(1); } static char *getLine(FILE *fp) { int i, c; char *s; i = 0; while ((c = getc_unlocked(fp)) != '\n') { if (c == EOF) return NULL; Line[i] = c; if (++i == Len && !(Line = realloc(Line, Len *= 2))) giveup("No memory"); } Line[i] = '\0'; if (!(s = strdup(Line))) giveup("No memory"); return s; } static void balance(char **data, int len) { if (len) { int n = (len + 1) / 2; char **p = data + n - 1; printf("%s\n", *p); balance(data, n - 1); balance(p + 1, len - n); } } // balance [- [ ..]] // balance [] int main(int ac, char *av[]) { int cnt; char *s; pid_t pid = 0; FILE *fp = stdin; if (ac > 1) { if (*av[1] == '-') { int pfd[2]; if (pipe(pfd) < 0) giveup("Pipe error\n"); if ((pid = fork()) == 0) { close(pfd[0]); if (pfd[1] != STDOUT_FILENO) dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); execvp(av[1]+1, av+1); } if (pid < 0) giveup("Fork error\n"); close(pfd[1]); if (!(fp = fdopen(pfd[0], "r"))) giveup("Pipe open error\n"); } else if (!(fp = fopen(av[1], "r"))) giveup("File open error\n"); } Line = malloc(Len = 4096); Data = malloc((Siz = 4096) * sizeof(char*)); for (cnt = 0; s = getLine(fp); ++cnt) { if (cnt == Siz && !(Data = realloc(Data, (Siz *= 2) * sizeof(char*)))) giveup("No memory"); Data[cnt] = s; } if (pid) { fclose(fp); while (waitpid(pid, NULL, 0) < 0) if (errno != EINTR) giveup("Pipe close error\n"); } balance(Data, cnt); return 0; } picolisp-3.1.5.2.orig/src/big.c0000644000000000000000000006740012265263724014653 0ustar rootroot/* 20aug13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" #define MAX MASK // Max digit size 0xFFFF.... #define OVFL ((1< num(setDig(dst, (unDig(src) & ~1) + (unDig(dst) & ~1))); src = cdr(numCell(src)); dst = cdr(numCell(x = dst)); for (;;) { if (!isNum(src)) { while (isNum(dst)) { if (!carry) return; carry = 0 == num(setDig(dst, 1 + unDig(dst))); dst = cdr(numCell(x = dst)); } break; } if (!isNum(dst)) { do { carry = unDig(src) > (n = carry + unDig(src)); x = cdr(numCell(x)) = box(n); } while (isNum(src = cdr(numCell(src)))); break; } if ((n = carry + unDig(src)) >= carry) { carry = unDig(dst) > (n += unDig(dst)); setDig(dst,n); } src = cdr(numCell(src)); dst = cdr(numCell(x = dst)); } if (carry) cdr(numCell(x)) = box(1); } /* Add digit to a (positive) bignum */ void digAdd(any x, word n) { any y; word carry; carry = n > num(setDig(x, n + unDig(x))); while (carry) { if (isNum(x = cdr(numCell(y = x)))) carry = 0 == num(setDig(x, 1 + unDig(x))); else { cdr(numCell(y)) = box(1); break; } } } /* Subtract two (positive) bignums */ void bigSub(any dst, any src) { any x, y; word n, borrow; borrow = MAX - (unDig(src) & ~1) < num(setDig(dst, (unDig(dst) & ~1) - (unDig(src) & ~1))); y = dst; for (;;) { src = cdr(numCell(src)); dst = cdr(numCell(x = dst)); if (!isNum(src)) { while (isNum(dst)) { if (!borrow) return; borrow = MAX == num(setDig(dst, unDig(dst) - 1)); dst = cdr(numCell(x = dst)); } break; } if (!isNum(dst)) { do { if (borrow) n = MAX - unDig(src); else borrow = 0 != (n = -unDig(src)); x = cdr(numCell(x)) = box(n); } while (isNum(src = cdr(numCell(src)))); break; } if ((n = unDig(dst) - borrow) > MAX - borrow) setDig(dst, MAX - unDig(src)); else borrow = num(setDig(dst, n - unDig(src))) > MAX - unDig(src); } if (borrow) { dst = y; borrow = 0 != (n = -unDig(dst)); setDig(dst, n | 1); /* Negate */ while (dst != x) { dst = cdr(numCell(dst)); if (borrow) setDig(dst, MAX - unDig(dst)); else borrow = 0 != num(setDig(dst, -unDig(dst))); } } if (unDig(x) == 0) zapZero(y); } /* Subtract 1 from a (positive) bignum */ void digSub1(any x) { any r, y; word borrow; r = NULL; borrow = MAX-1 == num(setDig(x, unDig(x) - 2)); while (isNum(x = cdr(numCell(y = x)))) { if (!borrow) return; borrow = MAX == num(setDig(x, unDig(x) - 1)); r = y; } if (r && unDig(y) == 0) cdr(numCell(r)) = x; } /* Multiply two (positive) bignums */ static any bigMul(any x1, any x2) { any x, y, z; word n, carry; word2 t; cell c1; Push(c1, x = y = box(0)); for (;;) { n = unDig(x2) / 2; if (isNum(x2 = cdr(numCell(x2))) && unDig(x2) & 1) n |= OVFL; t = (word2)n * unDig(z = x1); // x += n * x1 carry = (lo(t) > num(setDig(y, unDig(y) + lo(t)))) + hi(t); while (isNum(z = cdr(numCell(z)))) { if (!isNum(cdr(numCell(y)))) cdr(numCell(y)) = box(0); y = cdr(numCell(y)); t = (word2)n * unDig(z); carry = carry > num(setDig(y, carry + unDig(y))); if (lo(t) > num(setDig(y, unDig(y) + lo(t)))) ++carry; carry += hi(t); } if (carry) cdr(numCell(y)) = box(carry); if (!isNum(x2)) break; if (!isNum(y = cdr(numCell(x)))) y = cdr(numCell(x)) = box(0); x = y; } while (isNum(x2)); zapZero(data(c1)); return Pop(c1); } /* Multiply digit with a (positive) bignum */ void digMul(any x, word n) { word2 t; any y; t = (word2)n * unDig(x); for (;;) { setDig(x, num(t)); t = hi(t); if (!isNum(x = cdr(numCell(y = x)))) break; t += (word2)n * unDig(x); } if (t) cdr(numCell(y)) = box(num(t)); } /* (Positive) Bignum comparison */ static int bigCmp(any x, any y) { int res; any x1, y1, x2, y2; x1 = y1 = Nil; for (;;) { if ((x2 = cdr(numCell(x))) == (y2 = cdr(numCell(y)))) { for (;;) { if (unDig(x) < unDig(y)) { res = -1; break; } if (unDig(x) > unDig(y)) { res = +1; break; } if (!isNum(x1)) return 0; x2 = cdr(numCell(x1)), cdr(numCell(x1)) = x, x = x1, x1 = x2; y2 = cdr(numCell(y1)), cdr(numCell(y1)) = y, y = y1, y1 = y2; } break; } if (!isNum(x2)) { res = -1; break; } if (!isNum(y2)) { res = +1; break; } cdr(numCell(x)) = x1, x1 = x, x = x2; cdr(numCell(y)) = y1, y1 = y, y = y2; } while (isNum(x1)) { x2 = cdr(numCell(x1)), cdr(numCell(x1)) = x, x = x1, x1 = x2; y2 = cdr(numCell(y1)), cdr(numCell(y1)) = y, y = y1, y1 = y2; } return res; } /* Divide two (positive) bignums (Knuth Vol.2, p.257) */ static any bigDiv(any u, any v, bool rem) { int m, n, d, i; word q, v1, v2, u1, u2, u3, borrow; word2 t, r; any x, y, z; cell c1; digDiv2(u), digDiv2(v); // Normalize for (m = 0, z = u; isNum(y = cdr(numCell(z))); ++m, z = y); x = v, y = NULL, n = 1; while (isNum(cdr(numCell(x)))) y = x, x = cdr(numCell(x)), ++n, --m; if (m < 0) { if (rem) digMul2(u); return box(0); } cdr(numCell(z)) = box(0); for (d = 0; (unDig(x) & OVFL) == 0; ++d) digMul2(u), digMul2(v); v1 = unDig(x); v2 = y? unDig(y) : 0; Push(c1, Nil); do { for (i = m, x = u; --i >= 0; x = cdr(numCell(x))); // Index x -> u i = n; y = x; u1 = u2 = 0; do u3 = u2, u2 = u1, u1 = unDig(y), y = cdr(numCell(y)); while (--i >= 0); t = ((word2)u1 << BITS) + u2; // Calculate q q = u1 == v1? MAX : t / v1; r = t - (word2)q*v1; while (r <= MAX && (word2)q*v2 > (r << BITS) + u3) --q, r += v1; z = x; // x -= q*v t = (word2)q * unDig(y = v); borrow = (MAX - lo(t) < num(setDig(z, unDig(z) - lo(t)))) + hi(t); while (isNum(y = cdr(numCell(y)))) { z = cdr(numCell(z)); t = (word2)q * unDig(y); borrow = MAX - borrow < num(setDig(z, unDig(z) - borrow)); if (MAX - lo(t) < num(setDig(z, unDig(z) - lo(t)))) ++borrow; borrow += hi(t); } if (borrow) { z = cdr(numCell(z)); if (MAX - borrow < num(setDig(z, unDig(z) - borrow))) { word n, carry; // x += v --q; if (m || rem) { y = v; carry = unDig(y) > num(setDig(x, unDig(y) + unDig(x))); while (x = cdr(numCell(x)), isNum(y = cdr(numCell(y)))) { if ((n = carry + unDig(y)) >= carry) { carry = unDig(x) > (n += unDig(x)); setDig(x,n); } } setDig(x, carry + unDig(x)); } } } data(c1) = consNum(q, data(c1)); // Store result } while (--m >= 0); if (!rem) zapZero(data(c1)), digMul2(data(c1)); else { zapZero(u); if (!d) digMul2(u); else while (--d) digDiv2(u); } return Pop(c1); } /* Compare two numbers */ int bigCompare(any x, any y) { if (isNeg(x)) { if (!isNeg(y)) return -1; return bigCmp(y,x); } if (isNeg(y)) return +1; return bigCmp(x,y); } /* Make number from symbol */ any symToNum(any s, int scl, int sep, int ign) { unsigned c; bool sign, frac; cell c1, c2; if (!(c = symByte(s))) return NULL; while (c <= ' ') /* Skip white space */ if (!(c = symByte(NULL))) return NULL; sign = NO; if (c == '+' || c == '-' && (sign = YES)) if (!(c = symByte(NULL))) return NULL; if ((c -= '0') > 9) return NULL; frac = NO; Push(c1, s); Push(c2, box(c+c)); while ((c = symChar(NULL)) && (!frac || scl)) { if ((int)c == sep) { if (frac) { drop(c1); return NULL; } frac = YES; } else if ((int)c != ign) { if ((c -= '0') > 9) { drop(c1); return NULL; } digMul(data(c2), 10); digAdd(data(c2), c+c); if (frac) --scl; } } if (c) { if ((c -= '0') > 9) { drop(c1); return NULL; } if (c >= 5) digAdd(data(c2), 2); while (c = symByte(NULL)) { if ((c -= '0') > 9) { drop(c1); return NULL; } } } if (frac) while (--scl >= 0) digMul(data(c2), 10); if (sign && !IsZero(data(c2))) neg(data(c2)); drop(c1); return data(c2); } /* Buffer size calculation */ static inline int numlen(any x) { int n = 10; while (isNum(x = cdr(numCell(x)))) n += 10; return (n + 8) / 9; } /* Make symbol from number */ any numToSym(any x, int scl, int sep, int ign) { int i; bool sign; cell c1; word n = numlen(x); word c, *p, *q, *ta, *ti, acc[n], inc[n]; char *b, buf[10]; sign = isNeg(x); *(ta = acc) = 0; *(ti = inc) = 1; n = 2; for (;;) { do { if (unDig(x) & n) { c = 0, p = acc, q = inc; do { if (ta < p) *++ta = 0; if (c = (*p += *q + c) > 999999999) *p -= 1000000000; } while (++p, ++q <= ti); if (c) *p = 1, ++ta; } c = 0, q = inc; do if (c = (*q += *q + c) > 999999999) *q -= 1000000000; while (++q <= ti); if (c) *q = 1, ++ti; } while (n <<= 1); if (!isNum(x = cdr(numCell(x)))) break; n = 1; } n = (ta - acc) * 9; n += sprintf(b = buf, "%ld", *ta--); if (sep < 0) return boxCnt(n + sign); i = -8, Push(c1, x = box(0)); if (sign) byteSym('-', &i, &x); if ((scl = n - scl - 1) < 0) { byteSym('0', &i, &x); charSym(sep, &i, &x); while (scl < -1) byteSym('0', &i, &x), ++scl; } for (;;) { byteSym(*b++, &i, &x); if (!*b) { if (ta < acc) return consStr(Pop(c1)); sprintf(b = buf, "%09ld", *ta--); } if (scl == 0) charSym(sep, &i, &x); else if (ign && scl > 0 && scl % 3 == 0) charSym(ign, &i, &x); --scl; } } #define DMAX ((double)((word2)MASK+1)) /* Make number from double */ any doubleToNum(double d) { bool sign; any x; cell c1; if (isnan(d) || isinf(d) < 0) return Nil; if (isinf(d) > 0) return T; sign = NO; if (d < 0.0) sign = YES, d = -d; d += 0.5; Push(c1, x = box((word)fmod(d,DMAX))); while (d > DMAX) x = cdr(numCell(x)) = box((word)fmod(d /= DMAX, DMAX)); digMul2(data(c1)); if (sign && !IsZero(data(c1))) neg(data(c1)); return Pop(c1); } /* Make double from number */ double numToDouble(any x) { double d, m; bool sign; sign = isNeg(x); d = (double)(unDig(x) / 2), m = DMAX/2.0; while (isNum(x = cdr(numCell(x)))) d += m * (double)unDig(x), m *= DMAX; return sign? -d : d; } // (format 'num ['cnt ['sym1 ['sym2]]]) -> sym // (format 'sym|lst ['cnt ['sym1 ['sym2]]]) -> num any doFormat(any ex) { int scl, sep, ign; any x, y; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); x = cdr(x), y = EVAL(car(x)); scl = isNil(y)? 0 : xCnt(ex, y); sep = '.'; ign = 0; if (isCell(x = cdr(x))) { y = EVAL(car(x)); NeedSym(ex,y); sep = symChar(name(y)); if (isCell(x = cdr(x))) { y = EVAL(car(x)); NeedSym(ex,y); ign = symChar(name(y)); } } if (isNum(data(c1))) data(c1) = numToSym(data(c1), scl, sep, ign); else { int i; any nm; cell c2; if (isSym(data(c1))) nm = name(data(c1)); else { nm = NULL, pack(data(c1), &i, &nm, &c2); nm = nm? data(c2) : Nil; } data(c1) = symToNum(nm, scl, sep, ign) ?: Nil; } return Pop(c1); } // (+ 'num ..) -> num any doAdd(any ex) { any x; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); while (isCell(x = cdr(x))) { Push(c2, EVAL(car(x))); if (isNil(data(c2))) { drop(c1); return Nil; } NeedNum(ex,data(c2)); if (isNeg(data(c1))) { if (isNeg(data(c2))) bigAdd(data(c1),data(c2)); else bigSub(data(c1),data(c2)); if (!IsZero(data(c1))) neg(data(c1)); } else if (isNeg(data(c2))) bigSub(data(c1),data(c2)); else bigAdd(data(c1),data(c2)); drop(c2); } return Pop(c1); } // (- 'num ..) -> num any doSub(any ex) { any x; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); if (!isCell(x = cdr(x))) return IsZero(data(c1))? data(c1) : consNum(unDig(data(c1)) ^ 1, cdr(numCell(data(c1)))); Push(c1, bigCopy(data(c1))); do { Push(c2, EVAL(car(x))); if (isNil(data(c2))) { drop(c1); return Nil; } NeedNum(ex,data(c2)); if (isNeg(data(c1))) { if (isNeg(data(c2))) bigSub(data(c1),data(c2)); else bigAdd(data(c1),data(c2)); if (!IsZero(data(c1))) neg(data(c1)); } else if (isNeg(data(c2))) bigAdd(data(c1),data(c2)); else bigSub(data(c1),data(c2)); drop(c2); } while (isCell(x = cdr(x))); return Pop(c1); } // (inc 'num) -> num // (inc 'var ['num]) -> num any doInc(any ex) { any x; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; if (isNum(data(c1))) { Push(c1, bigCopy(data(c1))); if (!isNeg(data(c1))) digAdd(data(c1), 2); else { pos(data(c1)), digSub1(data(c1)), neg(data(c1)); if (unDig(data(c1)) == 1 && !isNum(cdr(numCell(data(c1))))) setDig(data(c1), 0); } return Pop(c1); } CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); if (!isCell(x = cdr(x))) { if (isNil(val(data(c1)))) return Nil; NeedNum(ex,val(data(c1))); Save(c1); val(data(c1)) = bigCopy(val(data(c1))); if (!isNeg(val(data(c1)))) digAdd(val(data(c1)), 2); else { pos(val(data(c1))), digSub1(val(data(c1))), neg(val(data(c1))); if (unDig(val(data(c1))) == 1 && !isNum(cdr(numCell(val(data(c1)))))) setDig(val(data(c1)), 0); } } else { Save(c1); Push(c2, EVAL(car(x))); if (isNil(val(data(c1))) || isNil(data(c2))) { drop(c1); return Nil; } NeedNum(ex,val(data(c1))); val(data(c1)) = bigCopy(val(data(c1))); NeedNum(ex,data(c2)); if (isNeg(val(data(c1)))) { if (isNeg(data(c2))) bigAdd(val(data(c1)),data(c2)); else bigSub(val(data(c1)),data(c2)); if (!IsZero(val(data(c1)))) neg(val(data(c1))); } else if (isNeg(data(c2))) bigSub(val(data(c1)),data(c2)); else bigAdd(val(data(c1)),data(c2)); } return val(Pop(c1)); } // (dec 'num) -> num // (dec 'var ['num]) -> num any doDec(any ex) { any x; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; if (isNum(data(c1))) { Push(c1, bigCopy(data(c1))); if (isNeg(data(c1))) digAdd(data(c1), 2); else if (IsZero(data(c1))) setDig(data(c1), 3); else digSub1(data(c1)); return Pop(c1); } CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); if (!isCell(x = cdr(x))) { if (isNil(val(data(c1)))) return Nil; NeedNum(ex,val(data(c1))); Save(c1); val(data(c1)) = bigCopy(val(data(c1))); if (isNeg(val(data(c1)))) digAdd(val(data(c1)), 2); else if (IsZero(val(data(c1)))) setDig(val(data(c1)), 3); else digSub1(val(data(c1))); } else { Save(c1); Push(c2, EVAL(car(x))); if (isNil(val(data(c1))) || isNil(data(c2))) { drop(c1); return Nil; } NeedNum(ex,val(data(c1))); val(data(c1)) = bigCopy(val(data(c1))); NeedNum(ex,data(c2)); if (isNeg(val(data(c1)))) { if (isNeg(data(c2))) bigSub(val(data(c1)),data(c2)); else bigAdd(val(data(c1)),data(c2)); if (!IsZero(val(data(c1)))) neg(val(data(c1))); } else if (isNeg(data(c2))) bigAdd(val(data(c1)),data(c2)); else bigSub(val(data(c1)),data(c2)); } return val(Pop(c1)); } // (* 'num ..) -> num any doMul(any ex) { any x; bool sign; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); sign = isNeg(data(c1)), pos(data(c1)); while (isCell(x = cdr(x))) { Push(c2, EVAL(car(x))); if (isNil(data(c2))) { drop(c1); return Nil; } NeedNum(ex,data(c2)); sign ^= isNeg(data(c2)); data(c1) = bigMul(data(c1),data(c2)); drop(c2); } if (sign && !IsZero(data(c1))) neg(data(c1)); return Pop(c1); } // (*/ 'num1 ['num2 ..] 'num3) -> num any doMulDiv(any ex) { any x; bool sign; cell c1, c2, c3; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); sign = isNeg(data(c1)), pos(data(c1)); Push(c2, Nil); for (;;) { x = cdr(x), data(c2) = EVAL(car(x)); if (isNil(data(c2))) { drop(c1); return Nil; } NeedNum(ex,data(c2)); sign ^= isNeg(data(c2)); if (!isCell(cdr(x))) break; data(c1) = bigMul(data(c1),data(c2)); } if (IsZero(data(c2))) divErr(ex); Push(c3, bigCopy(data(c2))); digDiv2(data(c3)); bigAdd(data(c1),data(c3)); data(c2) = bigCopy(data(c2)); data(c1) = bigDiv(data(c1),data(c2),NO); if (sign && !IsZero(data(c1))) neg(data(c1)); return Pop(c1); } // (/ 'num ..) -> num any doDiv(any ex) { any x; bool sign; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); sign = isNeg(data(c1)), pos(data(c1)); while (isCell(x = cdr(x))) { Push(c2, EVAL(car(x))); if (isNil(data(c2))) { drop(c1); return Nil; } NeedNum(ex,data(c2)); sign ^= isNeg(data(c2)); if (IsZero(data(c2))) divErr(ex); data(c2) = bigCopy(data(c2)); data(c1) = bigDiv(data(c1),data(c2),NO); drop(c2); } if (sign && !IsZero(data(c1))) neg(data(c1)); return Pop(c1); } // (% 'num ..) -> num any doRem(any ex) { any x; bool sign; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); sign = isNeg(data(c1)), pos(data(c1)); while (isCell(x = cdr(x))) { Push(c2, EVAL(car(x))); if (isNil(data(c2))) { drop(c1); return Nil; } NeedNum(ex,data(c2)); if (IsZero(data(c2))) divErr(ex); data(c2) = bigCopy(data(c2)); bigDiv(data(c1),data(c2),YES); drop(c2); } if (sign && !IsZero(data(c1))) neg(data(c1)); return Pop(c1); } // (>> 'cnt 'num) -> num any doShift(any ex) { any x; long n; bool sign; cell c1; x = cdr(ex), n = evCnt(ex,x); x = cdr(x); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); sign = isNeg(data(c1)); if (n > 0) { do digDiv2(data(c1)); while (--n); pos(data(c1)); } else if (n < 0) { pos(data(c1)); do digMul2(data(c1)); while (++n); } if (sign && !IsZero(data(c1))) neg(data(c1)); return Pop(c1); } // (lt0 'any) -> num | NIL any doLt0(any x) { x = cdr(x); return isNum(x = EVAL(car(x))) && isNeg(x)? x : Nil; } // (le0 'any) -> num | NIL any doLe0(any x) { x = cdr(x); return isNum(x = EVAL(car(x))) && (isNeg(x) || IsZero(x))? x : Nil; } // (ge0 'any) -> num | NIL any doGe0(any x) { x = cdr(x); return isNum(x = EVAL(car(x))) && !isNeg(x)? x : Nil; } // (gt0 'any) -> num | NIL any doGt0(any x) { x = cdr(x); return isNum(x = EVAL(car(x))) && !isNeg(x) && !IsZero(x)? x : Nil; } // (abs 'num) -> num any doAbs(any ex) { any x; x = cdr(ex); if (isNil(x = EVAL(car(x)))) return Nil; NeedNum(ex,x); if (!isNeg(x)) return x; return consNum(unDig(x) & ~1, cdr(numCell(x))); } // (bit? 'num ..) -> num | NIL any doBitQ(any ex) { any x, y, z; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); NeedNum(ex,data(c1)); while (isCell(x = cdr(x))) { if (isNil(z = EVAL(car(x)))) { drop(c1); return Nil; } NeedNum(ex,z); y = data(c1); for (;;) { if ((unDig(y) & unDig(z)) != unDig(y)) { drop(c1); return Nil; } if (!isNum(y = cdr(numCell(y)))) break; if (!isNum(z = cdr(numCell(z)))) { drop(c1); return Nil; } } } return Pop(c1); } // (& 'num ..) -> num any doBitAnd(any ex) { any x, y, z; cell c1; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); while (isCell(x = cdr(x))) { if (isNil(z = EVAL(car(x)))) { drop(c1); return Nil; } NeedNum(ex,z); y = data(c1); for (;;) { setDig(y, unDig(y) & unDig(z)); if (!isNum(z = cdr(numCell(z)))) { cdr(numCell(y)) = Nil; break; } if (!isNum(y = cdr(numCell(y)))) break; } } zapZero(data(c1)); return Pop(c1); } // (| 'num ..) -> num any doBitOr(any ex) { any x, y; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); while (isCell(x = cdr(x))) { if (isNil(data(c2) = EVAL(car(x)))) { drop(c1); return Nil; } NeedNum(ex,data(c2)); y = data(c1); Save(c2); for (;;) { setDig(y, unDig(y) | unDig(data(c2))); if (!isNum(data(c2) = cdr(numCell(data(c2))))) break; if (!isNum(cdr(numCell(y)))) cdr(numCell(y)) = box(0); y = cdr(numCell(y)); } drop(c2); } return Pop(c1); } // (x| 'num ..) -> num any doBitXor(any ex) { any x, y; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; NeedNum(ex,data(c1)); Push(c1, bigCopy(data(c1))); while (isCell(x = cdr(x))) { if (isNil(data(c2) = EVAL(car(x)))) { drop(c1); return Nil; } NeedNum(ex,data(c2)); y = data(c1); Save(c2); for (;;) { setDig(y, unDig(y) ^ unDig(data(c2))); if (!isNum(data(c2) = cdr(numCell(data(c2))))) break; if (!isNum(cdr(numCell(y)))) cdr(numCell(y)) = box(0); y = cdr(numCell(y)); } drop(c2); } zapZero(data(c1)); return Pop(c1); } // (sqrt 'num ['flg|num]) -> num any doSqrt(any ex) { any x, y, z; cell c1, c2, c3, c4, c5; x = cdr(ex); if (isNil(x = EVAL(car(x)))) return Nil; NeedNum(ex,x); if (isNeg(x)) argError(ex, x); Push(c1, x); // num y = cddr(ex); Push(c2, y = EVAL(car(y))); // flg|num if (isNum(y)) x = data(c1) = bigMul(x, y); Push(c3, y = box(unDig(x))); // Number copy Push(c4, z = box(2)); // Mask while (isNum(x = cdr(numCell(x)))) { y = cdr(numCell(y)) = box(unDig(x)); data(c4) = consNum(0, data(c4)); } while (unDig(y) >= unDig(z)) if (!setDig(z, unDig(z) << 2)) { z = cdr(numCell(z)) = box(2); break; } Push(c5, box(0)); // Result do { bigAdd(data(c5),data(c4)); if (bigCmp(data(c5),data(c3)) > 0) bigSub(data(c5),data(c4)); else bigSub(data(c3),data(c5)), bigAdd(data(c5),data(c4)); digDiv2(data(c5)); digDiv2(data(c4)), digDiv2(data(c4)); } while (!IsZero(data(c4))); if (!isNil(data(c2)) && bigCmp(data(c3),data(c5)) > 0) digAdd(data(c5), 2); drop(c1); return data(c5); } /* Random numbers */ static uint64_t Seed; static uint64_t initSeed(any x) { uint64_t n; for (n = 0; isCell(x); x = cdr(x)) n += initSeed(car(x)); if (!isNil(x)) { if (isSym(x)) x = name(x); do n += unDig(x); while (isNum(x = cdr(numCell(x)))); } return n; } // (seed 'any) -> cnt any doSeed(any ex) { return box(hi(Seed = initSeed(EVAL(cadr(ex))) * 6364136223846793005LL)); } // (hash 'any) -> cnt any doHash(any ex) { word2 n = initSeed(EVAL(cadr(ex))); int i = 64; int j = 0; do { if (((int)n ^ j) & 1) j ^= 0x14002; /* CRC Polynom x**16 + x**15 + x**2 + 1 */ n >>= 1, j >>= 1; } while (--i); return box(2 * (j + 1)); } // (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg any doRand(any ex) { any x; long n; x = cdr(ex); Seed = Seed * 6364136223846793005LL + 1; if (isNil(x = EVAL(car(x)))) return box(hi(Seed)); if (x == T) return hi(Seed) & 1 ? T : Nil; n = xCnt(ex,x); return boxCnt(n + hi(Seed) % (evCnt(ex, cddr(ex)) + 1 - n)); } picolisp-3.1.5.2.orig/src/ext.c0000644000000000000000000001255412265263724014712 0ustar rootroot/* 13may13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" /*** Soundex Algorithm ***/ static int SnxTab[] = { '0', '1', '2', '3', '4', '5', '6', '7', // 48 '8', '9', 0, 0, 0, 0, 0, 0, 0, 0, 'F', 'S', 'T', 0, 'F', 'S', // 64 0, 0, 'S', 'S', 'L', 'N', 'N', 0, 'F', 'S', 'R', 'S', 'T', 0, 'F', 'F', 'S', 0, 'S', 0, 0, 0, 0, 0, 0, 0, 'F', 'S', 'T', 0, 'F', 'S', // 96 0, 0, 'S', 'S', 'L', 'N', 'N', 0, 'F', 'S', 'R', 'S', 'T', 0, 'F', 'F', 'S', 0, 'S', 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 128 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, // 160 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 'S', // 192 0, 0, 0, 0, 0, 0, 0, 0, 'T', 'N', 0, 0, 0, 0, 0, 'S', 0, 0, 0, 0, 0, 0, 0, 'S', 0, 0, 0, 0, 0, 0, 0, 'S', // 224 0, 0, 0, 0, 0, 0, 0, 0, 0, 'N' // ... }; #define SNXBASE 48 #define SNXSIZE ((int)(sizeof(SnxTab) / sizeof(int))) // (ext:Snx 'any ['cnt]) -> sym any Snx(any ex) { int n, c, i, last; any x, nm; cell c1, c2; x = cdr(ex); if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) return Nil; while (c < SNXBASE) if (!(c = symChar(NULL))) return Nil; Push(c1, x); n = isCell(x = cddr(ex))? evCnt(ex,x) : 24; if (c >= 'a' && c <= 'z' || c == 128 || c >= 224 && c < 255) c &= ~0x20; Push(c2, boxChar(last = c, &i, &nm)); while (c = symChar(NULL)) if (c > ' ') { if ((c -= SNXBASE) < 0 || c >= SNXSIZE || !(c = SnxTab[c])) last = 0; else if (c != last) { if (!--n) break; charSym(last = c, &i, &nm); } } drop(c1); return consStr(data(c2)); } /*** Math ***/ // (ext:Pow 'x 'y 'scale) -> num any Pow(any ex) { double x, y, n; x = evDouble(ex, cdr(ex)); y = evDouble(ex, cddr(ex)); n = evDouble(ex, cdddr(ex)); return doubleToNum(n * pow(x / n, y / n)); } // (ext:Exp 'x 'scale) -> num any Exp(any ex) { double x, n; x = evDouble(ex, cdr(ex)); n = evDouble(ex, cddr(ex)); return doubleToNum(n * exp(x / n)); } // (ext:Log 'x 'scale) -> num any Log(any ex) { double x, n; x = evDouble(ex, cdr(ex)); n = evDouble(ex, cddr(ex)); return doubleToNum(n * log(x / n)); } // (ext:Sin 'angle 'scale) -> num any Sin(any ex) { double a, n; a = evDouble(ex, cdr(ex)); n = evDouble(ex, cddr(ex)); return doubleToNum(n * sin(a / n)); } // (ext:Cos 'angle 'scale) -> num any Cos(any ex) { double a, n; a = evDouble(ex, cdr(ex)); n = evDouble(ex, cddr(ex)); return doubleToNum(n * cos(a / n)); } // (ext:Tan 'angle 'scale) -> num any Tan(any ex) { double a, n; a = evDouble(ex, cdr(ex)); n = evDouble(ex, cddr(ex)); return doubleToNum(n * tan(a / n)); } // (ext:Asin 'angle 'scale) -> num any Asin(any ex) { double a, n; a = evDouble(ex, cdr(ex)); n = evDouble(ex, cddr(ex)); return doubleToNum(n * asin(a / n)); } // (ext:Acos 'angle 'scale) -> num any Acos(any ex) { double a, n; a = evDouble(ex, cdr(ex)); n = evDouble(ex, cddr(ex)); return doubleToNum(n * acos(a / n)); } // (ext:Atan 'angle 'scale) -> num any Atan(any ex) { double a, n; a = evDouble(ex, cdr(ex)); n = evDouble(ex, cddr(ex)); return doubleToNum(n * atan(a / n)); } // (ext:Atan2 'x 'y 'scale) -> num any Atan2(any ex) { double x, y, n; x = evDouble(ex, cdr(ex)); y = evDouble(ex, cddr(ex)); n = evDouble(ex, cdddr(ex)); return doubleToNum(n * atan2(x / n, y / n)); } /*** U-Law Encoding ***/ #define BIAS 132 #define CLIP (32767-BIAS) // (ext:Ulaw 'cnt) -> cnt # SEEEMMMM any Ulaw(any ex) { int val, sign, tmp, exp; val = (int)evCnt(ex,cdr(ex)); sign = 0; if (val < 0) val = -val, sign = 0x80; if (val > CLIP) val = CLIP; tmp = (val += BIAS) << 1; for (exp = 7; exp > 0 && !(tmp & 0x8000); --exp, tmp <<= 1); return boxCnt(~(sign | exp<<4 | val >> exp+3 & 0x000F) & 0xFF); } /*** Base64 Encoding ***/ static unsigned char Chr64[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; // (ext:Base64 'num1|NIL ['num2|NIL ['num3|NIL]]) -> flg any Base64(any x) { int c, d; any y; x = cdr(x); if (isNil(y = EVAL(car(x)))) return Nil; c = unDig(y) / 2; Env.put(Chr64[c >> 2]); x = cdr(x); if (isNil(y = EVAL(car(x)))) { Env.put(Chr64[(c & 3) << 4]), Env.put('='), Env.put('='); return Nil; } d = unDig(y) / 2; Env.put(Chr64[(c & 3) << 4 | d >> 4]); x = cdr(x); if (isNil(y = EVAL(car(x)))) { Env.put(Chr64[(d & 15) << 2]), Env.put('='); return Nil; } c = unDig(y) / 2; Env.put(Chr64[(d & 15) << 2 | c >> 6]), Env.put(Chr64[c & 63]); return T; } /*** Password hashing ***/ // (Ext:Crypt 'key 'salt) -> str any Crypt(any x) { any y; y = evSym(x = cdr(x)); { char key[bufSize(y)]; bufString(y, key); y = evSym(cdr(x)); { char salt[bufSize(y)]; bufString(y, salt); return mkStr(crypt(key, salt)); } } } picolisp-3.1.5.2.orig/src/flow.c0000644000000000000000000011542512265263724015062 0ustar rootroot/* 15nov13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" static void redefMsg(any x, any y) { outFile *oSave = OutFile; void (*putSave)(int) = Env.put; OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; outString("# "); print(x); if (y) space(), print(y); outString(" redefined\n"); Env.put = putSave, OutFile = oSave; } static void putSrc(any s, any k) { if (!isNil(val(Dbg)) && !isExt(s) && InFile && InFile->name) { any x, y; cell c1; Push(c1, boxCnt(InFile->src)); data(c1) = cons(data(c1), mkStr(InFile->name)); x = get(s, Dbg); if (!k) { if (isNil(x)) put(s, Dbg, cons(data(c1), Nil)); else car(x) = data(c1); } else if (isNil(x)) put(s, Dbg, cons(Nil, cons(data(c1), Nil))); else { for (y = cdr(x); isCell(y); y = cdr(y)) if (caar(y) == k) { cdar(y) = data(c1); drop(c1); return; } cdr(x) = cons(cons(k, data(c1)), cdr(x)); } drop(c1); } } static void redefine(any ex, any s, any x) { NeedSym(ex,s); CheckVar(ex,s); if (!isNil(val(s)) && s != val(s) && !equal(x,val(s))) redefMsg(s, NULL); val(s) = x; putSrc(s, NULL); } // (quote . any) -> any any doQuote(any x) {return cdr(x);} // (as 'any1 . any2) -> any2 | NIL any doAs(any x) { x = cdr(x); if (isNil(EVAL(car(x)))) return Nil; return cdr(x); } // (lit 'any) -> any any doLit(any x) { x = cadr(x); if (isNum(x = EVAL(x)) || isNil(x) || x == T || isCell(x) && isNum(car(x))) return x; return cons(Quote, x); } // (eval 'any ['cnt ['lst]]) -> any any doEval(any x) { any y; cell c1; bindFrame *p; x = cdr(x), Push(c1, EVAL(car(x))), x = cdr(x); if (!isNum(y = EVAL(car(x))) || !(p = Env.bind)) data(c1) = EVAL(data(c1)); else { int cnt, n, i, j; struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(x)]; } f; x = cdr(x), x = EVAL(car(x)); j = cnt = (int)unBox(y); n = f.i = f.cnt = 0; do { ++n; if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) { for (i = 0; i < p->cnt; ++i) { y = val(p->bnd[i].sym); val(p->bnd[i].sym) = p->bnd[i].val; p->bnd[i].val = y; } if (p->cnt && p->bnd[0].sym == At && !--j) break; } } while (p = p->link); while (isCell(x)) { for (p = Env.bind, j = n; ; p = p->link) { if (p->i < 0) for (i = 0; i < p->cnt; ++i) { if (p->bnd[i].sym == car(x)) { f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); val(car(x)) = p->bnd[i].val; ++f.cnt; goto next; } } if (!--j) break; } next: x = cdr(x); } f.link = Env.bind, Env.bind = (bindFrame*)&f; data(c1) = EVAL(data(c1)); while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; do { for (p = Env.bind, i = n; --i; p = p->link); if (p->i < 0 && (p->i += cnt) == 0) for (i = p->cnt; --i >= 0;) { y = val(p->bnd[i].sym); val(p->bnd[i].sym) = p->bnd[i].val; p->bnd[i].val = y; } } while (--n); } return Pop(c1); } // (run 'any ['cnt ['lst]]) -> any any doRun(any x) { any y; cell c1; bindFrame *p; x = cdr(x), data(c1) = EVAL(car(x)), x = cdr(x); if (!isNum(data(c1))) { Save(c1); if (!isNum(y = EVAL(car(x))) || !(p = Env.bind)) data(c1) = isSym(data(c1))? val(data(c1)) : run(data(c1)); else { int cnt, n, i, j; struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(x)]; } f; x = cdr(x), x = EVAL(car(x)); j = cnt = (int)unBox(y); n = f.i = f.cnt = 0; do { ++n; if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) { for (i = 0; i < p->cnt; ++i) { y = val(p->bnd[i].sym); val(p->bnd[i].sym) = p->bnd[i].val; p->bnd[i].val = y; } if (p->cnt && p->bnd[0].sym == At && !--j) break; } } while (p = p->link); while (isCell(x)) { for (p = Env.bind, j = n; ; p = p->link) { if (p->i < 0) for (i = 0; i < p->cnt; ++i) { if (p->bnd[i].sym == car(x)) { f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); val(car(x)) = p->bnd[i].val; ++f.cnt; goto next; } } if (!--j) break; } next: x = cdr(x); } f.link = Env.bind, Env.bind = (bindFrame*)&f; data(c1) = isSym(data(c1))? val(data(c1)) : prog(data(c1)); while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; do { for (p = Env.bind, i = n; --i; p = p->link); if (p->i < 0 && (p->i += cnt) == 0) for (i = p->cnt; --i >= 0;) { y = val(p->bnd[i].sym); val(p->bnd[i].sym) = p->bnd[i].val; p->bnd[i].val = y; } } while (--n); } drop(c1); } return data(c1); } // (def 'sym 'any) -> sym // (def 'sym 'sym 'any) -> sym any doDef(any ex) { any x, y; cell c1, c2, c3; x = cdr(ex), Push(c1, EVAL(car(x))); NeedSym(ex,data(c1)); x = cdr(x), Push(c2, EVAL(car(x))); if (!isCell(cdr(x))) { CheckVar(ex,data(c1)); Touch(ex,data(c1)); if (!isNil(y = val(data(c1))) && y != data(c1) && !equal(data(c2), y)) redefMsg(data(c1), NULL); val(data(c1)) = data(c2); putSrc(data(c1), NULL); } else { x = cdr(x), Push(c3, EVAL(car(x))); if (isExt(data(c1))) db(ex, data(c1), !isNil(data(c2))? 2 : 1); if (!isNil(y = get(data(c1), data(c2))) && !equal(data(c3), y)) redefMsg(data(c1), data(c2)); put(data(c1), data(c2), data(c3)); putSrc(data(c1), data(c2)); } return Pop(c1); } // (de sym . any) -> sym any doDe(any ex) { redefine(ex, cadr(ex), cddr(ex)); return cadr(ex); } // (dm sym . fun|cls2) -> sym // (dm (sym . cls) . fun|cls2) -> sym // (dm (sym sym2 [. cls]) . fun|cls2) -> sym any doDm(any ex) { any x, y, msg, cls; x = cdr(ex); if (!isCell(car(x))) msg = car(x), cls = val(Class); else { msg = caar(x); cls = !isCell(cdar(x))? cdar(x) : get(isNil(cddar(x))? val(Class) : cddar(x), cadar(x)); } if (msg != T) redefine(ex, msg, val(Meth)); if (isSym(cdr(x))) { y = val(cdr(x)); for (;;) { if (!isCell(y) || !isCell(car(y))) err(ex, msg, "Bad message"); if (caar(y) == msg) { x = car(y); break; } y = cdr(y); } } for (y = val(cls); isCell(y) && isCell(car(y)); y = cdr(y)) if (caar(y) == msg) { if (!equal(cdr(x), cdar(y))) redefMsg(msg, cls); cdar(y) = cdr(x); putSrc(cls, msg); return msg; } if (!isCell(car(x))) val(cls) = cons(x, val(cls)); else val(cls) = cons(cons(msg, cdr(x)), val(cls)); putSrc(cls, msg); return msg; } /* Evaluate method invocation */ static any evMethod(any o, any expr, any x) { any y = car(expr); any cls = TheCls, key = TheKey; struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(y)+3]; } f; f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = sizeof(f.bnd) / (2*sizeof(any)) - 2; f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); while (isCell(y)) { f.bnd[f.cnt].sym = car(y); f.bnd[f.cnt].val = EVAL(car(x)); ++f.cnt, x = cdr(x), y = cdr(y); } if (isNil(y)) { do { x = val(f.bnd[--f.i].sym); val(f.bnd[f.i].sym) = f.bnd[f.i].val; f.bnd[f.i].val = x; } while (f.i); f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; y = cls, cls = Env.cls; Env.cls = y; y = key, key = Env.key; Env.key = y; x = prog(cdr(expr)); } else if (y != At) { f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x; do { x = val(f.bnd[--f.i].sym); val(f.bnd[f.i].sym) = f.bnd[f.i].val; f.bnd[f.i].val = x; } while (f.i); f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; y = cls, cls = Env.cls; Env.cls = y; y = key, key = Env.key; Env.key = y; x = prog(cdr(expr)); } else { int n, cnt; cell *arg; cell c[n = cnt = length(x)]; while (--n >= 0) Push(c[n], EVAL(car(x))), x = cdr(x); do { x = val(f.bnd[--f.i].sym); val(f.bnd[f.i].sym) = f.bnd[f.i].val; f.bnd[f.i].val = x; } while (f.i); n = Env.next, Env.next = cnt; arg = Env.arg, Env.arg = c; f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o; y = cls, cls = Env.cls; Env.cls = y; y = key, key = Env.key; Env.key = y; x = prog(cdr(expr)); if (cnt) drop(c[cnt-1]); Env.arg = arg, Env.next = n; } while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; Env.cls = cls, Env.key = key; return x; } any method(any x) { any y, z; if (isCell(y = val(x))) { while (isCell(z = car(y))) { if (car(z) == TheKey) return cdr(z); if (!isCell(y = cdr(y))) return NULL; } do if (x = method(car(TheCls = y))) return x; while (isCell(y = cdr(y))); } return NULL; } // (box 'any) -> sym any doBox(any x) { x = cdr(x); return consSym(EVAL(car(x)), Nil); } // (new ['flg|num] ['typ ['any ..]]) -> obj any doNew(any ex) { any x, y, *h; cell c1, c2; x = cdr(ex); if (isCell(y = EVAL(car(x)))) Push(c1, consSym(y,Nil)); else { if (isNil(y)) data(c1) = consSym(Nil,Nil); else { y = newId(ex, isNum(y)? (int)unDig(y)/2 : 1); if (data(c1) = findHash(y, h = Extern + ehash(y))) tail(data(c1)) = y; else *h = cons(data(c1) = consSym(Nil,y), *h); mkExt(data(c1)); } Save(c1); x = cdr(x), val(data(c1)) = EVAL(car(x)); } TheKey = T, TheCls = NULL; if (y = method(data(c1))) evMethod(data(c1), y, cdr(x)); else { Push(c2, Nil); while (isCell(x = cdr(x))) { data(c2) = EVAL(car(x)), x = cdr(x); put(data(c1), data(c2), EVAL(car(x))); } } return Pop(c1); } // (type 'any) -> lst any doType(any ex) { any x, y, z; x = cdr(ex), x = EVAL(car(x)); if (isSym(x)) { Fetch(ex,x); z = x = val(x); while (isCell(x)) { if (!isCell(car(x))) { y = x; while (isSym(car(x))) { if (!isCell(x = cdr(x))) return isNil(x)? y : Nil; if (z == x) return Nil; } return Nil; } if (z == (x = cdr(x))) return Nil; } } return Nil; } static bool isa(any cls, any x) { any z; z = x = val(x); while (isCell(x)) { if (!isCell(car(x))) { while (isSym(car(x))) { if (isExt(car(x))) return NO; if (cls == car(x) || isa(cls, car(x))) return YES; if (!isCell(x = cdr(x)) || z == x) return NO; } return NO; } if (z == (x = cdr(x))) return NO; } return NO; } // (isa 'cls|typ 'any) -> obj | NIL any doIsa(any ex) { any x; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); x = cdr(x), x = EVAL(car(x)); if (isSym(x)) { Fetch(ex,x); drop(c1); if (isSym(data(c1))) return isa(data(c1), x)? x : Nil; while (isCell(data(c1))) { if (!isa(car(data(c1)), x)) return Nil; data(c1) = cdr(data(c1)); } return x; } drop(c1); return Nil; } // (method 'msg 'obj) -> fun any doMethod(any ex) { any x; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); NeedSym(ex,data(c1)); x = cdr(x), x = EVAL(car(x)); NeedSym(ex,x); Fetch(ex,x); TheKey = Pop(c1); return method(x)? : Nil; } // (meth 'obj ['any ..]) -> any any doMeth(any ex) { any x, y; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); NeedSym(ex,data(c1)); Fetch(ex,data(c1)); for (TheKey = car(ex); ; TheKey = val(TheKey)) { if (!isSym(TheKey)) err(ex, TheKey, "Bad message"); if (isNum(val(TheKey))) { TheCls = NULL; if (y = method(data(c1))) { x = evMethod(data(c1), y, cdr(x)); drop(c1); return x; } err(ex, TheKey, "Bad message"); } } } // (send 'msg 'obj ['any ..]) -> any any doSend(any ex) { any x, y; cell c1, c2; x = cdr(ex), Push(c1, EVAL(car(x))); NeedSym(ex,data(c1)); x = cdr(x), Push(c2, EVAL(car(x))); NeedSym(ex,data(c2)); Fetch(ex,data(c2)); TheKey = data(c1), TheCls = NULL; if (y = method(data(c2))) { x = evMethod(data(c2), y, cdr(x)); drop(c1); return x; } err(ex, TheKey, "Bad message"); } // (try 'msg 'obj ['any ..]) -> any any doTry(any ex) { any x, y; cell c1, c2; x = cdr(ex), Push(c1, EVAL(car(x))); NeedSym(ex,data(c1)); x = cdr(x), Push(c2, EVAL(car(x))); if (isSym(data(c2))) { if (isExt(data(c2))) { if (!isLife(data(c2))) return Nil; db(ex,data(c2),1); } TheKey = data(c1), TheCls = NULL; if (y = method(data(c2))) { x = evMethod(data(c2), y, cdr(x)); drop(c1); return x; } } drop(c1); return Nil; } // (super ['any ..]) -> any any doSuper(any ex) { any x, y, cls, key; TheKey = Env.key; x = val(Env.cls? car(Env.cls) : val(This)); while (isCell(car(x))) x = cdr(x); while (isCell(x)) { if (y = method(car(TheCls = x))) { cls = Env.cls, Env.cls = TheCls; key = Env.key, Env.key = TheKey; x = evExpr(y, cdr(ex)); Env.key = key, Env.cls = cls; return x; } x = cdr(x); } err(ex, TheKey, "Bad super"); } static any extra(any x) { any y; for (x = val(x); isCell(car(x)); x = cdr(x)); while (isCell(x)) { if (x == Env.cls || !(y = extra(car(x)))) { while (isCell(x = cdr(x))) if (y = method(car(TheCls = x))) return y; return NULL; } if (y && num(y) != 1) return y; x = cdr(x); } return (any)1; } // (extra ['any ..]) -> any any doExtra(any ex) { any x, y, cls, key; TheKey = Env.key; if ((y = extra(val(This))) && num(y) != 1) { cls = Env.cls, Env.cls = TheCls; key = Env.key, Env.key = TheKey; x = evExpr(y, cdr(ex)); Env.key = key, Env.cls = cls; return x; } err(ex, TheKey, "Bad extra"); } // (with 'sym . prg) -> any any doWith(any ex) { any x; bindFrame f; x = cdr(ex); if (isNil(x = EVAL(car(x)))) return Nil; NeedSym(ex,x); Bind(This,f), val(This) = x; x = prog(cddr(ex)); Unbind(f); return x; } // (bind 'sym|lst . prg) -> any any doBind(any ex) { any x, y; x = cdr(ex); if (isNum(y = EVAL(car(x)))) argError(ex, y); if (isNil(y)) return prog(cdr(x)); if (isSym(y)) { bindFrame f; Bind(y,f); x = prog(cdr(x)); Unbind(f); return x; } { struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(y)]; } f; f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = f.cnt = 0; do { if (isNum(car(y))) argError(ex, car(y)); if (isSym(car(y))) { f.bnd[f.cnt].sym = car(y); f.bnd[f.cnt].val = val(car(y)); } else { f.bnd[f.cnt].sym = caar(y); f.bnd[f.cnt].val = val(caar(y)); val(caar(y)) = cdar(y); } ++f.cnt; } while (isCell(y = cdr(y))); x = prog(cdr(x)); while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; return x; } } // (job 'lst . prg) -> any any doJob(any ex) { any x = cdr(ex); any y = EVAL(car(x)); cell c1; struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(y)]; } f; Push(c1,y); f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = f.cnt = 0; while (isCell(y)) { f.bnd[f.cnt].sym = caar(y); f.bnd[f.cnt].val = val(caar(y)); val(caar(y)) = cdar(y); ++f.cnt, y = cdr(y); } x = prog(cdr(x)); for (f.cnt = 0, y = Pop(c1); isCell(y); ++f.cnt, y = cdr(y)) { cdar(y) = val(caar(y)); val(caar(y)) = f.bnd[f.cnt].val; } Env.bind = f.link; return x; } // (let sym 'any . prg) -> any // (let (sym 'any ..) . prg) -> any any doLet(any x) { any y; x = cdr(x); if (isSym(y = car(x))) { bindFrame f; x = cdr(x), Bind(y,f), val(y) = EVAL(car(x)); x = prog(cdr(x)); Unbind(f); } else { struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[(length(y)+1)/2]; } f; f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = f.cnt = 0; do { f.bnd[f.cnt].sym = car(y); f.bnd[f.cnt].val = val(car(y)); ++f.cnt; val(car(y)) = EVAL(cadr(y)); } while (isCell(y = cddr(y))); x = prog(cdr(x)); while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; } return x; } // (let? sym 'any . prg) -> any any doLetQ(any x) { any y, z; bindFrame f; x = cdr(x), y = car(x), x = cdr(x); if (isNil(z = EVAL(car(x)))) return Nil; Bind(y,f), val(y) = z; x = prog(cdr(x)); Unbind(f); return x; } // (use sym . prg) -> any // (use (sym ..) . prg) -> any any doUse(any x) { any y; x = cdr(x); if (isSym(y = car(x))) { bindFrame f; Bind(y,f); x = prog(cdr(x)); Unbind(f); } else { struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(y)]; } f; f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = f.cnt = 0; do { f.bnd[f.cnt].sym = car(y); f.bnd[f.cnt].val = val(car(y)); ++f.cnt; } while (isCell(y = cdr(y))); x = prog(cdr(x)); while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; } return x; } // (and 'any ..) -> any any doAnd(any x) { any a; x = cdr(x); do { if (isNil(a = EVAL(car(x)))) return Nil; val(At) = a; } while (isCell(x = cdr(x))); return a; } // (or 'any ..) -> any any doOr(any x) { any a; x = cdr(x); do if (!isNil(a = EVAL(car(x)))) return val(At) = a; while (isCell(x = cdr(x))); return Nil; } // (nand 'any ..) -> flg any doNand(any x) { any a; x = cdr(x); do { if (isNil(a = EVAL(car(x)))) return T; val(At) = a; } while (isCell(x = cdr(x))); return Nil; } // (nor 'any ..) -> flg any doNor(any x) { any a; x = cdr(x); do if (!isNil(a = EVAL(car(x)))) { val(At) = a; return Nil; } while (isCell(x = cdr(x))); return T; } // (xor 'any 'any) -> flg any doXor(any x) { bool f; x = cdr(x), f = isNil(EVAL(car(x))), x = cdr(x); return f ^ isNil(EVAL(car(x)))? T : Nil; } // (bool 'any) -> flg any doBool(any x) {return isNil(EVAL(cadr(x)))? Nil : T;} // (not 'any) -> flg any doNot(any x) { any a; if (isNil(a = EVAL(cadr(x)))) return T; val(At) = a; return Nil; } // (nil . prg) -> NIL any doNil(any x) { while (isCell(x = cdr(x))) if (isCell(car(x))) evList(car(x)); return Nil; } // (t . prg) -> T any doT(any x) { while (isCell(x = cdr(x))) if (isCell(car(x))) evList(car(x)); return T; } // (prog . prg) -> any any doProg(any x) {return prog(cdr(x));} // (prog1 'any1 . prg) -> any1 any doProg1(any x) { cell c1; x = cdr(x), Push(c1, val(At) = EVAL(car(x))); while (isCell(x = cdr(x))) if (isCell(car(x))) evList(car(x)); return Pop(c1); } // (prog2 'any1 'any2 . prg) -> any2 any doProg2(any x) { cell c1; x = cdr(x), EVAL(car(x)); x = cdr(x), Push(c1, val(At) = EVAL(car(x))); while (isCell(x = cdr(x))) if (isCell(car(x))) evList(car(x)); return Pop(c1); } // (if 'any1 'any2 . prg) -> any any doIf(any x) { any a; x = cdr(x); if (isNil(a = EVAL(car(x)))) return prog(cddr(x)); val(At) = a; x = cdr(x); return EVAL(car(x)); } // (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any any doIf2(any x) { any a; x = cdr(x); if (isNil(a = EVAL(car(x)))) { x = cdr(x); if (isNil(a = EVAL(car(x)))) return prog(cddddr(x)); val(At) = a; x = cdddr(x); return EVAL(car(x)); } val(At) = a; x = cdr(x); if (isNil(a = EVAL(car(x)))) { x = cddr(x); return EVAL(car(x)); } val(At) = a; x = cdr(x); return EVAL(car(x)); } // (ifn 'any1 'any2 . prg) -> any any doIfn(any x) { any a; x = cdr(x); if (!isNil(a = EVAL(car(x)))) { val(At) = a; return prog(cddr(x)); } x = cdr(x); return EVAL(car(x)); } // (when 'any . prg) -> any any doWhen(any x) { any a; x = cdr(x); if (isNil(a = EVAL(car(x)))) return Nil; val(At) = a; return prog(cdr(x)); } // (unless 'any . prg) -> any any doUnless(any x) { any a; x = cdr(x); if (!isNil(a = EVAL(car(x)))) { val(At) = a; return Nil; } return prog(cdr(x)); } // (cond ('any1 . prg1) ('any2 . prg2) ..) -> any any doCond(any x) { any a; while (isCell(x = cdr(x))) { if (!isNil(a = EVAL(caar(x)))) { val(At) = a; return prog(cdar(x)); } } return Nil; } // (nond ('any1 . prg1) ('any2 . prg2) ..) -> any any doNond(any x) { any a; while (isCell(x = cdr(x))) { if (isNil(a = EVAL(caar(x)))) return prog(cdar(x)); val(At) = a; } return Nil; } // (case 'any (any1 . prg1) (any2 . prg2) ..) -> any any doCase(any x) { any y, z; x = cdr(x), val(At) = EVAL(car(x)); while (isCell(x = cdr(x))) { y = car(x), z = car(y); if (z == T || equal(val(At), z)) return prog(cdr(y)); if (isCell(z)) { do if (equal(val(At), car(z))) return prog(cdr(y)); while (isCell(z = cdr(z))); } } return Nil; } // (casq 'any (any1 . prg1) (any2 . prg2) ..) -> any any doCasq(any x) { any y, z; x = cdr(x), val(At) = EVAL(car(x)); while (isCell(x = cdr(x))) { y = car(x), z = car(y); if (z == T || z == val(At)) return prog(cdr(y)); if (isCell(z)) { do if (car(z) == val(At)) return prog(cdr(y)); while (isCell(z = cdr(z))); } } return Nil; } // (state 'var (sym|lst exe [. prg]) ..) -> any any doState(any ex) { any x, y, a; cell c1; x = cdr(ex); Push(c1, EVAL(car(x))); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); while (isCell(x = cdr(x))) { y = car(x); if (car(y) == T || memq(val(data(c1)), car(y))) { y = cdr(y); if (!isNil(a = EVAL(car(y)))) { val(At) = val(data(c1)) = a; drop(c1); return prog(cdr(y)); } } } drop(c1); return Nil; } // (while 'any . prg) -> any any doWhile(any x) { any cond, a; cell c1; cond = car(x = cdr(x)), x = cdr(x); Push(c1, Nil); while (!isNil(a = EVAL(cond))) { val(At) = a; data(c1) = prog(x); } return Pop(c1); } // (until 'any . prg) -> any any doUntil(any x) { any cond, a; cell c1; cond = car(x = cdr(x)), x = cdr(x); Push(c1, Nil); while (isNil(a = EVAL(cond))) data(c1) = prog(x); val(At) = a; return Pop(c1); } // (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any any doLoop(any ex) { any x, y, a; for (;;) { x = cdr(ex); do { if (isCell(y = car(x))) { if (isNil(car(y))) { y = cdr(y); if (isNil(a = EVAL(car(y)))) return prog(cdr(y)); val(At) = a; } else if (car(y) == T) { y = cdr(y); if (!isNil(a = EVAL(car(y)))) { val(At) = a; return prog(cdr(y)); } } else evList(y); } } while (isCell(x = cdr(x))); } } // (do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any any doDo(any x) { any y, z, a; cell c1; x = cdr(x); if (isNil(data(c1) = EVAL(car(x)))) return Nil; Save(c1); if (isNum(data(c1))) { if (isNeg(data(c1))) { drop(c1); return Nil; } data(c1) = bigCopy(data(c1)); } x = cdr(x), z = Nil; for (;;) { if (isNum(data(c1))) { if (IsZero(data(c1))) { drop(c1); return z; } digSub1(data(c1)); } y = x; do { if (!isNum(z = car(y))) { if (isSym(z)) z = val(z); else if (isNil(car(z))) { z = cdr(z); if (isNil(a = EVAL(car(z)))) { drop(c1); return prog(cdr(z)); } val(At) = a; z = Nil; } else if (car(z) == T) { z = cdr(z); if (!isNil(a = EVAL(car(z)))) { val(At) = a; drop(c1); return prog(cdr(z)); } z = Nil; } else z = evList(z); } } while (isCell(y = cdr(y))); } } // (at '(cnt1 . cnt2|NIL) . prg) -> any any doAt(any ex) { any x; x = cdr(ex), x = EVAL(car(x)); NeedPair(ex,x); if (isNil(cdr(x))) return Nil; NeedCnt(ex,car(x)); NeedCnt(ex,cdr(x)); if (num(setDig(car(x), unDig(car(x))+2)) < unDig(cdr(x))) return Nil; setDig(car(x), 0); return prog(cddr(ex)); } // (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any // (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any // (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any any doFor(any x) { any y, body, cond, a; cell c1; struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[2]; } f; f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = 0; if (!isCell(y = car(x = cdr(x))) || !isCell(cdr(y))) { if (!isCell(y)) { f.cnt = 1; f.bnd[0].sym = y; f.bnd[0].val = val(y); } else { f.cnt = 2; f.bnd[0].sym = cdr(y); f.bnd[0].val = val(cdr(y)); f.bnd[1].sym = car(y); f.bnd[1].val = val(car(y)); val(f.bnd[1].sym) = Zero; } y = Nil; x = cdr(x), Push(c1, EVAL(car(x))); if (isNum(data(c1))) val(f.bnd[0].sym) = Zero; body = x = cdr(x); for (;;) { if (isNum(data(c1))) { val(f.bnd[0].sym) = bigCopy(val(f.bnd[0].sym)); digAdd(val(f.bnd[0].sym), 2); if (bigCompare(val(f.bnd[0].sym), data(c1)) > 0) break; } else { if (!isCell(data(c1))) break; val(f.bnd[0].sym) = car(data(c1)); if (!isCell(data(c1) = cdr(data(c1)))) data(c1) = Nil; } if (f.cnt == 2) { val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym)); digAdd(val(f.bnd[1].sym), 2); } do { if (!isNum(y = car(x))) { if (isSym(y)) y = val(y); else if (isNil(car(y))) { y = cdr(y); if (isNil(a = EVAL(car(y)))) { y = prog(cdr(y)); goto for1; } val(At) = a; y = Nil; } else if (car(y) == T) { y = cdr(y); if (!isNil(a = EVAL(car(y)))) { val(At) = a; y = prog(cdr(y)); goto for1; } y = Nil; } else y = evList(y); } } while (isCell(x = cdr(x))); x = body; } for1: drop(c1); if (f.cnt == 2) val(f.bnd[1].sym) = f.bnd[1].val; val(f.bnd[0].sym) = f.bnd[0].val; Env.bind = f.link; return y; } if (!isCell(car(y))) { f.cnt = 1; f.bnd[0].sym = car(y); f.bnd[0].val = val(car(y)); } else { f.cnt = 2; f.bnd[0].sym = cdar(y); f.bnd[0].val = val(cdar(y)); f.bnd[1].sym = caar(y); f.bnd[1].val = val(caar(y)); val(f.bnd[1].sym) = Zero; } y = cdr(y); val(f.bnd[0].sym) = EVAL(car(y)); y = cdr(y), cond = car(y), y = cdr(y); Push(c1,Nil); body = x = cdr(x); for (;;) { if (f.cnt == 2) { val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym)); digAdd(val(f.bnd[1].sym), 2); } if (isNil(a = EVAL(cond))) break; val(At) = a; do { if (!isNum(data(c1) = car(x))) { if (isSym(data(c1))) data(c1) = val(data(c1)); else if (isNil(car(data(c1)))) { data(c1) = cdr(data(c1)); if (isNil(a = EVAL(car(data(c1))))) { data(c1) = prog(cdr(data(c1))); goto for2; } val(At) = a; data(c1) = Nil; } else if (car(data(c1)) == T) { data(c1) = cdr(data(c1)); if (!isNil(a = EVAL(car(data(c1))))) { val(At) = a; data(c1) = prog(cdr(data(c1))); goto for2; } data(c1) = Nil; } else data(c1) = evList(data(c1)); } } while (isCell(x = cdr(x))); if (isCell(y)) val(f.bnd[0].sym) = prog(y); x = body; } for2: if (f.cnt == 2) val(f.bnd[1].sym) = f.bnd[1].val; val(f.bnd[0].sym) = f.bnd[0].val; Env.bind = f.link; return Pop(c1); } // (catch 'any . prg) -> any any doCatch(any x) { any y; catchFrame f; x = cdr(x), f.tag = EVAL(car(x)), f.fin = Zero; f.link = CatchPtr, CatchPtr = &f; f.env = Env; y = setjmp(f.rst)? Thrown : prog(cdr(x)); CatchPtr = f.link; return y; } // (throw 'sym 'any) any doThrow(any ex) { any x, tag; catchFrame *p; x = cdr(ex), tag = EVAL(car(x)); x = cdr(x), Thrown = EVAL(car(x)); for (p = CatchPtr; p; p = p->link) if (p->tag == T || tag == p->tag) { unwind(p); longjmp(p->rst, 1); } err(ex, tag, "Tag not found"); } // (finally exe . prg) -> any any doFinally(any x) { catchFrame f; cell c1; x = cdr(x), f.tag = NULL, f.fin = car(x); f.link = CatchPtr, CatchPtr = &f; f.env = Env; Push(c1, prog(cdr(x))); EVAL(f.fin); CatchPtr = f.link; return Pop(c1); } static outFrame Out; static struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[3]; // for 'Up', 'Run' and 'At' } Brk; any brkLoad(any x) { if (!Break && isatty(STDIN_FILENO) && isatty(STDOUT_FILENO)) { Break = YES; Brk.cnt = 3; Brk.bnd[0].sym = Up, Brk.bnd[0].val = val(Up), val(Up) = x; Brk.bnd[1].sym = Run, Brk.bnd[1].val = val(Run), val(Run) = Nil; Brk.bnd[2].sym = At, Brk.bnd[2].val = val(At); Brk.link = Env.bind, Env.bind = (bindFrame*)&Brk; Out.pid = 0, Out.fd = STDOUT_FILENO, pushOutFiles(&Out); print(x), newline(); load(NULL, '!', Nil); popOutFiles(); val(At) = Brk.bnd[2].val; val(Run) = Brk.bnd[1].val; x = val(Up), val(Up) = Brk.bnd[0].val; Env.bind = Brk.link; Break = NO; } return x; } // (! . exe) -> any any doBreak(any x) { x = cdr(x); if (!isNil(val(Dbg))) x = brkLoad(x); return EVAL(x); } // (e . prg) -> any any doE(any ex) { any x; inFrame *in; cell c1, at, key; if (!Break) err(ex, NULL, "No Break"); Push(c1,val(Dbg)), val(Dbg) = Nil; Push(at, val(At)), val(At) = Brk.bnd[2].val; Push(key, val(Run)), val(Run) = Brk.bnd[1].val; in = Env.inFrames, popInFiles(); popOutFiles(); x = isCell(cdr(ex))? prog(cdr(ex)) : EVAL(val(Up)); pushOutFiles(&Out); pushInFiles(in); val(Run) = data(key); val(At) = data(at); val(Dbg) = Pop(c1); return x; } static void traceIndent(int i, any x, char *s) { if (i > 64) i = 64; while (--i >= 0) Env.put(' '); if (isSym(x)) print(x); else print(car(x)), space(), print(cdr(x)), space(), print(val(This)); outString(s); } // ($ sym|lst lst . prg) -> any any doTrace(any x) { any foo, body; outFile *oSave; void (*putSave)(int); cell c1; x = cdr(x); if (isNil(val(Dbg))) return prog(cddr(x)); oSave = OutFile, putSave = Env.put; OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; foo = car(x); x = cdr(x), body = cdr(x); traceIndent(++Env.trace, foo, " :"); for (x = car(x); isCell(x); x = cdr(x)) space(), print(val(car(x))); if (!isNil(x)) { if (x != At) space(), print(val(x)); else { int i = Env.next; while (--i >= 0) space(), print(data(Env.arg[i])); } } newline(); Env.put = putSave, OutFile = oSave; Push(c1, prog(body)); OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout; traceIndent(Env.trace--, foo, " = "), print(data(c1)); newline(); Env.put = putSave, OutFile = oSave; return Pop(c1); } // (call 'any ..) -> flg any doCall(any ex) { pid_t pid; any x, y; int res, i, ac = length(x = cdr(ex)); char *av[ac+1]; if (ac == 0) return Nil; av[0] = alloc(NULL, pathSize(y = evSym(x))), pathString(y, av[0]); for (i = 1; isCell(x = cdr(x)); ++i) av[i] = alloc(NULL, bufSize(y = evSym(x))), bufString(y, av[i]); av[ac] = NULL; flushAll(); if ((pid = fork()) == 0) { setpgid(0,0); execvp(av[0], av); execError(av[0]); } i = 0; do free(av[i]); while (++i < ac); if (pid < 0) err(ex, NULL, "fork"); setpgid(pid,0); if (Termio) tcsetpgrp(0,pid); for (;;) { while (waitpid(pid, &res, WUNTRACED) < 0) { if (errno != EINTR) err(ex, NULL, "wait pid"); if (*Signal) sighandler(ex); } if (Termio) tcsetpgrp(0,getpgrp()); if (!WIFSTOPPED(res)) return res == 0? T : Nil; load(NULL, '+', Nil); if (Termio) tcsetpgrp(0,pid); kill(pid, SIGCONT); } } // (tick (cnt1 . cnt2) . prg) -> any any doTick(any ex) { any x; clock_t n1, n2, save1, save2; struct tms tim; static clock_t ticks1, ticks2; save1 = ticks1, save2 = ticks2; times(&tim), n1 = tim.tms_utime, n2 = tim.tms_stime; x = prog(cddr(ex)); times(&tim); n1 = (tim.tms_utime - n1) - (ticks1 - save1); n2 = (tim.tms_stime - n2) - (ticks2 - save2); setDig(caadr(ex), unDig(caadr(ex)) + 2*n1); setDig(cdadr(ex), unDig(cdadr(ex)) + 2*n2); ticks1 += n1, ticks2 += n2; return x; } // (ipid) -> pid | NIL any doIpid(any ex __attribute__((unused))) { if (Env.inFrames && Env.inFrames->pid > 1) return boxCnt((long)Env.inFrames->pid); return Nil; } // (opid) -> pid | NIL any doOpid(any ex __attribute__((unused))) { if (Env.outFrames && Env.outFrames->pid > 1) return boxCnt((long)Env.outFrames->pid); return Nil; } // (kill 'pid ['cnt]) -> flg any doKill(any ex) { pid_t pid; pid = (pid_t)evCnt(ex,cdr(ex)); return kill(pid, isCell(cddr(ex))? (int)evCnt(ex,cddr(ex)) : SIGTERM)? Nil : T; } static void allocChildren(void) { int i; Child = alloc(Child, (Children + 8) * sizeof(child)); for (i = 0; i < 8; ++i) Child[Children++].pid = 0; } pid_t forkLisp(any ex) { pid_t n; int i, hear[2], tell[2]; static int mic[2]; flushAll(); if (!Spkr) { if (pipe(mic) < 0) pipeError(ex, "open"); closeOnExec(ex, mic[0]), closeOnExec(ex, mic[1]); Spkr = mic[0]; } if (pipe(hear) < 0 || pipe(tell) < 0) pipeError(ex, "open"); closeOnExec(ex, hear[0]), closeOnExec(ex, hear[1]); closeOnExec(ex, tell[0]), closeOnExec(ex, tell[1]); for (i = 0; i < Children; ++i) if (!Child[i].pid) break; if ((n = fork()) < 0) err(ex, NULL, "fork"); if (n == 0) { void *p; Slot = i; Spkr = 0; Mic = mic[1]; close(hear[1]), close(tell[0]), close(mic[0]); if (Hear) close(Hear), closeInFile(Hear), closeOutFile(Hear); initInFile(Hear = hear[0], NULL); if (Tell) close(Tell); Tell = tell[1]; for (i = 0; i < Children; ++i) if (Child[i].pid) close(Child[i].hear), close(Child[i].tell), free(Child[i].buf); Children = 0, free(Child), Child = NULL; for (p = Env.inFrames; p; p = ((inFrame*)p)->link) ((inFrame*)p)->pid = 0; for (p = Env.outFrames; p; p = ((outFrame*)p)->link) ((outFrame*)p)->pid = 0; for (p = CatchPtr; p; p = ((catchFrame*)p)->link) ((catchFrame*)p)->fin = Zero; free(Termio), Termio = NULL; if (Repl) ++Repl; val(PPid) = val(Pid); val(Pid) = boxCnt(getpid()); run(val(Fork)); val(Fork) = Nil; return 0; } if (i == Children) allocChildren(); close(hear[0]), close(tell[1]); Child[i].pid = n; Child[i].hear = tell[0]; nonblocking(Child[i].tell = hear[1]); Child[i].ofs = Child[i].cnt = 0; Child[i].buf = NULL; return n; } // (fork) -> pid | NIL any doFork(any ex) { int n; return (n = forkLisp(ex))? boxCnt(n) : Nil; } // (bye 'cnt|NIL) any doBye(any ex) { any x = EVAL(cadr(ex)); bye(isNil(x)? 0 : xCnt(ex,x)); } picolisp-3.1.5.2.orig/src/gc.c0000644000000000000000000000726212265263724014503 0ustar rootroot/* 12oct10abu * (c) Software Lab. Alexander Burger */ #include "pico.h" /* Mark data */ static void mark(any x) { cell *p; while (num((p = cellPtr(x))->cdr) & 1) { *(word*)&cdr(p) &= ~1; if (!isNum(x)) mark(p->car); x = p->cdr; } } /* Garbage collector */ static void gc(long c) { any p, *pp, x; heap *h; int i; val(DB) = Nil; h = Heaps; do { p = h->cells + CELLS-1; do *(word*)&cdr(p) |= 1; while (--p >= h->cells); } while (h = h->next); /* Mark */ mark(Nil+1); mark(Alarm), mark(Sigio), mark(Line), mark(Zero), mark(One); for (i = 0; i < IHASH; ++i) mark(Intern[i]), mark(Transient[i]); mark(ApplyArgs), mark(ApplyBody); for (p = Env.stack; p; p = cdr(p)) mark(car(p)); for (p = (any)Env.bind; p; p = (any)((bindFrame*)p)->link) for (i = ((bindFrame*)p)->cnt; --i >= 0;) { mark(((bindFrame*)p)->bnd[i].sym); mark(((bindFrame*)p)->bnd[i].val); } for (p = (any)CatchPtr; p; p = (any)((catchFrame*)p)->link) { if (((catchFrame*)p)->tag) mark(((catchFrame*)p)->tag); mark(((catchFrame*)p)->fin); } for (i = 0; i < EHASH; ++i) for (p = Extern[i]; isCell(p); p = (any)(num(p->cdr) & ~1)) if (num(val(p->car)) & 1) { for (x = tail1(p->car); !isSym(x); x = cdr(cellPtr(x))); if ((x = (any)(num(x) & ~1)) == At2 || x == At3) mark(p->car); // Keep if dirty or deleted } if (num(val(val(DB) = DbVal)) & 1) { val(DbVal) = cdr(numCell(DbTail)) = Nil; tail(DbVal) = ext(DbTail); } for (i = 0; i < EHASH; ++i) for (pp = Extern + i; isCell(p = *pp);) if (num(val(p->car)) & 1) *pp = (cell*)(num(p->cdr) & ~1); else *(word*)(pp = &cdr(p)) &= ~1; /* Sweep */ Avail = NULL; h = Heaps; if (c) { do { p = h->cells + CELLS-1; do if (num(p->cdr) & 1) Free(p), --c; while (--p >= h->cells); } while (h = h->next); while (c >= 0) heapAlloc(), c -= CELLS; } else { heap **hp = &Heaps; cell *av; do { c = CELLS; av = Avail; p = h->cells + CELLS-1; do if (num(p->cdr) & 1) Free(p), --c; while (--p >= h->cells); if (c) hp = &h->next, h = h->next; else Avail = av, h = h->next, free(*hp), *hp = h; } while (h); } } // (gc ['cnt]) -> cnt | NIL any doGc(any x) { x = cdr(x); gc(isNum(x = EVAL(car(x)))? CELLS*unBox(x) : CELLS); return x; } /* Construct a cell */ any cons(any x, any y) { cell *p; if (!(p = Avail)) { cell c1, c2; Push(c1,x); Push(c2,y); gc(CELLS); drop(c1); p = Avail; } Avail = p->car; p->car = x; p->cdr = y; return p; } /* Construct a symbol */ any consSym(any v, any x) { cell *p; if (!(p = Avail)) { cell c1, c2; Push(c1,v); Push(c2,x); gc(CELLS); drop(c1); p = Avail; } Avail = p->car; p = symPtr(p); tail(p) = x; val(p) = v; return p; } /* Construct a string */ any consStr(any x) { cell *p; if (!(p = Avail)) { cell c1; Push(c1,x); gc(CELLS); drop(c1); p = Avail; } Avail = p->car; p = symPtr(p); tail(p) = x; val(p) = p; return p; } /* Construct a number cell */ any consNum(word n, any x) { cell *p; if (!(p = Avail)) { cell c1; Push(c1,x); gc(CELLS); drop(c1); p = Avail; } Avail = p->car; p->car = (any)n; p->cdr = x; return numPtr(p); } picolisp-3.1.5.2.orig/src/ht.c0000644000000000000000000001470512265263724014525 0ustar rootroot/* 18may12abu * (c) Software Lab. Alexander Burger */ #include "pico.h" // (ht:Prin 'sym ..) -> sym any Prin(any x) { any y = Nil; while (isCell(x = cdr(x))) { if (isNum(y = EVAL(car(x))) || isCell(y) || isExt(y)) prin(y); else { int c; char *p, nm[bufSize(y)]; bufString(y, nm); for (p = nm; *p;) { switch (*(byte*)p) { case '<': outString("<"); break; case '>': outString(">"); break; case '&': outString("&"); break; case '"': outString("""); break; case 0xFF: Env.put(0xEF); Env.put(0xBF); Env.put(0xBF); break; default: Env.put(c = *p); if ((c & 0x80) != 0) { Env.put(*++p); if ((c & 0x20) != 0) Env.put(*++p); } } ++p; } } } return y; } static void putHex(int c) { int n; Env.put('%'); if ((n = c >> 4 & 0xF) > 9) n += 7; Env.put(n + '0'); if ((n = c & 0xF) > 9) n += 7; Env.put(n + '0'); } static void htEncode(char *p) { int c; while (c = *p++) { if (strchr(" \"#%&:;<=>?_", c)) putHex(c); else { Env.put(c); if ((c & 0x80) != 0) { Env.put(*p++); if ((c & 0x20) != 0) Env.put(*p++); } } } } static void htFmt(any x) { any y; if (isNum(x)) Env.put('+'), prin(x); else if (isCell(x)) do Env.put('_'), htFmt(car(x)); while (isCell(x = cdr(x))); else if (isNum(y = name(x))) { char nm[bufSize(x)]; bufString(x, nm); if (isExt(x)) Env.put('-'), htEncode(nm); else if (hashed(x, Intern[ihash(y)])) Env.put('$'), htEncode(nm); else if (strchr("$+-", *nm)) { putHex(*nm); htEncode(nm+1); } else htEncode(nm); } } // (ht:Fmt 'any ..) -> sym any Fmt(any x) { int n, i; cell c[length(x = cdr(x))]; for (n = 0; isCell(x); ++n, x = cdr(x)) Push(c[n], EVAL(car(x))); begString(); for (i = 0; i < n;) { htFmt(data(c[i])); if (++i != n) Env.put('&'); } x = endString(); if (n) drop(c[0]); return x; } static int getHex(any *p) { int n, m; n = firstByte(car(*p)), *p = cdr(*p); if ((n -= '0') > 9) n = (n & 0xDF) - 7; m = firstByte(car(*p)), *p = cdr(*p); if ((m -= '0') > 9) m = (m & 0xDF) - 7; return n << 4 | m; } static bool head(char *s, any x) { while (*s) { if (*s++ != firstByte(car(x))) return NO; x = cdr(x); } return YES; } static int getUnicode(any *p) { int c, n = 0; any x = cdr(*p); while ((c = firstByte(car(x))) >= '0' && c <= '9') { n = n * 10 + c - '0'; x = cdr(x); } if (n && c == ';') { *p = cdr(x); return n; } return 0; } // (ht:Pack 'lst) -> sym any Pack(any x) { int c; cell c1; x = EVAL(cadr(x)); begString(); Push(c1,x); while (isCell(x)) { if ((c = firstByte(car(x))) == '%') x = cdr(x), Env.put(getHex(&x)); else if (c != '&') outName(car(x)), x = cdr(x); else if (head("lt;", x = cdr(x))) Env.put('<'), x = cdddr(x); else if (head("gt;", x)) Env.put('>'), x = cdddr(x); else if (head("amp;", x)) Env.put('&'), x = cddddr(x); else if (head("quot;", x)) Env.put('"'), x = cddr(cdddr(x)); else if (head("nbsp;", x)) Env.put(' '), x = cddr(cdddr(x)); else if (firstByte(car(x)) == '#' && (c = getUnicode(&x))) outName(mkChar(c)); else Env.put('&'); } return endString(); } /*** Read content length bytes */ // (ht:Read 'cnt) -> lst any Read(any ex) { any x; int n, c; cell c1; if ((n = evCnt(ex, cdr(ex))) <= 0) return Nil; if (!Chr) Env.get(); if (Chr < 0) return Nil; if ((c = getChar()) >= 128) { --n; if (c >= 2048) --n; } if (--n < 0) return Nil; Push(c1, x = cons(mkChar(c), Nil)); while (n) { Env.get(); if (Chr < 0) { data(c1) = Nil; break; } if ((c = getChar()) >= 128) { --n; if (c >= 2048) --n; } if (--n < 0) { data(c1) = Nil; break; } x = cdr(x) = cons(mkChar(c), Nil); } Chr = 0; return Pop(c1); } /*** Chunked Encoding ***/ #define CHUNK 4000 static int Cnt; static void (*Get)(void); static void (*Put)(int); static char Chunk[CHUNK]; static int chrHex(void) { if (Chr >= '0' && Chr <= '9') return Chr - 48; else if (Chr >= 'A' && Chr <= 'F') return Chr - 55; else if (Chr >= 'a' && Chr <= 'f') return Chr - 87; else return -1; } static void chunkSize(void) { int n; if (!Chr) Get(); if ((Cnt = chrHex()) >= 0) { while (Get(), (n = chrHex()) >= 0) Cnt = Cnt << 4 | n; while (Chr != '\n') { if (Chr < 0) return; Get(); } Get(); if (Cnt == 0) { Get(); // Skip '\r' of empty line Chr = 0; // Discard '\n' } } } static void getChunked(void) { if (Cnt <= 0) Chr = -1; else { Get(); if (--Cnt == 0) { Get(), Get(); // Skip '\n', '\r' chunkSize(); } } } // (ht:In 'flg . prg) -> any any In(any x) { x = cdr(x); if (isNil(EVAL(car(x)))) return prog(cdr(x)); Get = Env.get, Env.get = getChunked; chunkSize(); x = prog(cdr(x)); Env.get = Get; Chr = 0; return x; } static void wrChunk(void) { int i; char buf[BITS/2]; sprintf(buf, "%x\r\n", Cnt); i = 0; do Put(buf[i]); while (buf[++i]); for (i = 0; i < Cnt; ++i) Put(Chunk[i]); Put('\r'), Put('\n'); } static void putChunked(int c) { Chunk[Cnt++] = c; if (Cnt == CHUNK) wrChunk(), Cnt = 0; } // (ht:Out 'flg . prg) -> any any Out(any x) { x = cdr(x); if (isNil(EVAL(car(x)))) x = prog(cdr(x)); else { Cnt = 0; Put = Env.put, Env.put = putChunked; x = prog(cdr(x)); if (Cnt) wrChunk(); Env.put = Put; outString("0\r\n\r\n"); } flush(OutFile); return x; } picolisp-3.1.5.2.orig/src/httpGate.c0000644000000000000000000001673712265263724015701 0ustar rootroot/* 04feb13abu * (c) Software Lab. Alexander Burger */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include typedef enum {NO,YES} bool; static int Http1; static char Head_410[] = "HTTP/1.0 410 Gone\r\n" "Server: PicoLisp\r\n" "Content-Type: text/html; charset=utf-8\r\n" "\r\n"; static void giveup(char *msg) { fprintf(stderr, "httpGate: %s\n", msg); exit(2); } static inline bool pre(char *p, char *s) { while (*s) if (*p++ != *s++) return NO; return YES; } static int slow(SSL *ssl, int fd, char *p, int cnt) { int n; while ((n = ssl? SSL_read(ssl, p, cnt) : read(fd, p, cnt)) < 0) if (errno != EINTR) return 0; return n; } static int rdLine(SSL *ssl, int fd, char *p, int cnt) { int n, len; for (len = 0;;) { if ((n = ssl? SSL_read(ssl, p, cnt) : read(fd, p, cnt)) <= 0) { if (!n || errno != EINTR) return 0; } else { len += n; if (memchr(p, '\n', n)) return len; p += n; if ((cnt -= n) == 0) return 0; } } } static void wrBytes(int fd, char *p, int cnt) { int n; do if ((n = write(fd, p, cnt)) >= 0) p += n, cnt -= n; else if (errno != EINTR) exit(1); while (cnt); } static void sslWrite(SSL *ssl, void *p, int cnt) { if (SSL_write(ssl, p, cnt) <= 0) exit(1); } static int gatePort(unsigned short port) { int sd, n; struct sockaddr_in6 addr; if ((sd = socket(AF_INET6, SOCK_STREAM, 0)) < 0) exit(1); n = 0; if (setsockopt(sd, IPPROTO_IPV6, IPV6_V6ONLY, &n, sizeof(n)) < 0) exit(1); memset(&addr, 0, sizeof(addr)); addr.sin6_family = AF_INET6; addr.sin6_addr = in6addr_any; n = 1; if (setsockopt(sd, SOL_SOCKET, SO_REUSEADDR, &n, sizeof(n)) < 0) exit(1); addr.sin6_port = htons(port); if (bind(sd, (struct sockaddr*)&addr, sizeof(addr)) < 0) exit(1); if (listen(sd,5) < 0) exit(1); return sd; } static int gateConnect(unsigned short port) { int sd; struct sockaddr_in6 addr; if ((sd = socket(AF_INET6, SOCK_STREAM, 0)) < 0) exit(1); memset(&addr, 0, sizeof(addr)); addr.sin6_family = AF_INET6; addr.sin6_addr = in6addr_loopback; addr.sin6_port = htons(port); return connect(sd, (struct sockaddr*)&addr, sizeof(addr)) < 0? -1 : sd; } static pid_t Buddy; static void doSigAlarm(int n __attribute__((unused))) { kill(Buddy, SIGTERM); exit(0); } static void doSigUsr1(int n __attribute__((unused))) { alarm(420); } int main(int ac, char *av[]) { int cnt = ac>4? ac-3 : 1, ports[cnt], n, sd, cli, srv; struct sockaddr_in6 addr; char s[INET6_ADDRSTRLEN]; char *gate; SSL_CTX *ctx; SSL *ssl; if (ac < 3) giveup("port dflt [pem [alt ..]]"); sd = gatePort(atoi(av[1])); // e.g. 80 or 443 ports[0] = atoi(av[2]); // e.g. 8080 if (ac == 3 || *av[3] == '\0') ssl = NULL, gate = "X-Pil: *Gate=http\r\nX-Pil: *Adr=%s\r\n"; else { SSL_library_init(); SSL_load_error_strings(); if (!(ctx = SSL_CTX_new(SSLv23_server_method())) || !SSL_CTX_use_certificate_file(ctx, av[3], SSL_FILETYPE_PEM) || !SSL_CTX_use_PrivateKey_file(ctx, av[3], SSL_FILETYPE_PEM) || !SSL_CTX_check_private_key(ctx) ) { ERR_print_errors_fp(stderr); giveup("SSL init"); } ssl = SSL_new(ctx), gate = "X-Pil: *Gate=https\r\nX-Pil: *Adr=%s\r\n"; } for (n = 1; n < cnt; ++n) ports[n] = atoi(av[n+3]); signal(SIGCHLD,SIG_IGN); /* Prevent zombies */ if ((n = fork()) < 0) giveup("detach"); if (n) return 0; setsid(); for (;;) { socklen_t len = sizeof(addr); if ((cli = accept(sd, (struct sockaddr*)&addr, &len)) >= 0 && (n = fork()) >= 0) { if (!n) { int fd, port, i; char *p, *q, buf[4096], buf2[64]; close(sd); alarm(420); if (ssl) { SSL_set_fd(ssl, cli); if (SSL_accept(ssl) < 0) return 1; } n = rdLine(ssl, cli, buf, sizeof(buf)); alarm(0); if (n < 6) return 1; /* "GET /url HTTP/1.x" * "GET /8080/url HTTP/1.x" * "POST /url HTTP/1.x" * "POST /8080/url HTTP/1.x" */ if (pre(buf, "GET /")) p = buf + 5; else if (pre(buf, "POST /")) p = buf + 6; else return 1; port = (int)strtol(p, &q, 10); if (q == p || *q != ' ' && *q != '/') port = ports[0], q = p; else if (port < cnt) { if ((port = ports[port]) < 0) return 1; } else if (port < 1024) return 1; else for (i = 1; i < cnt; ++i) if (port == -ports[i]) return 1; if ((srv = gateConnect((unsigned short)port)) < 0) { if (!memchr(q,'~', buf + n - q)) return 1; if ((fd = open("void", O_RDONLY)) < 0) return 1; alarm(420); if (ssl) sslWrite(ssl, Head_410, strlen(Head_410)); else wrBytes(cli, Head_410, strlen(Head_410)); alarm(0); while ((n = read(fd, buf, sizeof(buf))) > 0) { alarm(420); if (ssl) sslWrite(ssl, buf, n); else wrBytes(cli, buf, n); alarm(0); } return 0; } Http1 = 0; wrBytes(srv, buf, p - buf); if (*q == '/') ++q; p = q; while (*p++ != '\n') if (p >= buf + n) return 1; wrBytes(srv, q, p - q); if (pre(p-10, "HTTP/1.")) Http1 = *(p-3) - '0'; inet_ntop(AF_INET6, &addr.sin6_addr, s, INET6_ADDRSTRLEN); wrBytes(srv, buf2, sprintf(buf2, gate, s)); wrBytes(srv, p, buf + n - p); signal(SIGALRM, doSigAlarm); signal(SIGUSR1, doSigUsr1); if (Buddy = fork()) { for (;;) { alarm(420); n = slow(ssl, cli, buf, sizeof(buf)); alarm(0); if (!n) break; wrBytes(srv, buf, n); } shutdown(cli, SHUT_RD); shutdown(srv, SHUT_WR); } else { Buddy = getppid(); while ((n = read(srv, buf, sizeof(buf))) > 0) { kill(Buddy, SIGUSR1); alarm(420); if (ssl) sslWrite(ssl, buf, n); else wrBytes(cli, buf, n); alarm(0); } shutdown(srv, SHUT_RD); shutdown(cli, SHUT_WR); } return 0; } close(cli); } } } picolisp-3.1.5.2.orig/src/io.c0000644000000000000000000025027712265263724014527 0ustar rootroot/* 11dec13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" #ifdef __CYGWIN__ #include #define fcntl(fd,cmd,fl) 0 #endif static any read0(bool); // I/O Tokens enum {NIX, BEG, DOT, END}; enum {NUMBER, INTERN, TRANSIENT, EXTERN}; static char Delim[] = " \t\n\r\"'(),[]`~{}"; static int StrI; static cell StrCell, *StrP; static bool Sync; static pid_t Talking; static byte *PipeBuf, *PipePtr; static void (*PutSave)(int); static byte TBuf[] = {INTERN+4, 'T'}; static void openErr(any ex, char *s) {err(ex, NULL, "%s open: %s", s, strerror(errno));} static void closeErr(void) {err(NULL, NULL, "Close error: %s", strerror(errno));} static void eofErr(void) {err(NULL, NULL, "EOF Overrun");} static void badInput(void) {err(NULL, NULL, "Bad input '%c'", Chr);} static void badFd(any ex, any x) {err(ex, x, "Bad FD");} static void lockErr(void) {err(NULL, NULL, "File lock: %s", strerror(errno));} static void writeErr(char *s) {err(NULL, NULL, "%s write: %s", s, strerror(errno));} static void selectErr(any ex) {err(ex, NULL, "Select error: %s", strerror(errno));} static void lockFile(int fd, int cmd, int typ) { struct flock fl; fl.l_type = typ; fl.l_whence = SEEK_SET; fl.l_start = 0; fl.l_len = 0; while (fcntl(fd, cmd, &fl) < 0 && typ != F_UNLCK) if (errno != EINTR) lockErr(); } void closeOnExec(any ex, int fd) { if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) err(ex, NULL, "SETFD %s", strerror(errno)); } int nonblocking(int fd) { int flg = fcntl(fd, F_GETFL, 0); fcntl(fd, F_SETFL, flg | O_NONBLOCK); return flg; } inFile *initInFile(int fd, char *nm) { inFile *p; if (fd >= InFDs) { int i = InFDs; InFiles = alloc(InFiles, (InFDs = fd + 1) * sizeof(inFile*)); do InFiles[i] = NULL; while (++i < InFDs); } p = InFiles[fd] = alloc(InFiles[fd], sizeof(inFile)); p->fd = fd; p->ix = p->cnt = p->next = 0; p->line = p->src = 1; p->name = nm; return p; } outFile *initOutFile(int fd) { outFile *p; if (fd >= OutFDs) { int i = OutFDs; OutFiles = alloc(OutFiles, (OutFDs = fd + 1) * sizeof(outFile*)); do OutFiles[i] = NULL; while (++i < OutFDs); } p = OutFiles[fd] = alloc(OutFiles[fd], sizeof(outFile)); p->tty = isatty(p->fd = fd); p->ix = 0; return p; } void closeInFile(int fd) { inFile *p; if (fd < InFDs && (p = InFiles[fd])) { if (p == InFile) InFile = NULL; free(p->name), free(p), InFiles[fd] = NULL; } } void closeOutFile(int fd) { outFile *p; if (fd < OutFDs && (p = OutFiles[fd])) { if (p == OutFile) OutFile = NULL; free(p), OutFiles[fd] = NULL; } } int slow(inFile *p, bool nb) { int n, f; p->ix = p->cnt = 0; for (;;) { if (nb) f = nonblocking(p->fd); n = read(p->fd, p->buf, BUFSIZ); if (nb) fcntl(p->fd, F_SETFL, f); if (n > 0) return p->cnt = n; if (n == 0) { p->ix = p->cnt = -1; return 0; } if (errno == EAGAIN) return -1; if (errno != EINTR) return 0; if (*Signal) sighandler(NULL); } } int rdBytes(int fd, byte *p, int cnt, bool nb) { int n, f; for (;;) { if (nb) f = nonblocking(fd); n = read(fd, p, cnt); if (nb) fcntl(fd, F_SETFL, f); if (n > 0) { for (;;) { if ((cnt -= n) == 0) return 1; p += n; while ((n = read(fd, p, cnt)) <= 0) { if (!n || errno != EINTR) return 0; if (*Signal) sighandler(NULL); } } } if (n == 0) return 0; if (errno == EAGAIN) return -1; if (errno != EINTR) return 0; if (*Signal) sighandler(NULL); } } bool wrBytes(int fd, byte *p, int cnt) { int n; for (;;) { if ((n = write(fd, p, cnt)) >= 0) { if ((cnt -= n) == 0) return YES; p += n; } else { if (errno == EBADF || errno == EPIPE || errno == ECONNRESET) return NO; if (errno != EINTR) { if (fd == STDERR_FILENO) bye(2); writeErr("bytes"); } if (*Signal) sighandler(NULL); } } } static void clsChild(int i) { if (Child[i].pid == Talking) Talking = 0; Child[i].pid = 0; close(Child[i].hear), close(Child[i].tell); free(Child[i].buf); } static void wrChild(int i, byte *p, int cnt) { int n; if (Child[i].cnt == 0) { for (;;) { if ((n = write(Child[i].tell, p, cnt)) >= 0) { if ((cnt -= n) == 0) return; p += n; } else if (errno == EAGAIN) break; else if (errno == EPIPE || errno == ECONNRESET) { clsChild(i); return; } else if (errno != EINTR) writeErr("child"); } } n = Child[i].cnt; Child[i].buf = alloc(Child[i].buf, n + sizeof(int) + cnt); *(int*)(Child[i].buf + n) = cnt; memcpy(Child[i].buf + n + sizeof(int), p, cnt); Child[i].cnt += sizeof(int) + cnt; } bool flush(outFile *p) { int n; if (p && (n = p->ix)) { p->ix = 0; return wrBytes(p->fd, p->buf, n); } return YES; } void flushAll(void) { int i; for (i = 0; i < OutFDs; ++i) flush(OutFiles[i]); } /*** Low level I/O ***/ static int stdinByte(void) { inFile *p; if ((p = InFiles[STDIN_FILENO]) && (p->ix != p->cnt || (p->ix >= 0 && slow(p,NO)))) return p->buf[p->ix++]; if (!isatty(STDIN_FILENO)) return -1; bye(0); } static int getBinary(void) { if (!InFile || InFile->ix == InFile->cnt && (InFile->ix < 0 || !slow(InFile,NO))) return -1; return InFile->buf[InFile->ix++]; } static any rdNum(int cnt) { int n, i; any x; cell c1; if ((n = getBin()) < 0) return NULL; i = 0, Push(c1, x = box(n)); if (--cnt == 62) { do { do { if ((n = getBin()) < 0) return NULL; byteSym(n, &i, &x); } while (--cnt); if ((cnt = getBin()) < 0) return NULL; } while (cnt == 255); } while (--cnt >= 0) { if ((n = getBin()) < 0) return NULL; byteSym(n, &i, &x); } return Pop(c1); } any binRead(int extn) { int c; any x, y, *h; cell c1; if ((c = getBin()) < 0) return NULL; if ((c & ~3) == 0) { if (c == NIX) return Nil; if (c == BEG) { if ((x = binRead(extn)) == NULL) return NULL; Push(c1, x = cons(x,Nil)); while ((y = binRead(extn)) != (any)END) { if (y == NULL) { drop(c1); return NULL; } if (y == (any)DOT) { if ((y = binRead(extn)) == NULL) { drop(c1); return NULL; } cdr(x) = y == (any)END? data(c1) : y; break; } x = cdr(x) = cons(y,Nil); } return Pop(c1); } return (any)(long)c; // DOT or END } if ((y = rdNum(c / 4)) == NULL) return NULL; if ((c &= 3) == NUMBER) return y; if (c == TRANSIENT) return consStr(y); if (c == EXTERN) { if (extn) y = extOffs(extn, y); if (x = findHash(y, h = Extern + ehash(y))) return x; mkExt(x = consSym(Nil,y)); *h = cons(x,*h); return x; } if (x = findHash(y, h = Intern + ihash(y))) return x; x = consSym(Nil,y); *h = cons(x,*h); return x; } static void prDig(int t, word n) { int i = 1; word m = MASK; while (n & (m <<= 8)) ++i; putBin(i*4+t); while (putBin(n), --i) n >>= 8; } static int numByte(any s) { static int i; static any x; static word n; if (s) i = 0, n = unDig(x = s); else if (n >>= 8, (++i & sizeof(word)-1) == 0) n = unDig(x = cdr(numCell(x))); return n & 0xFF; } static void prNum(int t, any x) { int cnt, i; if (!isNum(cdr(numCell(x)))) prDig(t, unDig(x)); else if ((cnt = numBytes(x)) < 63) { putBin(cnt*4+t); putBin(numByte(x)); while (--cnt) putBin(numByte(NULL)); } else { putBin(63*4+t); putBin(numByte(x)); for (i = 1; i < 63; ++i) putBin(numByte(NULL)); cnt -= 63; while (cnt >= 255) { putBin(255); for (i = 0; i < 255; ++i) putBin(numByte(NULL)); cnt -= 255; } putBin(cnt); while (--cnt >= 0) putBin(numByte(NULL)); } } void binPrint(int extn, any x) { any y; if (isNum(x)) prNum(NUMBER, x); else if (isNil(x)) putBin(NIX); else if (isSym(x)) { if (!isNum(y = name(x))) binPrint(extn, y); else if (!isExt(x)) prNum(hashed(x, Intern[ihash(y)])? INTERN : TRANSIENT, y); else prNum(EXTERN, extn? extOffs(-extn, y) : y); } else { putBin(BEG); if ((y = circ(x)) == NULL) { while (binPrint(extn, car(x)), !isNil(x = cdr(x))) { if (!isCell(x)) { putBin(DOT); binPrint(extn, x); return; } } } else if (y == x) { do binPrint(extn, car(x)); while (y != (x = cdr(x))); putBin(DOT); } else { do binPrint(extn, car(x)); while (y != (x = cdr(x))); putBin(DOT), putBin(BEG); do binPrint(extn, car(x)); while (y != (x = cdr(x))); putBin(DOT), putBin(END); } putBin(END); } } void pr(int extn, any x) {putBin = putStdout, binPrint(extn, x);} void prn(long n) { putBin = putStdout; prDig(NUMBER, n >= 0? n * 2 : -n * 2 + 1); } /* Family IPC */ static void putTell(int c) { *PipePtr++ = c; if (PipePtr == PipeBuf + PIPE_BUF - 1) // END err(NULL, NULL, "Tell PIPE_BUF"); } static void tellBeg(ptr *pb, ptr *pp, ptr buf) { *pb = PipeBuf, *pp = PipePtr; PipePtr = (PipeBuf = buf) + sizeof(int); *PipePtr++ = BEG; } static void prTell(any x) {putBin = putTell, binPrint(0, x);} static void tellEnd(ptr *pb, ptr *pp, int pid) { int i, n; *PipePtr++ = END; *(int*)PipeBuf = (n = PipePtr - PipeBuf - sizeof(int)) | pid << 16; if (Tell && !wrBytes(Tell, PipeBuf, n+sizeof(int))) close(Tell), Tell = 0; for (i = 0; i < Children; ++i) if (Child[i].pid && (!pid || pid == Child[i].pid)) wrChild(i, PipeBuf+sizeof(int), n); PipePtr = *pp, PipeBuf = *pb; } static void unsync(void) { int n = 0; if (Tell && !wrBytes(Tell, (byte*)&n, sizeof(int))) close(Tell), Tell = 0; Sync = NO; } static any rdHear(void) { any x; inFile *iSave = InFile; InFile = InFiles[Hear]; getBin = getBinary; x = binRead(0); InFile = iSave; return x; } /* Return next byte from symbol name */ int symByte(any s) { static any x; static word n; if (s) { if (!isNum(x = s)) return 0; n = unDig(x); } else if ((n >>= 8) == 0) { if (!isNum(cdr(numCell(x)))) return 0; n = unDig(x = cdr(numCell(x))); } return n & 0xFF; } /* Return next char from symbol name */ int symChar(any s) { int c = symByte(s); if (c == 0xFF) return TOP; if (c & 0x80) { if ((c & 0x20) == 0) c &= 0x1F; else c = (c & 0xF) << 6 | symByte(NULL) & 0x3F; c = c << 6 | symByte(NULL) & 0x3F; } return c; } int numBytes(any x) { int cnt; word n, m = MASK; for (cnt = 1; isNum(cdr(numCell(x))); cnt += WORD) x = cdr(numCell(x)); for (n = unDig(x); n & (m <<= 8); ++cnt); return cnt; } /* Buffer size */ int bufSize(any x) {return isNum(x = name(x))? numBytes(x)+1 : 1;} int pathSize(any x) { int c = firstByte(x); if (c != '@' && (c != '+' || secondByte(x) != '@')) return bufSize(x); if (!Home) return numBytes(name(x)); return strlen(Home) + numBytes(name(x)); } void bufString(any x, char *p) { int c = symByte(name(x)); while (*p++ = c) c = symByte(NULL); } void pathString(any x, char *p) { int c; char *h; if ((c = symByte(name(x))) == '+') *p++ = c, c = symByte(NULL); if (c != '@') while (*p++ = c) c = symByte(NULL); else { if (h = Home) do *p++ = *h++; while (*h); while (*p++ = symByte(NULL)); } } // (path 'any) -> sym any doPath(any x) { x = evSym(cdr(x)); { char nm[pathSize(x)]; pathString(x,nm); return mkStr(nm); } } /* Add next byte to symbol name */ void byteSym(int c, int *i, any *p) { if ((*i += 8) < BITS) setDig(*p, unDig(*p) | (c & 0xFF) << *i); else *i = 0, *p = cdr(numCell(*p)) = box(c & 0xFF); } /* Box first char of symbol name */ any boxChar(int c, int *i, any *p) { *i = 0; if (c < 0x80) *p = box(c); else if (c < 0x800) { *p = box(0xC0 | c>>6 & 0x1F); byteSym(0x80 | c & 0x3F, i, p); } else if (c == TOP) *p = box(0xFF); else { *p = box(0xE0 | c>>12 & 0x0F); byteSym(0x80 | c>>6 & 0x3F, i, p); byteSym(0x80 | c & 0x3F, i, p); } return *p; } /* Add next char to symbol name */ void charSym(int c, int *i, any *p) { if (c < 0x80) byteSym(c, i, p); else if (c < 0x800) { byteSym(0xC0 | c>>6 & 0x1F, i, p); byteSym(0x80 | c & 0x3F, i, p); } else if (c == TOP) byteSym(0xFF, i, p); else { byteSym(0xE0 | c>>12 & 0x0F, i, p); byteSym(0x80 | c>>6 & 0x3F, i, p); byteSym(0x80 | c & 0x3F, i, p); } } static int currFd(any ex, char *p) { if (!Env.inFrames && !Env.outFrames) err(ex, NULL, "No current fd"); if (!Env.inFrames) return OutFile->fd; if (!Env.outFrames) return InFile->fd; return labs((char*)Env.outFrames - p) > labs((char*)Env.inFrames - p)? InFile->fd : OutFile->fd; } void rdOpen(any ex, any x, inFrame *f) { if (isNil(x)) f->pid = 0, f->fd = STDIN_FILENO; else if (isNum(x)) { int n = (int)unBox(x); if (n < 0) { inFrame *g = Env.inFrames; for (;;) { if (!(g = g->link)) badFd(ex,x); if (!++n) { n = g->fd; break; } } } f->pid = 0, f->fd = n; if (n >= InFDs || !InFiles[n]) badFd(ex,x); } else if (isSym(x)) { char nm[pathSize(x)]; f->pid = 1; pathString(x,nm); if (nm[0] == '+') { while ((f->fd = open(nm+1, O_APPEND|O_CREAT|O_RDWR, 0666)) < 0) { if (errno != EINTR) openErr(ex, nm); if (*Signal) sighandler(ex); } initInFile(f->fd, strdup(nm+1)); } else { while ((f->fd = open(nm, O_RDONLY)) < 0) { if (errno != EINTR) openErr(ex, nm); if (*Signal) sighandler(ex); } initInFile(f->fd, strdup(nm)); } closeOnExec(ex, f->fd); } else { any y; int i, pfd[2], ac = length(x); char *av[ac+1]; if (pipe(pfd) < 0) pipeError(ex, "read open"); closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]); av[0] = alloc(NULL, pathSize(y = xSym(car(x)))), pathString(y, av[0]); for (i = 1; isCell(x = cdr(x)); ++i) av[i] = alloc(NULL, bufSize(y = xSym(car(x)))), bufString(y, av[i]); av[ac] = NULL; if ((f->pid = fork()) == 0) { setpgid(0,0); close(pfd[0]); if (pfd[1] != STDOUT_FILENO) dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); execvp(av[0], av); execError(av[0]); } i = 0; do free(av[i]); while (++i < ac); if (f->pid < 0) err(ex, NULL, "fork"); setpgid(f->pid,0); close(pfd[1]); initInFile(f->fd = pfd[0], NULL); } } void wrOpen(any ex, any x, outFrame *f) { if (isNil(x)) f->pid = 0, f->fd = STDOUT_FILENO; else if (isNum(x)) { int n = (int)unBox(x); if (n < 0) { outFrame *g = Env.outFrames; for (;;) { if (!(g = g->link)) badFd(ex,x); if (!++n) { n = g->fd; break; } } } f->pid = 0, f->fd = n; if (n >= OutFDs || !OutFiles[n]) badFd(ex,x); } else if (isSym(x)) { char nm[pathSize(x)]; f->pid = 1; pathString(x,nm); if (nm[0] == '+') { while ((f->fd = open(nm+1, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0) { if (errno != EINTR) openErr(ex, nm); if (*Signal) sighandler(ex); } } else { while ((f->fd = open(nm, O_CREAT|O_TRUNC|O_WRONLY, 0666)) < 0) { if (errno != EINTR) openErr(ex, nm); if (*Signal) sighandler(ex); } } closeOnExec(ex, f->fd); initOutFile(f->fd); } else { any y; int i, pfd[2], ac = length(x); char *av[ac+1]; if (pipe(pfd) < 0) pipeError(ex, "write open"); closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]); av[0] = alloc(NULL, pathSize(y = xSym(car(x)))), pathString(y, av[0]); for (i = 1; isCell(x = cdr(x)); ++i) av[i] = alloc(NULL, bufSize(y = xSym(car(x)))), bufString(y, av[i]); av[ac] = NULL; if ((f->pid = fork()) == 0) { setpgid(0,0); close(pfd[1]); if (pfd[0] != STDIN_FILENO) dup2(pfd[0], STDIN_FILENO), close(pfd[0]); execvp(av[0], av); execError(av[0]); } i = 0; do free(av[i]); while (++i < ac); if (f->pid < 0) err(ex, NULL, "fork"); setpgid(f->pid,0); close(pfd[0]); initOutFile(f->fd = pfd[1]); } } void erOpen(any ex, any x, errFrame *f) { int fd; NeedSym(ex,x); f->fd = dup(STDERR_FILENO); if (isNil(x)) fd = dup(OutFile->fd); else { char nm[pathSize(x)]; pathString(x,nm); if (nm[0] == '+') { while ((fd = open(nm+1, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0) { if (errno != EINTR) openErr(ex, nm); if (*Signal) sighandler(ex); } } else { while ((fd = open(nm, O_CREAT|O_TRUNC|O_WRONLY, 0666)) < 0) { if (errno != EINTR) openErr(ex, nm); if (*Signal) sighandler(ex); } } closeOnExec(ex, fd); } dup2(fd, STDERR_FILENO), close(fd); } void ctOpen(any ex, any x, ctlFrame *f) { NeedSym(ex,x); if (isNil(x)) { f->fd = -1; lockFile(currFd(ex, (char*)f), F_SETLKW, F_RDLCK); } else if (x == T) { f->fd = -1; lockFile(currFd(ex, (char*)f), F_SETLKW, F_WRLCK); } else { char nm[pathSize(x)]; pathString(x,nm); if (nm[0] == '+') { while ((f->fd = open(nm+1, O_CREAT|O_RDWR, 0666)) < 0) { if (errno != EINTR) openErr(ex, nm); if (*Signal) sighandler(ex); } lockFile(f->fd, F_SETLKW, F_RDLCK); } else { while ((f->fd = open(nm, O_CREAT|O_RDWR, 0666)) < 0) { if (errno != EINTR) openErr(ex, nm); if (*Signal) sighandler(ex); } lockFile(f->fd, F_SETLKW, F_WRLCK); } closeOnExec(ex, f->fd); } } /*** Reading ***/ void getStdin(void) { if (!InFile) Chr = -1; else if (InFile != InFiles[STDIN_FILENO]) { if (InFile->ix == InFile->cnt && (InFile->ix < 0 || !slow(InFile,NO))) { Chr = -1; return; } if ((Chr = InFile->buf[InFile->ix++]) == '\n') ++InFile->line; } else if (!isCell(val(Led))) { waitFd(NULL, STDIN_FILENO, -1); Chr = stdinByte(); } else { static word dig; if (!isNum(Line)) dig = isNum(Line = name(run(val(Led))))? unDig(Line) : '\n'; else if ((dig >>= 8) == 0) dig = isNum(Line = cdr(numCell(Line)))? unDig(Line) : '\n'; Chr = dig & 0xFF; } } static void getParse(void) { if ((Chr = Env.parser->dig & 0xFF) == 0xFF) Chr = -1; else if ((Env.parser->dig >>= 8) == 0) { Env.parser->dig = isNum(Env.parser->name = cdr(numCell(Env.parser->name))) ? unDig(Env.parser->name) : Env.parser->eof; } } void pushInFiles(inFrame *f) { if (InFile) InFile->next = Chr; Chr = (InFile = InFiles[f->fd])? InFile->next : -1; f->get = Env.get, Env.get = getStdin; f->link = Env.inFrames, Env.inFrames = f; } void pushOutFiles(outFrame *f) { OutFile = OutFiles[f->fd]; f->put = Env.put, Env.put = putStdout; f->link = Env.outFrames, Env.outFrames = f; } void pushErrFiles(errFrame *f) { f->link = Env.errFrames, Env.errFrames = f; } void pushCtlFiles(ctlFrame *f) { f->link = Env.ctlFrames, Env.ctlFrames = f; } void popInFiles(void) { if (Env.inFrames->pid) { close(Env.inFrames->fd), closeInFile(Env.inFrames->fd); if (Env.inFrames->pid > 1) while (waitpid(Env.inFrames->pid, NULL, 0) < 0) { if (errno != EINTR) closeErr(); if (*Signal) sighandler(NULL); } } else if (InFile) InFile->next = Chr; Env.get = Env.inFrames->get; Chr = (InFile = InFiles[(Env.inFrames = Env.inFrames->link)? Env.inFrames->fd : STDIN_FILENO])? InFile->next : -1; } void popOutFiles(void) { flush(OutFile); if (Env.outFrames->pid) { close(Env.outFrames->fd), closeOutFile(Env.outFrames->fd); if (Env.outFrames->pid > 1) while (waitpid(Env.outFrames->pid, NULL, 0) < 0) { if (errno != EINTR) closeErr(); if (*Signal) sighandler(NULL); } } Env.put = Env.outFrames->put; OutFile = OutFiles[(Env.outFrames = Env.outFrames->link)? Env.outFrames->fd : STDOUT_FILENO]; } void popErrFiles(void) { dup2(Env.errFrames->fd, STDERR_FILENO); close(Env.errFrames->fd); Env.errFrames = Env.errFrames->link; } void popCtlFiles(void) { if (Env.ctlFrames->fd >= 0) close(Env.ctlFrames->fd); else lockFile(currFd(NULL, (char*)Env.ctlFrames), F_SETLK, F_UNLCK); Env.ctlFrames = Env.ctlFrames->link; } /* Get full char from input channel */ int getChar(void) { int c; if ((c = Chr) == 0xFF) return TOP; if (c & 0x80) { Env.get(); if ((c & 0x20) == 0) c &= 0x1F; else c = (c & 0xF) << 6 | Chr & 0x3F, Env.get(); if (Chr < 0) eofErr(); c = c << 6 | Chr & 0x3F; } return c; } /* Skip White Space and Comments */ static int skipc(int c) { if (Chr < 0) return Chr; for (;;) { while (Chr <= ' ') { Env.get(); if (Chr < 0) return Chr; } if (Chr != c) return Chr; Env.get(); while (Chr != '\n') { if (Chr < 0) return Chr; Env.get(); } } } static void comment(void) { Env.get(); if (Chr != '{') { while (Chr != '\n') { if (Chr < 0) return; Env.get(); } } else { for (;;) { // #{block-comment}# from Kriangkrai Soatthiyanont Env.get(); if (Chr < 0) return; if (Chr == '}' && (Env.get(), Chr == '#')) break; } Env.get(); } } static int skip(void) { for (;;) { if (Chr < 0) return Chr; while (Chr <= ' ') { Env.get(); if (Chr < 0) return Chr; } if (Chr != '#') return Chr; comment(); } } /* Test for escaped characters */ static bool testEsc(void) { for (;;) { if (Chr < 0) return NO; if (Chr == '^') { Env.get(); if (Chr == '@') badInput(); if (Chr == '?') Chr = 127; else Chr &= 0x1F; return YES; } if (Chr != '\\') return YES; if (Env.get(), Chr != '\n') return YES; do Env.get(); while (Chr == ' ' || Chr == '\t'); } } /* Try for anonymous symbol */ static any anonymous(any s) { unsigned c; unsigned long n; heap *h; if ((c = symByte(s)) != '$') return NULL; n = 0; while (c = symByte(NULL)) { if (c < '0' || c > '9') return NULL; n = n * 10 + c - '0'; } n *= sizeof(cell); h = Heaps; do if ((any)n >= h->cells && (any)n < h->cells + CELLS) return symPtr((any)n); while (h = h->next); return NULL; } /* Read an atom */ static any rdAtom(int c) { int i; any x, y, *h; cell c1; i = 0, Push(c1, y = box(c)); while (Chr > 0 && !strchr(Delim, Chr)) { if (Chr == '\\') Env.get(); byteSym(Chr, &i, &y); Env.get(); } y = Pop(c1); if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N')) return Nil; if (x = symToNum(y, (int)unDig(val(Scl)) / 2, '.', 0)) return x; if (x = anonymous(y)) return x; if (x = findHash(y, h = Intern + ihash(y))) return x; x = consSym(Nil,y); *h = cons(x,*h); return x; } /* Read a list */ static any rdList(void) { any x; cell c1; Env.get(); for (;;) { if (skip() == ')') { Env.get(); return Nil; } if (Chr == ']') return Nil; if (Chr != '~') { Push(c1, x = cons(read0(NO),Nil)); break; } Env.get(); Push(c1, read0(NO)); if (isCell(x = data(c1) = EVAL(data(c1)))) { while (isCell(cdr(x))) x = cdr(x); break; } drop(c1); } for (;;) { if (skip() == ')') { Env.get(); break; } if (Chr == ']') break; if (Chr == '.') { Env.get(); if (strchr(Delim, Chr)) { cdr(x) = skip()==')' || Chr==']'? data(c1) : read0(NO); if (skip() == ')') Env.get(); else if (Chr != ']') err(NULL, x, "Bad dotted pair"); break; } x = cdr(x) = cons(rdAtom('.'), Nil); } else if (Chr != '~') x = cdr(x) = cons(read0(NO), Nil); else { Env.get(); cdr(x) = read0(NO); cdr(x) = EVAL(cdr(x)); while (isCell(cdr(x))) x = cdr(x); } } return Pop(c1); } /* Read one expression */ static any read0(bool top) { int i; any x, y, *h; cell c1; if (skip() < 0) { if (top) return Nil; eofErr(); } if (top && InFile) InFile->src = InFile->line; if (Chr == '(') { x = rdList(); if (top && Chr == ']') Env.get(); return x; } if (Chr == '[') { x = rdList(); if (Chr != ']') err(NULL, x, "Super parentheses mismatch"); Env.get(); return x; } if (Chr == '\'') { Env.get(); return cons(Quote, read0(top)); } if (Chr == ',') { Env.get(); x = read0(top); if (val(Uni) != T) { Push(c1, x); if (isCell(y = idx(Uni, data(c1), 1))) x = car(y); drop(c1); } return x; } if (Chr == '`') { Env.get(); Push(c1, read0(top)); x = EVAL(data(c1)); drop(c1); return x; } if (Chr == '"') { Env.get(); if (Chr == '"') { Env.get(); return Nil; } if (!testEsc()) eofErr(); i = 0, Push(c1, y = box(Chr)); while (Env.get(), Chr != '"') { if (!testEsc()) eofErr(); byteSym(Chr, &i, &y); } y = Pop(c1), Env.get(); if (x = findHash(y, h = Transient + ihash(y))) return x; x = consStr(y); *h = cons(x,*h); return x; } if (Chr == '{') { Env.get(); if (Chr == '}') { Env.get(); return consSym(Nil,Nil); } i = 0, Push(c1, y = box(Chr)); while (Env.get(), Chr != '}') { if (Chr < 0) eofErr(); byteSym(Chr, &i, &y); } y = Pop(c1), Env.get(); if (x = findHash(y, h = Extern + ehash(y))) return x; mkExt(x = consSym(Nil,y)); *h = cons(x,*h); return x; } if (Chr == ')' || Chr == ']' || Chr == '~') badInput(); if (Chr == '\\') Env.get(); i = Chr; Env.get(); return rdAtom(i); } any read1(int end) { if (!Chr) Env.get(); if (Chr == end) return Nil; return read0(YES); } /* Read one token */ any token(any x, int c) { int i; any y, *h; cell c1; if (!Chr) Env.get(); if (skipc(c) < 0) return NULL; if (Chr == '"') { Env.get(); if (Chr == '"') { Env.get(); return Nil; } if (!testEsc()) return Nil; Push(c1, y = cons(mkChar(Chr), Nil)); while (Env.get(), Chr != '"' && testEsc()) y = cdr(y) = cons(mkChar(Chr), Nil); Env.get(); return Pop(c1); } if (Chr >= '0' && Chr <= '9') { i = 0, Push(c1, y = box(Chr)); while (Env.get(), Chr >= '0' && Chr <= '9' || Chr == '.') byteSym(Chr, &i, &y); return symToNum(Pop(c1), (int)unDig(val(Scl)) / 2, '.', 0); } if (Chr != '+' && Chr != '-') { char nm[bufSize(x)]; bufString(x, nm); if (Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr)) { if (Chr == '\\') Env.get(); i = 0, Push(c1, y = box(Chr)); while (Env.get(), Chr >= '0' && Chr <= '9' || Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || strchr(nm,Chr) ) { if (Chr == '\\') Env.get(); byteSym(Chr, &i, &y); } y = Pop(c1); if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N')) return Nil; if (x = findHash(y, h = Intern + ihash(y))) return x; x = consSym(Nil,y); *h = cons(x,*h); return x; } } c = getChar(); Env.get(); return mkChar(c); } // (read ['sym1 ['sym2]]) -> any any doRead(any ex) { any x; if (!isCell(x = cdr(ex))) x = read1(0); else { cell c1; Push(c1, EVAL(car(x))); NeedSym(ex, data(c1)); x = cdr(x), x = EVAL(car(x)); NeedSym(ex,x); x = token(data(c1), symChar(name(x))) ?: Nil; drop(c1); } if (InFile == InFiles[STDIN_FILENO] && Chr == '\n') Chr = 0; return x; } static inline bool inReady(inFile *p) { return p->ix < p->cnt; } static bool isSet(int fd, fd_set *fds) { inFile *p; if (fd >= InFDs || !(p = InFiles[fd])) return FD_ISSET(fd, fds); if (inReady(p)) return YES; return FD_ISSET(fd, fds) && slow(p,YES) >= 0; } long waitFd(any ex, int fd, long ms) { any x, taskSave; cell c1, c2, c3; int i, j, m, n; long t; fd_set rdSet, wrSet; struct timeval *tp, tv; #ifndef __linux__ struct timeval tt; #endif taskSave = Env.task; Push(c1, val(At)); Save(c2); do { if (ms >= 0) t = ms, tp = &tv; else t = LONG_MAX, tp = NULL; FD_ZERO(&rdSet); FD_ZERO(&wrSet); m = 0; if (fd >= 0) { if (fd < InFDs && InFiles[fd] && inReady(InFiles[fd])) tp = &tv, t = 0; else FD_SET(m = fd, &rdSet); } for (x = data(c2) = Env.task = val(Run); isCell(x); x = cdr(x)) { if (!memq(car(x), taskSave)) { if (isNeg(caar(x))) { if ((n = (int)unDig(cadar(x)) / 2) < t) tp = &tv, t = n; } else if ((n = (int)unDig(caar(x)) / 2) != fd) { if (n < InFDs && InFiles[n] && inReady(InFiles[n])) tp = &tv, t = 0; else { FD_SET(n, &rdSet); if (n > m) m = n; } } } } if (Hear && Hear != fd && InFiles[Hear]) { if (inReady(InFiles[Hear])) tp = &tv, t = 0; else { FD_SET(Hear, &rdSet); if (Hear > m) m = Hear; } } if (Spkr) { FD_SET(Spkr, &rdSet); if (Spkr > m) m = Spkr; for (i = 0; i < Children; ++i) { if (Child[i].pid) { FD_SET(Child[i].hear, &rdSet); if (Child[i].hear > m) m = Child[i].hear; if (Child[i].cnt) { FD_SET(Child[i].tell, &wrSet); if (Child[i].tell > m) m = Child[i].tell; } } } } if (tp) { tv.tv_sec = t / 1000; tv.tv_usec = t % 1000 * 1000; #ifndef __linux__ gettimeofday(&tt,NULL); t = tt.tv_sec*1000 + tt.tv_usec/1000; #endif } while (select(m+1, &rdSet, &wrSet, NULL, tp) < 0) { if (errno != EINTR) { val(Run) = Nil; selectErr(ex); } if (*Signal) sighandler(ex); } if (tp) { #ifdef __linux__ t -= tv.tv_sec*1000 + tv.tv_usec/1000; #else gettimeofday(&tt,NULL); t = tt.tv_sec*1000 + tt.tv_usec/1000 - t; #endif if (ms > 0 && (ms -= t) < 0) ms = 0; } if (Spkr) { ++Env.protect; for (i = 0; i < Children; ++i) { if (Child[i].pid) { if (FD_ISSET(Child[i].hear, &rdSet)) { if ((m = rdBytes(Child[i].hear, (byte*)&n, sizeof(int), YES)) >= 0) { byte buf[PIPE_BUF - sizeof(int)]; if (m == 0) { clsChild(i); continue; } if (n == 0) { if (Child[i].pid == Talking) Talking = 0; } else { pid_t pid = n >> 16; n &= 0xFFFF; if (rdBytes(Child[i].hear, buf, n, NO)) { for (j = 0; j < Children; ++j) if (j != i && Child[j].pid && (!pid || pid == Child[j].pid)) wrChild(j, buf, n); } else { clsChild(i); continue; } } } } if (FD_ISSET(Child[i].tell, &wrSet)) { n = *(int*)(Child[i].buf + Child[i].ofs); if (wrBytes(Child[i].tell, Child[i].buf + Child[i].ofs + sizeof(int), n)) { Child[i].ofs += sizeof(int) + n; if (2 * Child[i].ofs >= Child[i].cnt) { if (Child[i].cnt -= Child[i].ofs) { memcpy(Child[i].buf, Child[i].buf + Child[i].ofs, Child[i].cnt); Child[i].buf = alloc(Child[i].buf, Child[i].cnt); } Child[i].ofs = 0; } } else clsChild(i); } } } if (!Talking && FD_ISSET(Spkr,&rdSet) && rdBytes(Spkr, (byte*)&m, sizeof(int), YES) > 0 && Child[m].pid ) { Talking = Child[m].pid; wrChild(m, TBuf, sizeof(TBuf)); } --Env.protect; } if (Hear && Hear != fd && isSet(Hear, &rdSet)) { if ((data(c3) = rdHear()) == NULL) close(Hear), closeInFile(Hear), closeOutFile(Hear), Hear = 0; else if (data(c3) == T) Sync = YES; else { Save(c3); evList(data(c3)); drop(c3); } } for (x = data(c2); isCell(x); x = cdr(x)) { if (!memq(car(x), taskSave)) { if (isNeg(caar(x))) { if ((n = (int)(unDig(cadar(x)) / 2 - t)) > 0) setDig(cadar(x), (long)2*n); else { setDig(cadar(x), unDig(caar(x))); val(At) = caar(x); prog(cddar(x)); } } else if ((n = (int)unDig(caar(x)) / 2) != fd) { if (isSet(n, &rdSet)) { val(At) = caar(x); prog(cdar(x)); } } } } if (*Signal) sighandler(ex); } while (ms && fd >= 0 && !isSet(fd, &rdSet)); Env.task = taskSave; val(At) = Pop(c1); return ms; } // (wait ['cnt] . prg) -> any any doWait(any ex) { any x, y; long ms; x = cdr(ex); ms = isNil(y = EVAL(car(x)))? -1 : xCnt(ex,y); x = cdr(x); while (isNil(y = prog(x))) if (!(ms = waitFd(ex, -1, ms))) return prog(x); return y; } // (sync) -> flg any doSync(any ex) { byte *p; int n, cnt; if (!Mic || !Hear) return Nil; if (Sync) return T; p = (byte*)&Slot; cnt = sizeof(int); for (;;) { if ((n = write(Mic, p, cnt)) >= 0) { if ((cnt -= n) == 0) break; p += n; } else { if (errno != EINTR) writeErr("sync"); if (*Signal) sighandler(ex); } } Sync = NO; do waitFd(ex, -1, -1); while (!Sync); return T; } // (hear 'cnt) -> cnt any doHear(any ex) { any x; int fd; x = cdr(ex), x = EVAL(car(x)); if ((fd = (int)xCnt(ex,x)) < 0 || fd >= InFDs || !InFiles[fd]) badFd(ex,x); if (Hear) close(Hear), closeInFile(Hear), closeOutFile(Hear); Hear = fd; return x; } // (tell ['cnt] 'sym ['any ..]) -> any any doTell(any x) { any y; int pid; ptr pbSave, ppSave; byte buf[PIPE_BUF]; if (!Tell && !Children) return Nil; if (!isCell(x = cdr(x))) { unsync(); return Nil; } pid = 0; if (isNum(y = EVAL(car(x)))) { pid = (int)unDig(y)/2; x = cdr(x), y = EVAL(car(x)); } tellBeg(&pbSave, &ppSave, buf); while (prTell(y), isCell(x = cdr(x))) y = EVAL(car(x)); tellEnd(&pbSave, &ppSave, pid); return y; } // (poll 'cnt) -> cnt | NIL any doPoll(any ex) { any x; int fd; inFile *p; fd_set fdSet; struct timeval tv; x = cdr(ex), x = EVAL(car(x)); if ((fd = (int)xCnt(ex,x)) < 0 || fd >= InFDs) badFd(ex,x); if (!(p = InFiles[fd])) return Nil; do { if (inReady(p)) return x; FD_ZERO(&fdSet); FD_SET(fd, &fdSet); tv.tv_sec = tv.tv_usec = 0; while (select(fd+1, &fdSet, NULL, NULL, &tv) < 0) if (errno != EINTR) selectErr(ex); if (!FD_ISSET(fd, &fdSet)) return Nil; } while (slow(p,YES) < 0); return x; } // (key ['cnt]) -> sym any doKey(any ex) { any x; int c, d; flushAll(); setRaw(); x = cdr(ex); if (!waitFd(ex, STDIN_FILENO, isNil(x = EVAL(car(x)))? -1 : xCnt(ex,x))) return Nil; if ((c = stdinByte()) == 0xFF) c = TOP; else if (c & 0x80) { d = stdinByte(); if ((c & 0x20) == 0) c = (c & 0x1F) << 6 | d & 0x3F; else c = ((c & 0xF) << 6 | d & 0x3F) << 6 | stdinByte() & 0x3F; } return mkChar(c); } // (peek) -> sym any doPeek(any ex __attribute__((unused))) { if (!Chr) Env.get(); return Chr<0? Nil : mkChar(Chr); } // (char) -> sym // (char 'cnt) -> sym // (char T) -> sym // (char 'sym) -> cnt any doChar(any ex) { any x = cdr(ex); if (!isCell(x)) { if (!Chr) Env.get(); x = Chr<0? Nil : mkChar(getChar()); Env.get(); return x; } if (isNum(x = EVAL(car(x)))) return IsZero(x)? Nil : mkChar(unDig(x) / 2); if (isSym(x)) return x == T? mkChar(TOP) : boxCnt(symChar(name(x))); atomError(ex,x); } // (skip ['any]) -> sym any doSkip(any x) { x = evSym(cdr(x)); return skipc(symChar(name(x)))<0? Nil : mkChar(Chr); } // (eol) -> flg any doEol(any ex __attribute__((unused))) { return Chr=='\n' || Chr<=0? T : Nil; } // (eof ['flg]) -> flg any doEof(any x) { x = cdr(x); if (!isNil(EVAL(car(x)))) { Chr = -1; return T; } if (!Chr) Env.get(); return Chr < 0? T : Nil; } // (from 'any ..) -> sym any doFrom(any x) { int i, j, ac = length(x = cdr(x)), p[ac]; cell c[ac]; char *av[ac]; if (ac == 0) return Nil; for (i = 0;;) { Push(c[i], evSym(x)); av[i] = alloc(NULL, bufSize(data(c[i]))), bufString(data(c[i]), av[i]); p[i] = 0; if (++i == ac) break; x = cdr(x); } if (!Chr) Env.get(); while (Chr >= 0) { for (i = 0; i < ac; ++i) { for (;;) { if (av[i][p[i]] == (byte)Chr) { if (av[i][++p[i]]) break; Env.get(); x = data(c[i]); goto done; } if (!p[i]) break; for (j = 1; --p[i]; ++j) if (memcmp(av[i], av[i]+j, p[i]) == 0) break; } } Env.get(); } x = Nil; done: i = 0; do free(av[i]); while (++i < ac); drop(c[0]); return x; } // (till 'any ['flg]) -> lst|sym any doTill(any ex) { any x; int i; cell c1; x = evSym(cdr(ex)); { char buf[bufSize(x)]; bufString(x, buf); if (!Chr) Env.get(); if (Chr < 0 || strchr(buf,Chr)) return Nil; x = cddr(ex); if (isNil(EVAL(car(x)))) { Push(c1, x = cons(mkChar(getChar()), Nil)); while (Env.get(), Chr > 0 && !strchr(buf,Chr)) x = cdr(x) = cons(mkChar(getChar()), Nil); return Pop(c1); } Push(c1, boxChar(getChar(), &i, &x)); while (Env.get(), Chr > 0 && !strchr(buf,Chr)) charSym(getChar(), &i, &x); return consStr(Pop(c1)); } } bool eol(void) { if (Chr < 0) return YES; if (Chr == '\n') { Chr = 0; return YES; } if (Chr == '\r') { Env.get(); if (Chr == '\n') Chr = 0; return YES; } return NO; } // (line 'flg ['cnt ..]) -> lst|sym any doLine(any ex) { any x, y, z; bool pack; int i, n; cell c1; if (!Chr) Env.get(); if (eol()) return Nil; x = cdr(ex); if (pack = !isNil(EVAL(car(x)))) Push(c1, boxChar(getChar(), &i, &z)); else Push(c1, cons(mkChar(getChar()), Nil)); if (!isCell(x = cdr(x))) y = data(c1); else { if (!pack) z = data(c1); data(c1) = y = cons(data(c1), Nil); for (;;) { n = (int)evCnt(ex,x); while (--n) { if (Env.get(), eol()) { if (pack) car(y) = consStr(car(y)); return Pop(c1); } if (pack) charSym(getChar(), &i, &z); else z = cdr(z) = cons(mkChar(getChar()), Nil); } if (pack) car(y) = consStr(car(y)); if (!isCell(x = cdr(x))) { pack = NO; break; } if (Env.get(), eol()) return Pop(c1); y = cdr(y) = cons( pack? boxChar(getChar(), &i, &z) : (z = cons(mkChar(getChar()), Nil)), Nil ); } } for (;;) { if (Env.get(), eol()) return pack? consStr(Pop(c1)) : Pop(c1); if (pack) charSym(getChar(), &i, &z); else y = cdr(y) = cons(mkChar(getChar()), Nil); } } // (lines 'any ..) -> cnt any doLines(any x) { any y; int c, cnt = 0; bool flg = NO; FILE *fp; for (x = cdr(x); isCell(x); x = cdr(x)) { y = evSym(x); { char nm[pathSize(y)]; pathString(y, nm); if (fp = fopen(nm, "r")) { flg = YES; while ((c = getc_unlocked(fp)) >= 0) if (c == '\n') ++cnt; fclose(fp); } } } return flg? boxCnt(cnt) : Nil; } static any parse(any x, bool skp, any s) { int c; parseFrame *save, parser; void (*getSave)(void); cell c1; save = Env.parser; Env.parser = &parser; parser.dig = unDig(parser.name = name(x)); parser.eof = s? 0xFF : 0xFF5D0A; getSave = Env.get, Env.get = getParse, c = Chr, Chr = 0; Push(c1, Env.parser->name); if (skp) getParse(); if (!s) x = rdList(); else { any y; cell c2; if (!(x = token(s,0))) return Nil; Push(c2, y = cons(x,Nil)); while (x = token(s,0)) y = cdr(y) = cons(x,Nil); x = Pop(c2); } drop(c1); Chr = c, Env.get = getSave, Env.parser = save; return x; } static void putString(int c) { if (StrP) byteSym(c, &StrI, &StrP); else StrI = 0, data(StrCell) = StrP = box(c & 0xFF); } void begString(void) { StrP = NULL; Push(StrCell,Nil); PutSave = Env.put, Env.put = putString; } any endString(void) { Env.put = PutSave; drop(StrCell); return StrP? consStr(data(StrCell)) : Nil; } // (any 'sym) -> any any doAny(any ex) { any x; x = cdr(ex), x = EVAL(car(x)); NeedSym(ex,x); if (!isNil(x)) { int c; parseFrame *save, parser; void (*getSave)(void); cell c1; save = Env.parser; Env.parser = &parser; parser.dig = unDig(parser.name = name(x)); parser.eof = 0xFF20; getSave = Env.get, Env.get = getParse, c = Chr, Chr = 0; Push(c1, Env.parser->name); getParse(); x = read0(YES); drop(c1); Chr = c, Env.get = getSave, Env.parser = save; } return x; } // (sym 'any) -> sym any doSym(any x) { x = EVAL(cadr(x)); begString(); print(x); return endString(); } // (str 'sym ['sym1]) -> lst // (str 'lst) -> sym any doStr(any ex) { any x; cell c1, c2; x = cdr(ex); if (isNil(x = EVAL(car(x)))) return Nil; if (isNum(x)) argError(ex,x); if (isSym(x)) { if (!isCell(cddr(ex))) return parse(x, NO, NULL); Push(c1, x); Push(c2, evSym(cddr(ex))); x = parse(x, NO, data(c2)); drop(c1); return x; } begString(); while (print(car(x)), isCell(x = cdr(x))) space(); return endString(); } any load(any ex, int pr, any x) { cell c1, c2; inFrame f; if (isSym(x) && firstByte(x) == '-') { Push(c1, parse(x, YES, NULL)); x = evList(data(c1)); drop(c1); return x; } rdOpen(ex, x, &f); pushInFiles(&f); doHide(Nil); x = Nil; for (;;) { if (InFile != InFiles[STDIN_FILENO]) data(c1) = read1(0); else { if (pr && !Chr) prin(run(val(Prompt))), Env.put(pr), space(), flushAll(); data(c1) = read1(isatty(STDIN_FILENO)? '\n' : 0); while (Chr > 0) { if (Chr == '\n') { Chr = 0; break; } if (Chr == '#') comment(); else { if (Chr > ' ') break; Env.get(); } } } if (isNil(data(c1))) { popInFiles(); doHide(Nil); return x; } Save(c1); if (InFile != InFiles[STDIN_FILENO] || Chr || !pr) x = EVAL(data(c1)); else { flushAll(); Push(c2, val(At)); x = val(At) = EVAL(data(c1)); val(At3) = val(At2), val(At2) = data(c2); outString("-> "), flushAll(), print1(x), newline(); } drop(c1); } } // (load 'any ..) -> any any doLoad(any ex) { any x, y; x = cdr(ex); do { if ((y = EVAL(car(x))) != T) y = load(ex, '>', y); else y = loadAll(ex); } while (isCell(x = cdr(x))); return y; } // (in 'any . prg) -> any any doIn(any ex) { any x; inFrame f; x = cdr(ex), x = EVAL(car(x)); rdOpen(ex, x, &f); pushInFiles(&f); x = prog(cddr(ex)); popInFiles(); return x; } // (out 'any . prg) -> any any doOut(any ex) { any x; outFrame f; x = cdr(ex), x = EVAL(car(x)); wrOpen(ex, x, &f); pushOutFiles(&f); x = prog(cddr(ex)); popOutFiles(); return x; } // (err 'sym . prg) -> any any doErr(any ex) { any x; errFrame f; x = cdr(ex), x = EVAL(car(x)); erOpen(ex,x,&f); pushErrFiles(&f); x = prog(cddr(ex)); popErrFiles(); return x; } // (ctl 'sym . prg) -> any any doCtl(any ex) { any x; ctlFrame f; x = cdr(ex), x = EVAL(car(x)); ctOpen(ex,x,&f); pushCtlFiles(&f); x = prog(cddr(ex)); popCtlFiles(); return x; } // (pipe exe) -> cnt // (pipe exe . prg) -> any any doPipe(any ex) { any x; union { inFrame in; outFrame out; } f; int pfd[2]; if (pipe(pfd) < 0) err(ex, NULL, "Can't pipe"); closeOnExec(ex, pfd[0]), closeOnExec(ex, pfd[1]); if ((f.in.pid = forkLisp(ex)) == 0) { if (isCell(cddr(ex))) setpgid(0,0); close(pfd[0]); if (pfd[1] != STDOUT_FILENO) dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); wrOpen(ex, Nil, &f.out); pushOutFiles(&f.out); OutFile->tty = NO; val(Run) = Nil; EVAL(cadr(ex)); bye(0); } close(pfd[1]); initInFile(f.in.fd = pfd[0], NULL); if (!isCell(cddr(ex))) return boxCnt(pfd[0]); setpgid(f.in.pid,0); pushInFiles(&f.in); x = prog(cddr(ex)); popInFiles(); return x; } // (open 'any ['flg]) -> cnt | NIL any doOpen(any ex) { any x = evSym(cdr(ex)); char nm[pathSize(x)]; int fd; pathString(x, nm); x = caddr(ex), x = EVAL(x); while ((fd = open(nm, isNil(x)? O_CREAT|O_RDWR : O_RDONLY, 0666)) < 0) { if (errno != EINTR) return Nil; if (*Signal) sighandler(ex); } closeOnExec(ex, fd); initInFile(fd, strdup(nm)), initOutFile(fd); return boxCnt(fd); } // (close 'cnt) -> cnt | NIL any doClose(any ex) { any x; int fd; x = cdr(ex), x = EVAL(car(x)), fd = (int)xCnt(ex,x); while (close(fd)) { if (errno != EINTR) return Nil; if (*Signal) sighandler(ex); } closeInFile(fd), closeOutFile(fd); return x; } // (echo ['cnt ['cnt]] | ['sym ..]) -> sym any doEcho(any ex) { any x, y; long cnt; x = cdr(ex), y = EVAL(car(x)); if (!Chr) Env.get(); if (isNil(y) && !isCell(cdr(x))) { while (Chr >= 0) Env.put(Chr), Env.get(); return T; } if (isSym(y)) { int m, n, i, j, ac = length(x), p[ac], om, op; cell c[ac]; char *av[ac]; for (i = 0;;) { Push(c[i], y); av[i] = alloc(NULL, bufSize(y)), bufString(y, av[i]); p[i] = 0; if (++i == ac) break; y = evSym(x = cdr(x)); } m = -1; while (Chr >= 0) { if ((om = m) >= 0) op = p[m]; for (i = 0; i < ac; ++i) { for (;;) { if (av[i][p[i]] == (byte)Chr) { if (av[i][++p[i]]) { if (m < 0 || p[i] > p[m]) m = i; break; } if (om >= 0) for (j = 0, n = op-p[i]; j <= n; ++j) Env.put(av[om][j]); Chr = 0; x = data(c[i]); goto done; } if (!p[i]) break; for (j = 1; --p[i]; ++j) if (memcmp(av[i], av[i]+j, p[i]) == 0) break; if (m == i) for (m = -1, j = 0; j < ac; ++j) if (p[j] && (m < 0 || p[j] > p[m])) m = j; } } if (m < 0) { if (om >= 0) for (i = 0; i < op; ++i) Env.put(av[om][i]); Env.put(Chr); } else if (om >= 0) for (i = 0, n = op-p[m]; i <= n; ++i) Env.put(av[om][i]); Env.get(); } x = Nil; done: i = 0; do free(av[i]); while (++i < ac); drop(c[0]); return x; } if (isCell(x = cdr(x))) { for (cnt = xCnt(ex,y), y = EVAL(car(x)); --cnt >= 0; Env.get()) if (Chr < 0) return Nil; } if ((cnt = xCnt(ex,y)) > 0) { for (;;) { if (Chr < 0) return Nil; Env.put(Chr); if (!--cnt) break; Env.get(); } } Chr = 0; return T; } /*** Printing ***/ void putStdout(int c) { if (OutFile) { if (OutFile->ix == BUFSIZ) { OutFile->ix = 0; wrBytes(OutFile->fd, OutFile->buf, BUFSIZ); } if ((OutFile->buf[OutFile->ix++] = c) == '\n' && OutFile->tty) { int n = OutFile->ix; OutFile->ix = 0; wrBytes(OutFile->fd, OutFile->buf, n); } } } void newline(void) {Env.put('\n');} void space(void) {Env.put(' ');} void outWord(word n) { if (n > 9) outWord(n / 10); Env.put('0' + n % 10); } void outString(char *s) { while (*s) Env.put(*s++); } static void outSym(int c) { do Env.put(c); while (c = symByte(NULL)); } void outName(any s) {outSym(symByte(name(s)));} void outNum(any x) { if (isNum(cdr(numCell(x)))) { cell c1; Push(c1, numToSym(x, 0, 0, 0)); outName(data(c1)); drop(c1); } else { char *p, buf[BITS/2]; sprintf(p = buf, "%ld", unBox(x)); do Env.put(*p++); while (*p); } } /* Print one expression */ void print(any x) { cell c1; Push(c1,x); print1(x); drop(c1); } void print1(any x) { if (*Signal) sighandler(NULL); if (isNum(x)) outNum(x); else if (isNil(x)) outString("NIL"); else if (isSym(x)) { int c; any y; if (!(c = symByte(y = name(x)))) Env.put('$'), outWord(num(x)/sizeof(cell)); else if (isExt(x)) Env.put('{'), outSym(c), Env.put('}'); else if (hashed(x, Intern[ihash(y)])) { if (unDig(y) == '.') Env.put('\\'), Env.put('.'); else { if (c == '#') Env.put('\\'); do { if (c == '\\' || strchr(Delim, c)) Env.put('\\'); Env.put(c); } while (c = symByte(NULL)); } } else { bool tsm = isCell(val(Tsm)) && Env.put == putStdout && OutFile->tty; if (!tsm) Env.put('"'); else { outName(car(val(Tsm))); c = symByte(y); } do { if (c == '\\' || c == '^' || !tsm && c == '"') Env.put('\\'); else if (c == 127) Env.put('^'), c = '?'; else if (c < ' ') Env.put('^'), c |= 0x40; Env.put(c); } while (c = symByte(NULL)); if (!tsm) Env.put('"'); else outName(cdr(val(Tsm))); } } else if (car(x) == Quote && x != cdr(x)) Env.put('\''), print1(cdr(x)); else { any y; Env.put('('); if ((y = circ(x)) == NULL) { while (print1(car(x)), !isNil(x = cdr(x))) { if (!isCell(x)) { outString(" . "); print1(x); break; } space(); } } else if (y == x) { do print1(car(x)), space(); while (y != (x = cdr(x))); Env.put('.'); } else { do print1(car(x)), space(); while (y != (x = cdr(x))); outString(". ("); do print1(car(x)), space(); while (y != (x = cdr(x))); outString(".)"); } Env.put(')'); } } void prin(any x) { cell c1; Push(c1,x); prin1(x); drop(c1); } void prin1(any x) { if (*Signal) sighandler(NULL); if (!isNil(x)) { if (isNum(x)) outNum(x); else if (isSym(x)) { if (isExt(x)) Env.put('{'); outName(x); if (isExt(x)) Env.put('}'); } else { while (prin1(car(x)), !isNil(x = cdr(x))) { if (!isCell(x)) { prin1(x); break; } } } } } // (prin 'any ..) -> any any doPrin(any x) { any y = Nil; while (isCell(x = cdr(x))) prin(y = EVAL(car(x))); return y; } // (prinl 'any ..) -> any any doPrinl(any x) { any y = Nil; while (isCell(x = cdr(x))) prin(y = EVAL(car(x))); newline(); return y; } // (space ['cnt]) -> cnt any doSpace(any ex) { any x; int n; if (isNil(x = EVAL(cadr(ex)))) { Env.put(' '); return One; } for (n = xCnt(ex,x); n > 0; --n) Env.put(' '); return x; } // (print 'any ..) -> any any doPrint(any x) { any y; x = cdr(x), print(y = EVAL(car(x))); while (isCell(x = cdr(x))) space(), print(y = EVAL(car(x))); return y; } // (printsp 'any ..) -> any any doPrintsp(any x) { any y; x = cdr(x); do print(y = EVAL(car(x))), space(); while (isCell(x = cdr(x))); return y; } // (println 'any ..) -> any any doPrintln(any x) { any y; x = cdr(x), print(y = EVAL(car(x))); while (isCell(x = cdr(x))) space(), print(y = EVAL(car(x))); newline(); return y; } // (flush) -> flg any doFlush(any ex __attribute__((unused))) { return flush(OutFile)? T : Nil; } // (rewind) -> flg any doRewind(any ex __attribute__((unused))) { if (!OutFile) return Nil; OutFile->ix = 0; return lseek(OutFile->fd, 0L, SEEK_SET) || ftruncate(OutFile->fd, 0)? Nil : T; } // (ext 'cnt . prg) -> any any doExt(any ex) { int extn; any x; x = cdr(ex); extn = ExtN, ExtN = (int)evCnt(ex,x); x = prog(cddr(ex)); ExtN = extn; return x; } // (rd ['sym]) -> any // (rd 'cnt) -> num | NIL any doRd(any x) { long cnt; int n, i; cell c1; x = cdr(x), x = EVAL(car(x)); if (!isNum(x)) { Push(c1,x); getBin = getBinary; x = binRead(ExtN) ?: data(c1); drop(c1); return x; } if ((cnt = unBox(x)) < 0) { if ((n = getBinary()) < 0) return Nil; i = 0, Push(c1, x = box(n)); while (++cnt) { if ((n = getBinary()) < 0) return Nil; byteSym(n, &i, &x); } zapZero(data(c1)); digMul2(data(c1)); } else { if ((n = getBinary()) < 0) return Nil; i = 0, Push(c1, x = box(n+n)); while (--cnt) { if ((n = getBinary()) < 0) return Nil; digMul(data(c1), 256); setDig(data(c1), unDig(data(c1)) | n+n); } zapZero(data(c1)); } return Pop(c1); } // (pr 'any ..) -> any any doPr(any x) { any y; x = cdr(x); do pr(ExtN, y = EVAL(car(x))); while (isCell(x = cdr(x))); return y; } // (wr 'cnt ..) -> cnt any doWr(any x) { any y; x = cdr(x); do putStdout(unDig(y = EVAL(car(x))) / 2); while (isCell(x = cdr(x))); return y; } /*** DB-I/O ***/ #define BLKSIZE 64 // DB block unit size #define BLK 6 #define TAGMASK (BLKSIZE-1) #define BLKMASK (~TAGMASK) #define EXTERN64 65536 static int F, Files, *BlkShift, *BlkFile, *BlkSize, *Fluse, MaxBlkSize; static FILE *Jnl, *Log; static adr BlkIndex, BlkLink; static adr *Marks; static byte *Locks, *Ptr, **Mark; static byte *Block, *IniBlk; // 01 00 00 00 00 00 NIL 0 static adr getAdr(byte *p) { return (adr)p[0] | (adr)p[1]<<8 | (adr)p[2]<<16 | (adr)p[3]<<24 | (adr)p[4]<<32 | (adr)p[5]<<40; } static void setAdr(adr n, byte *p) { p[0] = (byte)n, p[1] = (byte)(n >> 8), p[2] = (byte)(n >> 16); p[3] = (byte)(n >> 24), p[4] = (byte)(n >> 32), p[5] = (byte)(n >> 40); } static void dbfErr(any ex) {err(ex, NULL, "Bad DB file");} static void dbErr(char *s) {err(NULL, NULL, "DB %s: %s", s, strerror(errno));} static void jnlErr(any ex) {err(ex, NULL, "Bad Journal");} static void fsyncErr(any ex, char *s) {err(ex, NULL, "%s fsync error: %s", s, strerror(errno));} static void truncErr(any ex) {err(ex, NULL, "Log truncate error: %s", strerror(errno));} static void ignLog(void) {fprintf(stderr, "Discarding incomplete transaction.\n");} any new64(adr n, any x) { int c, i; adr w = 0; do { if ((c = n & 0x3F) > 11) c += 5; if (c > 42) c += 6; w = w << 8 | c + '0'; } while (n >>= 6); if (i = F) { ++i; w = w << 8 | '-'; do { if ((c = i & 0x3F) > 11) c += 5; if (c > 42) c += 6; w = w << 8 | c + '0'; } while (i >>= 6); } return hi(w)? consNum(num(w), consNum(hi(w), x)) : consNum(num(w), x); } adr blk64(any x) { int c; adr n, w; F = 0; n = 0; if (isNum(x)) { w = unDig(x); if (isNum(x = cdr(numCell(x)))) w |= (adr)unDig(x) << BITS; do { if ((c = w & 0xFF) == '-') F = n-1, n = 0; else { if ((c -= '0') > 42) c -= 6; if (c > 11) c -= 5; n = n << 6 | c; } } while (w >>= 8); } return n; } any extOffs(int offs, any x) { int f = F; adr n = blk64(x); if (offs != -EXTERN64) { if ((F += offs) < 0) err(NULL, NULL, "%d: Bad DB offset", F); x = new64(n, Nil); } else { // Undocumented 64-bit DB export adr w = n & 0xFFFFF | (F & 0xFF) << 20; w |= ((n >>= 20) & 0xFFF) << 28; w |= (adr)(F >> 8) << 40 | (n >> 12) << 48; x = hi(w)? consNum(num(w), consNum(hi(w), Nil)) : consNum(num(w), Nil); } F = f; return x; } /* DB Record Locking */ static void dbLock(int cmd, int typ, int f, off_t len) { struct flock fl; fl.l_type = typ; fl.l_whence = SEEK_SET; fl.l_start = 0; fl.l_len = len; while (fcntl(BlkFile[f], cmd, &fl) < 0 && typ != F_UNLCK) if (errno != EINTR) lockErr(); } static inline void rdLock(void) { if (val(Solo) != T) dbLock(F_SETLKW, F_RDLCK, 0, 1); } static inline void wrLock(void) { if (val(Solo) != T) dbLock(F_SETLKW, F_WRLCK, 0, 1); } static inline void rwUnlock(off_t len) { if (val(Solo) != T) { if (len == 0) { int f; for (f = 1; f < Files; ++f) if (Locks[f]) dbLock(F_SETLK, F_UNLCK, f, 0), Locks[f] = 0; val(Solo) = Zero; } dbLock(F_SETLK, F_UNLCK, 0, len); } } static pid_t tryLock(off_t n, off_t len) { struct flock fl; for (;;) { fl.l_type = F_WRLCK; fl.l_whence = SEEK_SET; fl.l_start = n; fl.l_len = len; if (fcntl(BlkFile[F], F_SETLK, &fl) >= 0) { Locks[F] = 1; if (!n) val(Solo) = T; else if (val(Solo) != T) val(Solo) = Nil; return 0; } if (errno != EINTR && errno != EACCES && errno != EAGAIN) lockErr(); while (fcntl(BlkFile[F], F_GETLK, &fl) < 0) if (errno != EINTR) lockErr(); if (fl.l_type != F_UNLCK) return fl.l_pid; } } static void blkPeek(off_t pos, void *buf, int siz) { if (pread(BlkFile[F], buf, siz, pos) != (ssize_t)siz) dbErr("read"); } static void blkPoke(off_t pos, void *buf, int siz) { if (pwrite(BlkFile[F], buf, siz, pos) != (ssize_t)siz) dbErr("write"); if (Jnl) { byte a[BLK+2]; putc_unlocked(siz == BlkSize[F]? BLKSIZE : siz, Jnl); a[0] = (byte)F, a[1] = (byte)(F >> 8), setAdr(pos >> BlkShift[F], a+2); if (fwrite(a, BLK+2, 1, Jnl) != 1 || fwrite(buf, siz, 1, Jnl) != 1) writeErr("Journal"); } } static void rdBlock(adr n) { blkPeek((BlkIndex = n) << BlkShift[F], Block, BlkSize[F]); BlkLink = getAdr(Block) & BLKMASK; Ptr = Block + BLK; } static void logBlock(void) { byte a[BLK+2]; a[0] = (byte)F, a[1] = (byte)(F >> 8), setAdr(BlkIndex, a+2); if (fwrite(a, BLK+2, 1, Log) != 1 || fwrite(Block, BlkSize[F], 1, Log) != 1) writeErr("Log"); } static void wrBlock(void) {blkPoke(BlkIndex << BlkShift[F], Block, BlkSize[F]);} static adr newBlock(void) { adr n; byte buf[2*BLK]; blkPeek(0, buf, 2*BLK); // Get Free, Next if ((n = getAdr(buf)) && Fluse[F]) { blkPeek(n << BlkShift[F], buf, BLK); // Get free link --Fluse[F]; } else if ((n = getAdr(buf+BLK)) != 281474976710592LL) setAdr(n + BLKSIZE, buf+BLK); // Increment next else err(NULL, NULL, "DB Oversize"); blkPoke(0, buf, 2*BLK); setAdr(0, IniBlk), blkPoke(n << BlkShift[F], IniBlk, BlkSize[F]); return n; } any newId(any ex, int i) { adr n; if ((F = i-1) >= Files) dbfErr(ex); if (!Log) ++Env.protect; wrLock(); if (Jnl) lockFile(fileno(Jnl), F_SETLKW, F_WRLCK); n = newBlock(); if (Jnl) fflush(Jnl), lockFile(fileno(Jnl), F_SETLK, F_UNLCK); rwUnlock(1); if (!Log) --Env.protect; return new64(n/BLKSIZE, At2); // dirty } bool isLife(any x) { adr n; byte buf[2*BLK]; if ((n = blk64(name(x))*BLKSIZE) > 0) { if (F < Files) { for (x = tail1(x); !isSym(x); x = cdr(cellPtr(x))); if (x == At || x == At2) return YES; if (x != At3) { blkPeek(0, buf, 2*BLK); // Get Next if (n < getAdr(buf+BLK)) { blkPeek(n << BlkShift[F], buf, BLK); if ((buf[0] & TAGMASK) == 1) return YES; } } } else if (!isNil(val(Ext))) return YES; } return NO; } static void cleanUp(adr n) { adr p, fr; byte buf[BLK]; blkPeek(0, buf, BLK), fr = getAdr(buf); // Get Free setAdr(n, buf), blkPoke(0, buf, BLK); // Set new for (;;) { p = n << BlkShift[F]; blkPeek(p, buf, BLK); // Get block link buf[0] &= BLKMASK; // Clear Tag if ((n = getAdr(buf)) == 0) break; blkPoke(p, buf, BLK); } setAdr(fr, buf), blkPoke(p, buf, BLK); // Append old free list } static int getBlock(void) { if (Ptr == Block+BlkSize[F]) { if (!BlkLink) return 0; rdBlock(BlkLink); } return *Ptr++; } static void putBlock(int c) { if (Ptr == Block+BlkSize[F]) { if (BlkLink) wrBlock(), rdBlock(BlkLink); else { adr n = newBlock(); int cnt = Block[0]; // Link must be 0 setAdr(n | cnt, Block); wrBlock(); BlkIndex = n; if (cnt < TAGMASK) ++cnt; setAdr(cnt, Block); Ptr = Block + BLK; } } *Ptr++ = (byte)c; } // Test for existing transaction static bool transaction(void) { byte a[BLK]; fseek(Log, 0L, SEEK_SET); if (fread(a, 2, 1, Log) == 0) { if (!feof(Log)) ignLog(); return NO; } for (;;) { if (a[0] == 0xFF && a[1] == 0xFF) return YES; if ((F = a[0] | a[1]<<8) >= Files || fread(a, BLK, 1, Log) != 1 || fseek(Log, BlkSize[F], SEEK_CUR) != 0 || fread(a, 2, 1, Log) != 1 ) { ignLog(); return NO; } } } static void restore(any ex) { byte dirty[Files], a[BLK], buf[MaxBlkSize]; fprintf(stderr, "Last transaction not completed: Rollback\n"); fseek(Log, 0L, SEEK_SET); for (F = 0; F < Files; ++F) dirty[F] = 0; for (;;) { if (fread(a, 2, 1, Log) == 0) jnlErr(ex); if (a[0] == 0xFF && a[1] == 0xFF) break; if ((F = a[0] | a[1]<<8) >= Files || fread(a, BLK, 1, Log) != 1 || fread(buf, BlkSize[F], 1, Log) != 1 ) jnlErr(ex); if (pwrite(BlkFile[F], buf, BlkSize[F], getAdr(a) << BlkShift[F]) != (ssize_t)BlkSize[F]) dbErr("write"); dirty[F] = 1; } for (F = 0; F < Files; ++F) if (dirty[F] && fsync(BlkFile[F]) < 0) fsyncErr(ex, "DB"); } // (pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T any doPool(any ex) { any x; byte buf[2*BLK+1]; cell c1, c2, c3, c4; x = cdr(ex), Push(c1, evSym(x)); // db x = cdr(x), Push(c2, EVAL(car(x))); // lst NeedLst(ex,data(c2)); x = cdr(x), Push(c3, evSym(x)); // sym2 Push(c4, evSym(cdr(x))); // sym3 val(Solo) = Zero; if (Files) { doRollback(Nil); for (F = 0; F < Files; ++F) { if (Marks) free(Mark[F]); if (close(BlkFile[F]) < 0) closeErr(); } free(Mark), Mark = NULL, free(Marks), Marks = NULL; Files = 0; if (Jnl) fclose(Jnl), Jnl = NULL; if (Log) fclose(Log), Log = NULL; } if (!isNil(data(c1))) { x = data(c2); Files = length(x) ?: 1; BlkShift = alloc(BlkShift, Files * sizeof(int)); BlkFile = alloc(BlkFile, Files * sizeof(int)); BlkSize = alloc(BlkSize, Files * sizeof(int)); Fluse = alloc(Fluse, Files * sizeof(int)); Locks = alloc(Locks, Files), memset(Locks, 0, Files); MaxBlkSize = 0; for (F = 0; F < Files; ++F) { char nm[pathSize(data(c1)) + 8]; pathString(data(c1), nm); if (isCell(x)) sprintf(nm + strlen(nm), "%d", F+1); BlkShift[F] = isNum(car(x))? (int)unDig(car(x))/2 : 2; if ((BlkFile[F] = open(nm, O_RDWR)) >= 0) { blkPeek(0, buf, 2*BLK+1); // Get block shift BlkSize[F] = BLKSIZE << (BlkShift[F] = (int)buf[2*BLK]); } else { if (errno != ENOENT || (BlkFile[F] = open(nm, O_CREAT|O_EXCL|O_RDWR, 0666)) < 0) { Files = F; openErr(ex, nm); } BlkSize[F] = BLKSIZE << BlkShift[F]; setAdr(0, buf); // Free if (F) setAdr(BLKSIZE, buf+BLK); // Next else { byte blk[BlkSize[0]]; setAdr(2*BLKSIZE, buf+BLK); // Next memset(blk, 0, BlkSize[0]); setAdr(1, blk), blkPoke(BlkSize[0], blk, BlkSize[0]); } buf[2*BLK] = (byte)BlkShift[F]; blkPoke(0, buf, 2*BLK+1); } closeOnExec(ex, BlkFile[F]); if (BlkSize[F] > MaxBlkSize) MaxBlkSize = BlkSize[F]; Fluse[F] = -1; x = cdr(x); } Block = alloc(Block, MaxBlkSize); IniBlk = alloc(IniBlk, MaxBlkSize); memset(IniBlk, 0, MaxBlkSize); if (!isNil(data(c3))) { char nm[pathSize(data(c3))]; pathString(data(c3), nm); if (!(Jnl = fopen(nm, "a"))) openErr(ex, nm); closeOnExec(ex, fileno(Jnl)); } if (!isNil(data(c4))) { char nm[pathSize(data(c4))]; pathString(data(c4), nm); if (!(Log = fopen(nm, "a+"))) openErr(ex, nm); closeOnExec(ex, fileno(Log)); if (transaction()) restore(ex); fseek(Log, 0L, SEEK_SET); if (ftruncate(fileno(Log), 0)) truncErr(ex); } } drop(c1); return T; } // (journal 'any ..) -> T any doJournal(any ex) { any x, y; int siz; FILE *fp; byte a[BLK], buf[MaxBlkSize]; for (x = cdr(ex); isCell(x); x = cdr(x)) { y = evSym(x); { char nm[pathSize(y)]; pathString(y, nm); if (!(fp = fopen(nm, "r"))) openErr(ex, nm); while ((siz = getc_unlocked(fp)) >= 0) { if (fread(a, 2, 1, fp) != 1) jnlErr(ex); if ((F = a[0] | a[1]<<8) >= Files) dbfErr(ex); if (siz == BLKSIZE) siz = BlkSize[F]; if (fread(a, BLK, 1, fp) != 1 || fread(buf, siz, 1, fp) != 1) jnlErr(ex); blkPoke(getAdr(a) << BlkShift[F], buf, siz); } fclose(fp); } } return T; } static any mkId(adr n) { any x, y, *h; x = new64(n, Nil); if (y = findHash(x, h = Extern + ehash(x))) return y; mkExt(y = consSym(Nil,x)); *h = cons(y,*h); return y; } // (id 'num ['num]) -> sym // (id 'sym [NIL]) -> num // (id 'sym T) -> (num . num) any doId(any ex) { any x, y; adr n; cell c1; x = cdr(ex); if (isNum(y = EVAL(car(x)))) { x = cdr(x); if (isNil(x = EVAL(car(x)))) { F = 0; return mkId(unBoxWord2(y)); } F = (int)unDig(y)/2 - 1; NeedNum(ex,x); return mkId(unBoxWord2(x)); } NeedExt(ex,y); n = blk64(name(y)); x = cdr(x); if (isNil(EVAL(car(x)))) return boxWord2(n); Push(c1, boxWord2(n)); data(c1) = cons(box((F + 1) * 2), data(c1)); return Pop(c1); } // (seq 'cnt|sym1) -> sym | NIL any doSeq(any ex) { any x; adr n, next; byte buf[2*BLK]; x = cdr(ex); if (isNum(x = EVAL(car(x)))) { F = (int)unDig(x)/2 - 1; n = 0; } else { NeedExt(ex,x); n = blk64(name(x))*BLKSIZE; } if (F >= Files) dbfErr(ex); rdLock(); blkPeek(0, buf, 2*BLK), next = getAdr(buf+BLK); // Get Next while ((n += BLKSIZE) < next) { blkPeek(n << BlkShift[F], buf, BLK); if ((buf[0] & TAGMASK) == 1) { rwUnlock(1); return mkId(n/BLKSIZE); } } rwUnlock(1); return Nil; } // (lieu 'any) -> sym | NIL any doLieu(any x) { any y; x = cdr(x); if (!isSym(x = EVAL(car(x))) || !isExt(x)) return Nil; for (y = tail1(x); !isSym(y); y = cdr(cellPtr(y))); return y == At || y == At2? x : Nil; } // (lock ['sym]) -> cnt | NIL any doLock(any ex) { any x; pid_t n; off_t blk; x = cdr(ex); if (isNil(x = EVAL(car(x)))) F = 0, n = tryLock(0,0); else { NeedExt(ex,x); blk = blk64(name(x)); if (F >= Files) dbfErr(ex); n = tryLock(blk * BlkSize[F], 1); } return n? boxCnt(n) : Nil; } int dbSize(any ex, any x) { int n; db(ex,x,1); n = BLK + 1 + binSize(val(x)); for (x = tail1(x); isCell(x); x = cdr(x)) { if (isSym(car(x))) n += binSize(car(x)) + 2; else n += binSize(cdar(x)) + binSize(caar(x)); } return n; } void db(any ex, any s, int a) { any x, y, *p; if (!isNum(x = tail1(s))) { if (a == 1) return; while (!isNum(x = cdr(x))); } p = &cdr(numCell(x)); while (isNum(*p)) p = &cdr(numCell(*p)); if (!isSym(*p)) p = &car(*p); if (*p != At3) { // not deleted if (*p == At2) { // dirty if (a == 3) { *p = At3; // deleted val(s) = Nil; tail(s) = ext(x); } } else if (isNil(*p) || a > 1) { if (a == 3) { *p = At3; // deleted val(s) = Nil; tail(s) = ext(x); } else if (*p == At) *p = At2; // loaded -> dirty else { // NIL & 1 | 2 adr n; cell c[1]; Push(c[0],s); n = blk64(x); if (F < Files) { rdLock(); rdBlock(n*BLKSIZE); if ((Block[0] & TAGMASK) != 1) err(ex, s, "Bad ID"); *p = a == 1? At : At2; // loaded : dirty getBin = getBlock; val(s) = binRead(0); if (!isNil(y = binRead(0))) { tail(s) = ext(x = cons(y,x)); if ((y = binRead(0)) != T) car(x) = cons(y,car(x)); while (!isNil(y = binRead(0))) { cdr(x) = cons(y,cdr(x)); if ((y = binRead(0)) != T) cadr(x) = cons(y,cadr(x)); x = cdr(x); } } rwUnlock(1); } else { if (!isCell(y = val(Ext)) || F < unBox(caar(y))) dbfErr(ex); while (isCell(cdr(y)) && F >= unBox(caadr(y))) y = cdr(y); y = apply(ex, cdar(y), NO, 1, c); // ((Obj) ..) *p = At; // loaded val(s) = car(y); if (!isCell(y = cdr(y))) tail(s) = ext(x); else { tail(s) = ext(y); while (isCell(cdr(y))) y = cdr(y); cdr(y) = x; } } drop(c[0]); } } } } // (commit ['any] [exe1] [exe2]) -> flg any doCommit(any ex) { bool note; int i, extn; adr n; cell c1; any x, y, z; ptr pbSave, ppSave; byte dirty[Files], buf[PIPE_BUF]; x = cdr(ex), Push(c1, EVAL(car(x))); if (!Log) ++Env.protect; wrLock(); if (Jnl) lockFile(fileno(Jnl), F_SETLKW, F_WRLCK); if (Log) { for (F = 0; F < Files; ++F) dirty[F] = 0, Fluse[F] = 0; for (i = 0; i < EHASH; ++i) { // Save objects for (x = Extern[i]; isCell(x); x = cdr(x)) { for (y = tail1(car(x)); isCell(y); y = cdr(y)); z = numCell(y); while (isNum(cdr(z))) z = numCell(cdr(z)); if (cdr(z) == At2 || cdr(z) == At3) { // dirty or deleted n = blk64(y); if (F < Files) { rdBlock(n*BLKSIZE); while (logBlock(), BlkLink) rdBlock(BlkLink); dirty[F] = 1; if (cdr(z) != At3) ++Fluse[F]; } } } } for (F = 0; F < Files; ++F) { if (i = Fluse[F]) { rdBlock(0); // Save Block 0 while (logBlock(), BlkLink && --i >= 0) // and free list rdBlock(BlkLink); } } putc_unlocked(0xFF, Log), putc_unlocked(0xFF, Log); fflush(Log); if (fsync(fileno(Log)) < 0) fsyncErr(ex, "Transaction"); } x = cddr(ex), EVAL(car(x)); if (data(c1) == T) note = NO, extn = EXTERN64; // Undocumented 64-bit DB export else { extn = 0; if (note = !isNil(data(c1)) && (Tell || Children)) tellBeg(&pbSave, &ppSave, buf), prTell(data(c1)); } for (i = 0; i < EHASH; ++i) { for (x = Extern[i]; isCell(x); x = cdr(x)) { for (y = tail1(car(x)); isCell(y); y = cdr(y)); z = numCell(y); while (isNum(cdr(z))) z = numCell(cdr(z)); if (cdr(z) == At2) { // dirty n = blk64(y); if (F < Files) { rdBlock(n*BLKSIZE); Block[0] |= 1; // Might be new putBin = putBlock; binPrint(extn, val(y = car(x))); for (y = tail1(y); isCell(y); y = cdr(y)) { if (isCell(car(y))) { if (!isNil(cdar(y))) binPrint(extn, cdar(y)), binPrint(extn, caar(y)); } else { if (!isNil(car(y))) binPrint(extn, car(y)), binPrint(extn, T); } } putBlock(NIX); setAdr(Block[0] & TAGMASK, Block); // Clear Link wrBlock(); if (BlkLink) cleanUp(BlkLink); cdr(z) = At; // loaded if (note) { if (PipePtr >= PipeBuf + PIPE_BUF - 12) { // EXTERN <2+1+7> END tellEnd(&pbSave, &ppSave, 0); tellBeg(&pbSave, &ppSave, buf), prTell(data(c1)); } prTell(car(x)); } } } else if (cdr(z) == At3) { // deleted n = blk64(y); if (F < Files) { cleanUp(n*BLKSIZE); if (note) { if (PipePtr >= PipeBuf + PIPE_BUF - 12) { // EXTERN <2+1+7> END tellEnd(&pbSave, &ppSave, 0); tellBeg(&pbSave, &ppSave, buf), prTell(data(c1)); } prTell(car(x)); } } cdr(z) = Nil; } } } if (note) tellEnd(&pbSave, &ppSave, 0); x = cdddr(ex), EVAL(car(x)); if (Jnl) fflush(Jnl), lockFile(fileno(Jnl), F_SETLK, F_UNLCK); if (isCell(x = val(Zap))) { outFile f, *oSave; char nm[pathSize(y = cdr(x))]; pathString(y, nm); if ((f.fd = open(nm, O_APPEND|O_CREAT|O_WRONLY, 0666)) < 0) openErr(ex, nm); f.ix = 0; f.tty = NO; putBin = putStdout; oSave = OutFile, OutFile = &f; for (y = car(x); isCell(y); y = cdr(y)) binPrint(0, car(y)); flush(&f); close(f.fd); car(x) = Nil; OutFile = oSave; } if (Log) { for (F = 0; F < Files; ++F) if (dirty[F] && fsync(BlkFile[F]) < 0) fsyncErr(ex, "DB"); fseek(Log, 0L, SEEK_SET); if (ftruncate(fileno(Log), 0)) truncErr(ex); } rwUnlock(0); // Unlock all unsync(); if (!Log) --Env.protect; for (F = 0; F < Files; ++F) Fluse[F] = -1; drop(c1); return T; } // (rollback) -> flg any doRollback(any x) { int i; any y, z; if (!Files) return Nil; for (i = 0; i < EHASH; ++i) { for (x = Extern[i]; isCell(x); x = cdr(x)) { val(y = car(x)) = Nil; for (z = tail1(y); isCell(z); z = cdr(z)); tail(y) = ext(z); z = numCell(z); while (isNum(cdr(z))) z = numCell(cdr(z)); cdr(z) = Nil; } } if (isCell(x = val(Zap))) car(x) = Nil; rwUnlock(0); // Unlock all unsync(); return T; } // (mark 'sym|0 ['NIL | 'T | '0]) -> flg any doMark(any ex) { any x, y; adr n, m; int b; byte *p; x = cdr(ex); if (isNum(y = EVAL(car(x)))) { if (Marks) { for (F = 0; F < Files; ++F) free(Mark[F]); free(Mark), Mark = NULL, free(Marks), Marks = NULL; } return Nil; } NeedExt(ex,y); n = blk64(name(y)); if (F >= Files) dbfErr(ex); if (!Marks) { Marks = alloc(Marks, Files * sizeof(adr)); memset(Marks, 0, Files * sizeof(adr)); Mark = alloc(Mark, Files * sizeof(byte*)); memset(Mark, 0, Files * sizeof(byte*)); } b = 1 << (n & 7); if ((n >>= 3) >= Marks[F]) { m = Marks[F], Marks[F] = n + 1; Mark[F] = alloc(Mark[F], Marks[F]); memset(Mark[F] + m, 0, Marks[F] - m); } p = Mark[F] + n; x = cdr(x); y = *p & b? T : Nil; // Old value if (!isNil(x = EVAL(car(x)))) { if (isNum(x)) *p &= ~b; // Clear mark else *p |= b; // Set mark } return y; } // (free 'cnt) -> (sym . lst) any doFree(any x) { byte buf[2*BLK]; cell c1; if ((F = (int)evCnt(x, cdr(x)) - 1) >= Files) dbfErr(x); rdLock(); blkPeek(0, buf, 2*BLK); // Get Free, Next Push(c1, x = cons(mkId(getAdr(buf+BLK)/BLKSIZE), Nil)); // Next BlkLink = getAdr(buf); // Free while (BlkLink) { x = cdr(x) = cons(mkId(BlkLink/BLKSIZE), Nil); rdBlock(BlkLink); } rwUnlock(1); return Pop(c1); } // (dbck ['cnt] 'flg) -> any any doDbck(any ex) { any x, y; bool flg; int i; FILE *jnl = Jnl; adr next, p, cnt; word2 blks, syms; byte buf[2*BLK]; cell c1; F = 0; x = cdr(ex); if (isNum(y = EVAL(car(x)))) { if ((F = (int)unDig(y)/2 - 1) >= Files) dbfErr(ex); x = cdr(x), y = EVAL(car(x)); } flg = !isNil(y); cnt = BLKSIZE; blks = syms = 0; ++Env.protect; wrLock(); if (Jnl) lockFile(fileno(Jnl), F_SETLKW, F_WRLCK); blkPeek(0, buf, 2*BLK); // Get Free, Next BlkLink = getAdr(buf); next = getAdr(buf+BLK); Jnl = NULL; while (BlkLink) { // Check free list rdBlock(BlkLink); if ((cnt += BLKSIZE) > next) { x = mkStr("Circular free list"); goto done; } Block[0] |= TAGMASK, wrBlock(); // Mark free list } Jnl = jnl; for (p = BLKSIZE; p != next; p += BLKSIZE) { // Check all chains if (rdBlock(p), (Block[0] & TAGMASK) == 0) { cnt += BLKSIZE; memcpy(Block, buf, BLK); // Insert into free list wrBlock(); setAdr(p, buf), blkPoke(0, buf, BLK); } else if ((Block[0] & TAGMASK) == 1) { ++blks, ++syms; cnt += BLKSIZE; for (i = 2; BlkLink; cnt += BLKSIZE) { ++blks; rdBlock(BlkLink); if ((Block[0] & TAGMASK) != i) { x = mkStr("Bad chain"); goto done; } if (i < TAGMASK) ++i; } } } BlkLink = getAdr(buf); // Unmark free list Jnl = NULL; while (BlkLink) { rdBlock(BlkLink); if (Block[0] & TAGMASK) Block[0] &= BLKMASK, wrBlock(); } if (cnt != next) x = mkStr("Bad count"); else if (!flg) x = Nil; else { Push(c1, boxWord2(syms)); data(c1) = cons(boxWord2(blks), data(c1)); x = Pop(c1); } done: if (Jnl = jnl) fflush(Jnl), lockFile(fileno(Jnl), F_SETLK, F_UNLCK); rwUnlock(1); --Env.protect; return x; } picolisp-3.1.5.2.orig/src/lat1.c0000644000000000000000000000343712265263724014753 0ustar rootroot/* lat1.c * 31mar05abu * Convert stdin (UTF-8, 2-Byte) to process or file (ISO-8859-15) */ #include #include #include #include #include #include // lat1 [- [ ..]] // lat1 [[+]] int main(int ac, char *av[]) { int c; pid_t pid = 0; FILE *fp = stdout; if (ac > 1) { char *mode = "w"; if (*av[1] == '-') { int pfd[2]; if (pipe(pfd) < 0) { fprintf(stderr, "lat1: Pipe error\n"); return 1; } if ((pid = fork()) == 0) { close(pfd[1]); if (pfd[0] != STDIN_FILENO) dup2(pfd[0], STDIN_FILENO), close(pfd[0]); execvp(av[1]+1, av+1); } if (pid < 0) { fprintf(stderr, "lat1: Fork error\n"); return 1; } close(pfd[0]); if (!(fp = fdopen(pfd[1], mode))) { fprintf(stderr, "lat1: Pipe open error\n"); return 1; } } else { if (*av[1] == '+') mode = "a", ++av[1]; if (!(fp = fopen(av[1], mode))) { fprintf(stderr, "lat1: '%s' open error\n", av[1]); return 1; } } } while ((c = getchar_unlocked()) != EOF) { if ((c & 0x80) == 0) putc_unlocked(c,fp); else if ((c & 0x20) == 0) putc_unlocked((c & 0x1F) << 6 | getchar_unlocked() & 0x3F, fp); else { getchar_unlocked(); // 0x82 getchar_unlocked(); // 0xAC putc_unlocked(0xA4, fp); } } if (pid) { fclose(fp); while (waitpid(pid, NULL, 0) < 0) if (errno != EINTR) { fprintf(stderr, "lat1: Pipe close error\n"); return 1; } } return 0; } picolisp-3.1.5.2.orig/src/main.c0000644000000000000000000007332312265263724015037 0ustar rootroot/* 23jun13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" #include "vers.h" #ifdef __CYGWIN__ #define O_ASYNC FASYNC #endif /* Globals */ int Repl, Chr, Slot, Spkr, Mic, Hear, Tell, Children, ExtN; char **AV, *AV0, *Home; child *Child; heap *Heaps; cell *Avail; stkEnv Env; catchFrame *CatchPtr; struct termios OrgTermio, *Termio; int InFDs, OutFDs; inFile *InFile, **InFiles; outFile *OutFile, **OutFiles; int (*getBin)(void); void (*putBin)(int); any TheKey, TheCls, Thrown; any Alarm, Sigio, Line, Zero, One; any Intern[IHASH], Transient[IHASH], Extern[EHASH]; any ApplyArgs, ApplyBody, DbVal, DbTail; any Nil, DB, Meth, Quote, T; any Solo, PPid, Pid, At, At2, At3, This, Prompt, Dbg, Zap, Ext, Scl, Class; any Run, Hup, Sig1, Sig2, Up, Err, Msg, Uni, Led, Tsm, Adr, Fork, Bye; bool Break; sig_atomic_t Signal[NSIG]; static int TtyPid; static word2 USec; static struct timeval Tv; static bool Tio, Jam; static jmp_buf ErrRst; static void finish(int) __attribute__ ((noreturn)); static struct rlimit ULim = {RLIM_INFINITY, RLIM_INFINITY}; /*** System ***/ static void finish(int n) { setCooked(); exit(n); } void giveup(char *msg) { fprintf(stderr, "%d %s\n", (int)getpid(), msg); finish(1); } void bye(int n) { static bool flg; if (!flg) { flg = YES; unwind(NULL); prog(val(Bye)); } flushAll(); finish(n); } void execError(char *s) { fprintf(stderr, "%s: Can't exec\n", s); exit(127); } /* Install interrupting signal */ static void iSignal(int n, void (*foo)(int)) { struct sigaction act, old; act.sa_handler = foo; sigemptyset(&act.sa_mask); act.sa_flags = 0; sigaction(n, &act, &old); } /* Signal handler */ void sighandler(any ex) { int i; bool flg; if (!Env.protect) { Env.protect = 1; do { if (Signal[SIGIO]) { --Signal[0], --Signal[SIGIO]; run(Sigio); } else if (Signal[SIGUSR1]) { --Signal[0], --Signal[SIGUSR1]; run(val(Sig1)); } else if (Signal[SIGUSR2]) { --Signal[0], --Signal[SIGUSR2]; run(val(Sig2)); } else if (Signal[SIGALRM]) { --Signal[0], --Signal[SIGALRM]; run(Alarm); } else if (Signal[SIGINT]) { --Signal[0], --Signal[SIGINT]; if (Repl < 2) brkLoad(ex ?: Nil); } else if (Signal[SIGHUP]) { --Signal[0], --Signal[SIGHUP]; run(val(Hup)); } else if (Signal[SIGTERM]) { for (flg = NO, i = 0; i < Children; ++i) if (Child[i].pid && kill(Child[i].pid, SIGTERM) == 0) flg = YES; if (flg) break; Signal[0] = 0, bye(0); } } while (*Signal); Env.protect = 0; } } static void sig(int n) { if (TtyPid) kill(TtyPid, n); else ++Signal[n], ++Signal[0]; } static void sigTerm(int n) { if (TtyPid) kill(TtyPid, n); else ++Signal[SIGTERM], ++Signal[0]; } static void sigChld(int n __attribute__((unused))) { int e, stat; pid_t pid; e = errno; while ((pid = waitpid(0, &stat, WNOHANG)) > 0) if (WIFSIGNALED(stat)) fprintf(stderr, "%d SIG-%d\n", (int)pid, WTERMSIG(stat)); errno = e; } static void tcSet(struct termios *p) { if (Termio) while (tcsetattr(STDIN_FILENO, TCSADRAIN, p) && errno == EINTR); } static void sigTermStop(int n __attribute__((unused))) { sigset_t mask; tcSet(&OrgTermio); sigemptyset(&mask); sigaddset(&mask, SIGTSTP); sigprocmask(SIG_UNBLOCK, &mask, NULL); signal(SIGTSTP, SIG_DFL), raise(SIGTSTP), signal(SIGTSTP, sigTermStop); tcSet(Termio); } void setRaw(void) { if (Tio && !Termio) { *(Termio = malloc(sizeof(struct termios))) = OrgTermio; Termio->c_iflag = 0; Termio->c_lflag = ISIG; Termio->c_cc[VMIN] = 1; Termio->c_cc[VTIME] = 0; tcSet(Termio); if (signal(SIGTSTP,SIG_IGN) == SIG_DFL) signal(SIGTSTP, sigTermStop); } } void setCooked(void) { tcSet(&OrgTermio); free(Termio), Termio = NULL; } // (raw ['flg]) -> flg any doRaw(any x) { if (!isCell(x = cdr(x))) return Termio? T : Nil; if (isNil(EVAL(car(x)))) { setCooked(); return Nil; } setRaw(); return T; } // (alarm 'cnt . prg) -> cnt any doAlarm(any x) { int n = alarm((int)evCnt(x,cdr(x))); Alarm = cddr(x); return boxCnt(n); } // (sigio 'cnt . prg) -> cnt any doSigio(any ex) { any x = EVAL(cadr(ex)); int fd = (int)xCnt(ex,x); Sigio = cddr(ex); fcntl(fd, F_SETOWN, unBox(val(Pid))); fcntl(fd, F_SETFL, fcntl(fd, F_GETFL, 0) | O_NONBLOCK|O_ASYNC); return x; } // (protect . prg) -> any any doProtect(any x) { ++Env.protect; x = prog(cdr(x)); --Env.protect; return x; } /* Allocate memory */ void *alloc(void *p, size_t siz) { if (!(p = realloc(p,siz))) giveup("No memory"); return p; } /* Allocate cell heap */ void heapAlloc(void) { heap *h; cell *p; h = (heap*)alloc(NULL, sizeof(heap)); h->next = Heaps, Heaps = h; p = h->cells + CELLS-1; do Free(p); while (--p >= h->cells); } // (heap 'flg) -> cnt any doHeap(any x) { long n = 0; x = cdr(x); if (isNil(EVAL(car(x)))) { heap *h = Heaps; do ++n; while (h = h->next); return boxCnt(n); } for (x = Avail; x; x = car(x)) ++n; return boxCnt(n / CELLS); } // (adr 'var) -> num // (adr 'num) -> var any doAdr(any x) { x = cdr(x); if (isNum(x = EVAL(car(x)))) return (any)(unDig(x) * WORD); return box(num(x) / WORD); } // (env ['lst] | ['sym 'val] ..) -> lst any doEnv(any x) { int i; bindFrame *p; cell c1, c2; Push(c1, Nil); if (!isCell(x = cdr(x))) { for (p = Break? Env.bind->link : Env.bind; p; p = p->link) { if (p->i == 0) { for (i = p->cnt; --i >= 0;) { for (x = data(c1); ; x = cdr(x)) { if (!isCell(x)) { data(c1) = cons(cons(p->bnd[i].sym, val(p->bnd[i].sym)), data(c1)); break; } if (caar(x) == p->bnd[i].sym) break; } } } } } else { do { Push(c2, EVAL(car(x))); if (isCell(data(c2))) { do data(c1) = cons( isCell(car(data(c2)))? cons(caar(data(c2)), cdar(data(c2))) : cons(car(data(c2)), val(car(data(c2)))), data(c1) ); while (isCell(data(c2) = cdr(data(c2)))); } else if (!isNil(data(c2))) { x = cdr(x); data(c1) = cons(cons(data(c2), EVAL(car(x))), data(c1)); } drop(c2); } while (isCell(x = cdr(x))); } return Pop(c1); } // (up [cnt] sym ['val]) -> any any doUp(any x) { any y, *val; int cnt, i; bindFrame *p; x = cdr(x); if (!isNum(y = car(x))) cnt = 1; else cnt = (int)unBox(y), x = cdr(x), y = car(x); for (p = Break? Env.bind->link : Env.bind, val = &val(y); p; p = p->link) { if (p->i <= 0) { for (i = 0; i < p->cnt; ++i) if (p->bnd[i].sym == y) { if (!--cnt) { if (isCell(x = cdr(x))) return p->bnd[i].val = EVAL(car(x)); return p->bnd[i].val; } val = &p->bnd[i].val; } } } if (isCell(x = cdr(x))) return *val = EVAL(car(x)); return *val; } // (sys 'any ['any]) -> sym any doSys(any x) { any y; y = evSym(x = cdr(x)); { char nm[bufSize(y)]; bufString(y,nm); if (!isCell(x = cdr(x))) return mkStr(getenv(nm)); y = evSym(x); { char val[bufSize(y)]; bufString(y,val); return setenv(nm,val,1)? Nil : y; } } } /*** Primitives ***/ any circ(any x) { any y = x; for (;;) { *(word*)&car(y) |= 1; if (!isCell(y = cdr(y))) { do *(word*)&car(x) &= ~1; while (isCell(x = cdr(x))); return NULL; } if (num(car(y)) & 1) { while (x != y) *(word*)&car(x) &= ~1, x = cdr(x); do *(word*)&car(x) &= ~1; while (y != (x = cdr(x))); return y; } } } /* Comparisons */ bool equal(any x, any y) { any a, b; bool res; for (;;) { if (x == y) return YES; if (isNum(x)) { if (!isNum(y) || unDig(x) != unDig(y)) return NO; x = cdr(numCell(x)), y = cdr(numCell(y)); continue; } if (isSym(x)) { if (!isSym(y) || !isNum(x = name(x)) || !isNum(y = name(y))) return NO; continue; } if (!isCell(y)) return NO; a = x, b = y; res = NO; for (;;) { if (!equal(car(x), (any)(num(car(y)) & ~1))) break; if (!isCell(cdr(x))) { res = equal(cdr(x), cdr(y)); break; } if (!isCell(cdr(y))) break; *(word*)&car(x) |= 1, x = cdr(x), y = cdr(y); if (num(car(x)) & 1) { for (;;) { if (a == x) { if (b == y) { for (;;) { a = cdr(a); if ((b = cdr(b)) == y) { res = a == x; break; } if (a == x) { res = YES; break; } } } break; } if (b == y) { res = NO; break; } *(word*)&car(a) &= ~1, a = cdr(a), b = cdr(b); } do *(word*)&car(a) &= ~1, a = cdr(a); while (a != x); return res; } } while (a != x) *(word*)&car(a) &= ~1, a = cdr(a); return res; } } int compare(any x, any y) { any a, b; if (x == y) return 0; if (isNil(x)) return -1; if (x == T) return +1; if (isNum(x)) { if (!isNum(y)) return isNil(y)? +1 : -1; return bigCompare(x,y); } if (isSym(x)) { int b1, b2; word n1, n2; if (isNum(y) || isNil(y)) return +1; if (isCell(y) || y == T) return -1; if (!isNum(a = name(x))) return !isNum(name(y))? (long)x - (long)y : -1; if (!isNum(b = name(y))) return +1; n1 = unDig(a), n2 = unDig(b); for (;;) { if ((b1 = n1 & 0xFF) != (b2 = n2 & 0xFF)) return b1 - b2; if ((n1 >>= 8) == 0) { if ((n2 >>= 8) != 0) return -1; if (!isNum(a = cdr(numCell(a)))) return !isNum(b = cdr(numCell(b)))? 0 : -1; if (!isNum(b = cdr(numCell(b)))) return +1; n1 = unDig(a), n2 = unDig(b); } else if ((n2 >>= 8) == 0) return +1; } } if (!isCell(y)) return y == T? -1 : +1; a = x, b = y; for (;;) { int n; if (n = compare(car(x),car(y))) return n; if (!isCell(x = cdr(x))) return compare(x, cdr(y)); if (!isCell(y = cdr(y))) return y == T? -1 : +1; if (x == a && y == b) return 0; } } int binSize(any x) { if (isNum(x)) { int n = numBytes(x); if (n < 63) return n + 1; return n + 2 + (n - 63) / 255; } else if (isNil(x)) return 1; else if (isSym(x)) return binSize(name(x)); else { any y = x; int n = 2; while (n += binSize(car(x)), !isNil(x = cdr(x))) { if (x == y) return n + 1; if (!isCell(x)) return n + binSize(x); } return n; } } /*** Error handling ***/ void err(any ex, any x, char *fmt, ...) { va_list ap; char msg[240]; outFrame f; cell c1; va_start(ap,fmt); vsnprintf(msg, sizeof(msg), fmt, ap); va_end(ap); val(Up) = ex ?: Nil; if (x) Push(c1, x); if (msg[0]) { any y; catchFrame *p; val(Msg) = mkStr(msg); for (p = CatchPtr; p; p = p->link) if (y = p->tag) while (isCell(y)) { if (subStr(car(y), val(Msg))) { Thrown = isNil(car(y))? val(Msg) : car(y); unwind(p); longjmp(p->rst, 1); } y = cdr(y); } } Chr = ExtN = 0; Break = NO; Alarm = Line = Nil; f.pid = 0, f.fd = STDERR_FILENO, pushOutFiles(&f); if (InFile && InFile->name) { Env.put('['); outString(InFile->name), Env.put(':'), outWord(InFile->src); Env.put(']'), space(); } if (ex) outString("!? "), print(ex), newline(); if (x) print(x), outString(" -- "); if (msg[0]) { outString(msg), newline(); if (!isNil(val(Err)) && !Jam) Jam = YES, prog(val(Err)), Jam = NO; if (!isatty(STDIN_FILENO) || !isatty(STDOUT_FILENO)) bye(1); load(NULL, '?', Nil); } unwind(NULL); Env.stack = NULL; Env.protect = Env.trace = 0; Env.next = -1; Env.task = Nil; Env.make = Env.yoke = NULL; Env.parser = NULL; longjmp(ErrRst, +1); } // (quit ['any ['any]]) any doQuit(any x) { any y; x = cdr(x), y = evSym(x); { char msg[bufSize(y)]; bufString(y, msg); x = isCell(x = cdr(x))? EVAL(car(x)) : NULL; err(NULL, x, "%s", msg); } } void argError(any ex, any x) {err(ex, x, "Bad argument");} void numError(any ex, any x) {err(ex, x, "Number expected");} void cntError(any ex, any x) {err(ex, x, "Small number expected");} void symError(any ex, any x) {err(ex, x, "Symbol expected");} void extError(any ex, any x) {err(ex, x, "External symbol expected");} void pairError(any ex, any x) {err(ex, x, "Cons pair expected");} void atomError(any ex, any x) {err(ex, x, "Atom expected");} void lstError(any ex, any x) {err(ex, x, "List expected");} void varError(any ex, any x) {err(ex, x, "Variable expected");} void protError(any ex, any x) {err(ex, x, "Protected symbol");} void pipeError(any ex, char *s) {err(ex, NULL, "Pipe %s error", s);} void unwind(catchFrame *catch) { any x; int i, j, n; bindFrame *p; catchFrame *q; while (q = CatchPtr) { while (p = Env.bind) { if ((i = p->i) < 0) { j = i, n = 0; while (++n, ++j && (p = p->link)) if (p->i >= 0 || p->i < i) --j; do { for (p = Env.bind, j = n; --j; p = p->link); if (p->i < 0 && ((p->i -= i) > 0? (p->i = 0) : p->i) == 0) for (j = p->cnt; --j >= 0;) { x = val(p->bnd[j].sym); val(p->bnd[j].sym) = p->bnd[j].val; p->bnd[j].val = x; } } while (--n); } if (Env.bind == q->env.bind) break; if (Env.bind->i == 0) for (i = Env.bind->cnt; --i >= 0;) val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val; Env.bind = Env.bind->link; } while (Env.inFrames != q->env.inFrames) popInFiles(); while (Env.outFrames != q->env.outFrames) popOutFiles(); while (Env.errFrames != q->env.errFrames) popErrFiles(); while (Env.ctlFrames != q->env.ctlFrames) popCtlFiles(); Env = q->env; EVAL(q->fin); CatchPtr = q->link; if (q == catch) return; } while (Env.bind) { if (Env.bind->i == 0) for (i = Env.bind->cnt; --i >= 0;) val(Env.bind->bnd[i].sym) = Env.bind->bnd[i].val; Env.bind = Env.bind->link; } while (Env.inFrames) popInFiles(); while (Env.outFrames) popOutFiles(); while (Env.errFrames) popErrFiles(); while (Env.ctlFrames) popCtlFiles(); } /*** Evaluation ***/ any evExpr(any expr, any x) { any y = car(expr); struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(y)+2]; } f; f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = sizeof(f.bnd) / (2*sizeof(any)) - 1; f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); while (isCell(y)) { f.bnd[f.cnt].sym = car(y); f.bnd[f.cnt].val = EVAL(car(x)); ++f.cnt, x = cdr(x), y = cdr(y); } if (isNil(y)) { do { x = val(f.bnd[--f.i].sym); val(f.bnd[f.i].sym) = f.bnd[f.i].val; f.bnd[f.i].val = x; } while (f.i); x = prog(cdr(expr)); } else if (y != At) { f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x; do { x = val(f.bnd[--f.i].sym); val(f.bnd[f.i].sym) = f.bnd[f.i].val; f.bnd[f.i].val = x; } while (f.i); x = prog(cdr(expr)); } else { int n, cnt; cell *arg; cell c[n = cnt = length(x)]; while (--n >= 0) Push(c[n], EVAL(car(x))), x = cdr(x); do { x = val(f.bnd[--f.i].sym); val(f.bnd[f.i].sym) = f.bnd[f.i].val; f.bnd[f.i].val = x; } while (f.i); n = Env.next, Env.next = cnt; arg = Env.arg, Env.arg = c; x = prog(cdr(expr)); if (cnt) drop(c[cnt-1]); Env.arg = arg, Env.next = n; } while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; return x; } any funq(any x) { any y; if (isSym(x)) return Nil; if (isNum(x)) return (unDig(x)&3) || isNum(cdr(numCell(x)))? Nil : x; for (y = cdr(x); isCell(y); y = cdr(y)) { if (y == x) return Nil; if (isCell(car(y))) { if (isNum(caar(y))) { if (isCell(cdr(y))) return Nil; } else if (isNil(caar(y)) || caar(y) == T) return Nil; } else if (!isNil(cdr(y))) return Nil; } if (!isNil(y)) return Nil; if (isNil(x = car(x))) return T; for (y = x; isCell(y);) if (isNum(car(y)) || isCell(car(y)) || isNil(car(y)) || car(y)==T || x==(y=cdr(y))) return Nil; return isNum(y) || y==T? Nil : x; } bool sharedLib(any x) { void *h; char *p, nm[bufSize(x)]; bufString(x, nm); if (!(p = strchr(nm,':')) || p == nm || p[1] == '\0') return NO; *p++ = '\0'; { int n = Home? strlen(Home) : 0; #ifndef __CYGWIN__ char buf[n + strlen(nm) + 4 + 1]; #else char buf[n + strlen(nm) + 4 + 4 + 1]; #endif if (strchr(nm,'/')) strcpy(buf, nm); else { if (n) memcpy(buf, Home, n); strcpy(buf + n, "lib/"), strcpy(buf + n + 4, nm); #ifdef __CYGWIN__ strcpy(buf + n + 4 + strlen(nm), ".dll"); #endif } if (!(h = dlopen(buf, RTLD_LAZY | RTLD_GLOBAL)) || !(h = dlsym(h,p))) return NO; val(x) = box(num(h)); } return YES; } void undefined(any x, any ex) { if (!sharedLib(x)) err(ex, x, "Undefined"); } static any evList2(any foo, any ex) { cell c1; Push(c1, foo); if (isCell(foo)) { foo = evExpr(foo, cdr(ex)); drop(c1); return foo; } for (;;) { if (isNil(val(foo))) undefined(foo,ex); if (*Signal) sighandler(ex); if (isNum(foo = val(foo))) { foo = evSubr(foo,ex); drop(c1); return foo; } if (isCell(foo)) { foo = evExpr(foo, cdr(ex)); drop(c1); return foo; } } } /* Evaluate a list */ any evList(any ex) { any foo; if (!isSym(foo = car(ex))) { if (isNum(foo)) return ex; if (*Signal) sighandler(ex); if (isNum(foo = evList(foo))) return evSubr(foo,ex); return evList2(foo,ex); } for (;;) { if (isNil(val(foo))) undefined(foo,ex); if (*Signal) sighandler(ex); if (isNum(foo = val(foo))) return evSubr(foo,ex); if (isCell(foo)) return evExpr(foo, cdr(ex)); } } /* Evaluate any to sym */ any evSym(any x) {return xSym(EVAL(car(x)));} any xSym(any x) { int i; any nm; cell c1, c2; if (isSym(x)) return x; Push(c1,x); nm = NULL, pack(x, &i, &nm, &c2); drop(c1); return nm? consStr(data(c2)) : Nil; } /* Evaluate count */ long evCnt(any ex, any x) {return xCnt(ex, EVAL(car(x)));} long xCnt(any ex, any x) { NeedCnt(ex,x); return unBox(x); } /* Evaluate double */ double evDouble(any ex, any x) { x = EVAL(car(x)); NeedNum(ex,x); return numToDouble(x); } // (args) -> flg any doArgs(any ex __attribute__((unused))) { return Env.next > 0? T : Nil; } // (next) -> any any doNext(any ex __attribute__((unused))) { if (Env.next > 0) return data(Env.arg[--Env.next]); if (Env.next == 0) Env.next = -1; return Nil; } // (arg ['cnt]) -> any any doArg(any ex) { long n; if (Env.next < 0) return Nil; if (!isCell(cdr(ex))) return data(Env.arg[Env.next]); if ((n = evCnt(ex,cdr(ex))) > 0 && n <= Env.next) return data(Env.arg[Env.next - n]); return Nil; } // (rest) -> lst any doRest(any x) { int i; cell c1; if ((i = Env.next) <= 0) return Nil; Push(c1, x = cons(data(Env.arg[--i]), Nil)); while (i) x = cdr(x) = cons(data(Env.arg[--i]), Nil); return Pop(c1); } static struct tm *TM; any mkDat(int y, int m, int d) { int n; static char mon[13] = {31,31,28,31,30,31,30,31,31,30,31,30,31}; if (m<1 || m>12 || d<1 || d>mon[m] && (m!=2 || d!=29 || y%4 || !(y%100) && y%400)) return Nil; n = (12*y + m - 3) / 12; return boxCnt((4404*y+367*m-1094)/12 - 2*n + n/4 - n/100 + n/400 + d); } // (date ['T]) -> dat // (date 'dat) -> (y m d) // (date 'y 'm 'd) -> dat | NIL // (date '(y m d)) -> dat | NIL any doDate(any ex) { any x, z; int y, m, d, n; cell c1; if (!isCell(x = cdr(ex))) { gettimeofday(&Tv,NULL); TM = localtime(&Tv.tv_sec); return mkDat(TM->tm_year+1900, TM->tm_mon+1, TM->tm_mday); } if ((z = EVAL(car(x))) == T) { gettimeofday(&Tv,NULL); TM = gmtime(&Tv.tv_sec); return mkDat(TM->tm_year+1900, TM->tm_mon+1, TM->tm_mday); } if (isNil(z)) return Nil; if (isCell(z)) return mkDat(xCnt(ex, car(z)), xCnt(ex, cadr(z)), xCnt(ex, caddr(z))); if (!isCell(x = cdr(x))) { n = xCnt(ex,z); y = (100*n - 20) / 3652425; n += (y - y/4); y = (100*n - 20) / 36525; n -= 36525*y / 100; m = (10*n - 5) / 306; d = (10*n - 306*m + 5) / 10; if (m < 10) m += 3; else ++y, m -= 9; Push(c1, cons(boxCnt(d), Nil)); data(c1) = cons(boxCnt(m), data(c1)); data(c1) = cons(boxCnt(y), data(c1)); return Pop(c1); } y = xCnt(ex,z); m = evCnt(ex,x); return mkDat(y, m, evCnt(ex,cdr(x))); } any mkTime(int h, int m, int s) { if (h < 0 || h > 23 || m < 0 || m > 59 || s < 0 || s > 60) return Nil; return boxCnt(h * 3600 + m * 60 + s); } // (time ['T]) -> tim // (time 'tim) -> (h m s) // (time 'h 'm ['s]) -> tim | NIL // (time '(h m [s])) -> tim | NIL any doTime(any ex) { any x, z; int h, m, s; cell c1; struct tm *p; if (!isCell(x = cdr(ex))) { gettimeofday(&Tv,NULL); p = localtime(&Tv.tv_sec); return boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec); } if ((z = EVAL(car(x))) == T) return TM? boxCnt(TM->tm_hour * 3600 + TM->tm_min * 60 + TM->tm_sec) : Nil; if (isNil(z)) return Nil; if (isCell(z)) return mkTime(xCnt(ex, car(z)), xCnt(ex, cadr(z)), isCell(cddr(z))? xCnt(ex, caddr(z)) : 0); if (!isCell(x = cdr(x))) { s = xCnt(ex,z); Push(c1, cons(boxCnt(s % 60), Nil)); data(c1) = cons(boxCnt(s / 60 % 60), data(c1)); data(c1) = cons(boxCnt(s / 3600), data(c1)); return Pop(c1); } h = xCnt(ex, z); m = evCnt(ex, x); return mkTime(h, m, isCell(cdr(x))? evCnt(ex, cdr(x)) : 0); } // (usec ['flg]) -> num any doUsec(any ex) { if (!isNil(EVAL(cadr(ex)))) return boxCnt(Tv.tv_usec); gettimeofday(&Tv,NULL); return boxWord2((word2)Tv.tv_sec*1000000 + Tv.tv_usec - USec); } // (pwd) -> sym any doPwd(any x) { char *p; if ((p = getcwd(NULL,0)) == NULL) return Nil; x = mkStr(p); free(p); return x; } // (cd 'any) -> sym any doCd(any x) { x = evSym(cdr(x)); { char *p, path[pathSize(x)]; pathString(x, path); if ((p = getcwd(NULL,0)) == NULL || path[0] && chdir(path) < 0) return Nil; x = mkStr(p); free(p); return x; } } // (ctty 'sym|pid) -> flg any doCtty(any ex) { any x; if (isNum(x = EVAL(cadr(ex)))) TtyPid = unDig(x) / 2; else { if (!isSym(x)) argError(ex,x); { char tty[bufSize(x)]; bufString(x, tty); if (!freopen(tty,"r",stdin) || !freopen(tty,"w",stdout) || !freopen(tty,"w",stderr)) return Nil; OutFiles[STDOUT_FILENO]->tty = YES; } } return T; } // (info 'any ['flg]) -> (cnt|T dat . tim) any doInfo(any x) { any y; cell c1; struct tm *p; struct stat st; y = evSym(x = cdr(x)); { char nm[pathSize(y)]; pathString(y, nm); x = cdr(x); if ((isNil(EVAL(car(x)))? stat(nm, &st) : lstat(nm, &st)) < 0) return Nil; p = gmtime(&st.st_mtime); Push(c1, boxCnt(p->tm_hour * 3600 + p->tm_min * 60 + p->tm_sec)); data(c1) = cons(mkDat(p->tm_year+1900, p->tm_mon+1, p->tm_mday), data(c1)); data(c1) = cons(S_ISDIR(st.st_mode)? T : boxWord2((word2)st.st_size), data(c1)); return Pop(c1); } } // (file) -> (sym1 sym2 . num) | NIL any doFile(any ex __attribute__((unused))) { char *s, *p; cell c1; if (!InFile || !InFile->name) return Nil; Push(c1, boxCnt(InFile->src)); s = strdup(InFile->name); if (p = strrchr(s, '/')) { data(c1) = cons(mkStr(p+1), data(c1)); *(p+1) = '\0'; data(c1) = cons(mkStr(s), data(c1)); } else { data(c1) = cons(mkStr(s), data(c1)); data(c1) = cons(mkStr("./"), data(c1)); } free(s); return Pop(c1); } // (dir ['any] ['flg]) -> lst any doDir(any x) { any y; DIR *dp; struct dirent *p; cell c1; if (isNil(y = evSym(x = cdr(x)))) dp = opendir("."); else { char nm[pathSize(y)]; pathString(y, nm); dp = opendir(nm); } if (!dp) return Nil; x = cdr(x), x = EVAL(car(x)); do { if (!(p = readdir(dp))) { closedir(dp); return Nil; } } while (isNil(x) && p->d_name[0] == '.'); Push(c1, y = cons(mkStr(p->d_name), Nil)); while (p = readdir(dp)) if (!isNil(x) || p->d_name[0] != '.') y = cdr(y) = cons(mkStr(p->d_name), Nil); closedir(dp); return Pop(c1); } // (cmd ['any]) -> sym any doCmd(any x) { if (isNil(x = evSym(cdr(x)))) return mkStr(AV0); bufString(x, AV0); return x; } // (argv [var ..] [. sym]) -> lst|sym any doArgv(any ex) { any x, y; char **p; cell c1; if (*(p = AV) && strcmp(*p,"-") == 0) ++p; if (isNil(x = cdr(ex))) { if (!*p) return Nil; Push(c1, x = cons(mkStr(*p++), Nil)); while (*p) x = cdr(x) = cons(mkStr(*p++), Nil); return Pop(c1); } do { if (!isCell(x)) { NeedSym(ex,x); CheckVar(ex,x); if (!*p) return val(x) = Nil; Push(c1, y = cons(mkStr(*p++), Nil)); while (*p) y = cdr(y) = cons(mkStr(*p++), Nil); return val(x) = Pop(c1); } y = car(x); NeedVar(ex,y); CheckVar(ex,y); val(y) = *p? mkStr(*p++) : Nil; } while (!isNil(x = cdr(x))); return val(y); } // (opt) -> sym any doOpt(any ex __attribute__((unused))) { return *AV && strcmp(*AV,"-")? mkStr(*AV++) : Nil; } // (version ['flg]) -> lst any doVersion(any x) { int i; cell c1; x = cdr(x); if (isNil(EVAL(car(x)))) { for (i = 0; i < 4; ++i) { outWord((word)Version[i]); Env.put(i == 3? ' ' : '.'); } Env.put('C'); newline(); } Push(c1, Nil); i = 4; do data(c1) = cons(box(Version[--i] * 2), data(c1)); while (i); return Pop(c1); } any loadAll(any ex) { any x = Nil; while (*AV && strcmp(*AV,"-") != 0) x = load(ex, 0, mkStr(*AV++)); return x; } /*** Main ***/ static void init(int ac, char *av[]) { char *p; sigset_t sigs; AV0 = *av++; AV = av; heapAlloc(); initSymbols(); if (ac >= 2 && strcmp(av[ac-2], "+") == 0) val(Dbg) = T, av[ac-2] = NULL; if (av[0] && *av[0] != '-' && (p = strrchr(av[0], '/')) && !(p == av[0]+1 && *av[0] == '.')) { Home = malloc(p - av[0] + 2); memcpy(Home, av[0], p - av[0] + 1); Home[p - av[0] + 1] = '\0'; } Env.get = getStdin; InFile = initInFile(STDIN_FILENO, NULL); Env.put = putStdout; initOutFile(STDERR_FILENO); OutFile = initOutFile(STDOUT_FILENO); Env.task = Alarm = Sigio = Line = Nil; setrlimit(RLIMIT_STACK, &ULim); Tio = tcgetattr(STDIN_FILENO, &OrgTermio) == 0; ApplyArgs = cons(cons(consSym(Nil,Nil), Nil), Nil); ApplyBody = cons(Nil,Nil); sigfillset(&sigs); sigprocmask(SIG_UNBLOCK, &sigs, NULL); iSignal(SIGHUP, sig); iSignal(SIGINT, sigTerm); iSignal(SIGUSR1, sig); iSignal(SIGUSR2, sig); iSignal(SIGALRM, sig); iSignal(SIGTERM, sig); iSignal(SIGIO, sig); signal(SIGCHLD, sigChld); signal(SIGPIPE, SIG_IGN); signal(SIGTTIN, SIG_IGN); signal(SIGTTOU, SIG_IGN); gettimeofday(&Tv,NULL); USec = (word2)Tv.tv_sec*1000000 + Tv.tv_usec; } int MAIN(int ac, char *av[]) { init(ac,av); if (!setjmp(ErrRst)) { loadAll(NULL); ++Repl; iSignal(SIGINT, sig); } for (;;) load(NULL, ':', Nil); } picolisp-3.1.5.2.orig/src/mkVers0000755000000000000000000000035112265263724015133 0ustar rootroot#!../bin/picolisp ../lib.l # 07mar11abu # (c) Software Lab. Alexander Burger (load "../src64/version.l") (out "vers.h" (prinl "static byte Version[4] = {" (glue "," *Version) "};" ) ) (bye) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src/net.c0000644000000000000000000001275312265263724014701 0ustar rootroot/* 06feb13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" #include #include #include #include static void ipErr(any ex, char *s) { err(ex, NULL, "IP %s error: %s", s, strerror(errno)); } // (port ['T] 'cnt|(cnt . cnt) ['var]) -> cnt any doPort(any ex) { any x, y; int type, sd, n; unsigned short port; struct sockaddr_in6 addr; x = cdr(ex); type = SOCK_STREAM; if ((y = EVAL(car(x))) == T) type = SOCK_DGRAM, x = cdr(x), y = EVAL(car(x)); if ((sd = socket(AF_INET6, type, 0)) < 0) ipErr(ex, "socket"); closeOnExec(ex, sd); n = 0; if (setsockopt(sd, IPPROTO_IPV6, IPV6_V6ONLY, &n, sizeof(n)) < 0) ipErr(ex, "IPV6_V6ONLY"); memset(&addr, 0, sizeof(addr)); addr.sin6_family = AF_INET6; addr.sin6_addr = in6addr_any; if (isNum(y)) { if ((port = (unsigned short)xCnt(ex,y)) != 0) { n = 1; if (setsockopt(sd, SOL_SOCKET, SO_REUSEADDR, &n, sizeof(n)) < 0) ipErr(ex, "SO_REUSEADDR"); } } else if (isCell(y)) port = (unsigned short)xCnt(ex,car(y)); else argError(ex,y); for (;;) { addr.sin6_port = htons(port); if (bind(sd, (struct sockaddr*)&addr, sizeof(addr)) >= 0) break; if (!isCell(y) || ++port > xCnt(ex,cdr(y))) close(sd), ipErr(ex, "bind"); } if (type == SOCK_STREAM && listen(sd,5) < 0) close(sd), ipErr(ex, "listen"); if (!isNil(y = EVAL(cadr(x)))) { socklen_t len = sizeof(addr); if (getsockname(sd, (struct sockaddr*)&addr, &len) < 0) close(sd), ipErr(ex, "getsockname"); NeedVar(ex,y); CheckVar(ex,y); val(y) = boxCnt(ntohs(addr.sin6_port)); } return boxCnt(sd); } static any tcpAccept(int sd) { int i, f, sd2; char s[INET6_ADDRSTRLEN]; struct sockaddr_in6 addr; f = nonblocking(sd); i = 200; do { socklen_t len = sizeof(addr); if ((sd2 = accept(sd, (struct sockaddr*)&addr, &len)) >= 0) { fcntl(sd, F_SETFL, f); #ifndef __linux__ fcntl(sd2, F_SETFL, 0); #endif inet_ntop(AF_INET6, &addr.sin6_addr, s, INET6_ADDRSTRLEN); val(Adr) = mkStr(s); initInFile(sd2,NULL), initOutFile(sd2); return boxCnt(sd2); } usleep(100000); // 100 ms } while (errno == EAGAIN && --i >= 0); fcntl(sd, F_SETFL, f); return NULL; } // (accept 'cnt) -> cnt | NIL any doAccept(any ex) { return tcpAccept((int)evCnt(ex, cdr(ex))) ?: Nil; } // (listen 'cnt1 ['cnt2]) -> cnt | NIL any doListen(any ex) { any x; int sd; long ms; sd = (int)evCnt(ex, x = cdr(ex)); x = cdr(x); ms = isNil(x = EVAL(car(x)))? -1 : xCnt(ex,x); for (;;) { if (!waitFd(ex, sd, ms)) return Nil; if (x = tcpAccept(sd)) return x; } } // (host 'any) -> sym any doHost(any x) { x = evSym(cdr(x)); { struct addrinfo *lst, *p; char host[NI_MAXHOST]; char nm[bufSize(x)]; bufString(x, nm); if (getaddrinfo(nm, NULL, NULL, &lst)) return Nil; x = Nil; for (p = lst; p; p = p->ai_next) { if (getnameinfo(p->ai_addr, p->ai_addrlen, host, NI_MAXHOST, NULL, 0, NI_NAMEREQD) == 0 && host[0]) { x = mkStr(host); break; } } freeaddrinfo(lst); return x; } } static struct addrinfo *server(int type, any node, any service) { struct addrinfo hints, *lst; char nd[bufSize(node)], sv[bufSize(service)]; memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; hints.ai_socktype = type; bufString(node, nd), bufString(service, sv); return getaddrinfo(nd, sv, &hints, &lst)? NULL : lst; } // (connect 'any1 'any2) -> cnt | NIL any doConnect(any ex) { struct addrinfo *lst, *p; any port; int sd; cell c1; Push(c1, evSym(cdr(ex))); port = evSym(cddr(ex)); for (p = lst = server(SOCK_STREAM, Pop(c1), port); p; p = p->ai_next) { if ((sd = socket(p->ai_family, p->ai_socktype, 0)) >= 0) { if (connect(sd, p->ai_addr, p->ai_addrlen) == 0) { closeOnExec(ex, sd); initInFile(sd,NULL), initOutFile(sd); freeaddrinfo(lst); return boxCnt(sd); } close(sd); } } freeaddrinfo(lst); return Nil; } /*** UDP send/receive ***/ #define UDPMAX 4096 static byte *UdpBuf, *UdpPtr; static void putUdp(int c) { if (UdpPtr == UdpBuf + UDPMAX) err(NULL, NULL, "UDP overflow"); *UdpPtr++ = c; } static int getUdp(void) { if (UdpPtr == UdpBuf + UDPMAX) return -1; return *UdpPtr++; } // (udp 'any1 'any2 'any3) -> any // (udp 'cnt) -> any any doUdp(any ex) { any x, y; cell c1; struct addrinfo *lst, *p; int sd; byte buf[UDPMAX]; x = cdr(ex), data(c1) = EVAL(car(x)); if (!isCell(x = cdr(x))) { if (recv((int)xCnt(ex, data(c1)), buf, UDPMAX, 0) < 0) return Nil; getBin = getUdp, UdpPtr = UdpBuf = buf; return binRead(ExtN) ?: Nil; } Save(c1); data(c1) = xSym(data(c1)); y = evSym(x); drop(c1); if (lst = server(SOCK_DGRAM, data(c1), y)) { x = cdr(x), x = EVAL(car(x)); putBin = putUdp, UdpPtr = UdpBuf = buf, binPrint(ExtN, x); for (p = lst; p; p = p->ai_next) { if ((sd = socket(p->ai_family, p->ai_socktype, 0)) >= 0) { sendto(sd, buf, UdpPtr-buf, 0, p->ai_addr, p->ai_addrlen); close(sd); freeaddrinfo(lst); return x; } } freeaddrinfo(lst); } return Nil; } picolisp-3.1.5.2.orig/src/pico.h0000644000000000000000000004543012265263724015050 0ustar rootroot/* 28aug13abu * (c) Software Lab. Alexander Burger */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #ifndef NOWAIT #include // tcc doen't like it #endif #ifndef __CYGWIN__ #define MAIN main #else #define MAIN main2 #endif #define WORD ((int)sizeof(long)) #define BITS (8*WORD) #define MASK ((word)-1) #define CELLS (1024*1024/sizeof(cell)) // Heap allocation unit 1MB #define IHASH 4999 // Internal hash table size (should be prime) #define EHASH 49999 // External hash table size (should be prime) #define TOP 0x10000 // Character Top typedef unsigned long word; typedef unsigned char byte; typedef unsigned char *ptr; typedef unsigned long long word2; typedef long long adr; #undef bool typedef enum {NO,YES} bool; typedef struct cell { // PicoLisp primary data type struct cell *car; struct cell *cdr; } cell, *any; typedef any (*fun)(any); typedef struct heap { cell cells[CELLS]; struct heap *next; } heap; typedef struct child { pid_t pid; int hear, tell; int ofs, cnt; byte *buf; } child; typedef struct bindFrame { struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[1]; } bindFrame; typedef struct inFile { int fd, ix, cnt, next; int line, src; char *name; byte buf[BUFSIZ]; } inFile; typedef struct outFile { int fd, ix; bool tty; byte buf[BUFSIZ]; } outFile; typedef struct inFrame { struct inFrame *link; void (*get)(void); pid_t pid; int fd; } inFrame; typedef struct outFrame { struct outFrame *link; void (*put)(int); pid_t pid; int fd; } outFrame; typedef struct errFrame { struct errFrame *link; int fd; } errFrame; typedef struct ctlFrame { struct ctlFrame *link; int fd; } ctlFrame; typedef struct parseFrame { any name; word dig, eof; } parseFrame; typedef struct stkEnv { cell *stack, *arg; bindFrame *bind; int next, protect, trace; any cls, key, task, *make, *yoke; inFrame *inFrames; outFrame *outFrames; errFrame *errFrames; ctlFrame *ctlFrames; parseFrame *parser; void (*get)(void); void (*put)(int); } stkEnv; typedef struct catchFrame { struct catchFrame *link; any tag, fin; stkEnv env; jmp_buf rst; } catchFrame; /*** Macros ***/ #define Free(p) ((p)->car=Avail, Avail=(p)) #define cellPtr(x) ((any)((word)(x) & ~(2*WORD-1))) /* Number access */ #define num(x) ((word)(x)) #define numPtr(x) ((any)(num(x)+(WORD/2))) #define numCell(n) ((any)(num(n)-(WORD/2))) #define box(n) (consNum(n,Nil)) #define unDig(x) num(car(numCell(x))) #define setDig(x,v) (car(numCell(x))=(any)(v)) #define isNeg(x) (unDig(x) & 1) #define pos(x) (car(numCell(x)) = (any)(unDig(x) & ~1)) #define neg(x) (car(numCell(x)) = (any)(unDig(x) ^ 1)) #define lo(w) num((w)&MASK) #define hi(w) num((w)>>BITS) /* Symbol access */ #define symPtr(x) ((any)&(x)->cdr) #define val(x) ((x)->car) #define tail(s) (((s)-1)->cdr) #define tail1(s) ((any)(num(tail(s)) & ~1)) #define Tail(s,v) (tail(s) = (any)(num(v) | num(tail(s)) & 1)) #define ext(x) ((any)(num(x) | 1)) #define mkExt(s) (*(word*)&tail(s) |= 1) /* Cell access */ #define car(x) ((x)->car) #define cdr(x) ((x)->cdr) #define caar(x) (car(car(x))) #define cadr(x) (car(cdr(x))) #define cdar(x) (cdr(car(x))) #define cddr(x) (cdr(cdr(x))) #define caaar(x) (car(car(car(x)))) #define caadr(x) (car(car(cdr(x)))) #define cadar(x) (car(cdr(car(x)))) #define caddr(x) (car(cdr(cdr(x)))) #define cdaar(x) (cdr(car(car(x)))) #define cdadr(x) (cdr(car(cdr(x)))) #define cddar(x) (cdr(cdr(car(x)))) #define cdddr(x) (cdr(cdr(cdr(x)))) #define caaaar(x) (car(car(car(car(x))))) #define caaadr(x) (car(car(car(cdr(x))))) #define caadar(x) (car(car(cdr(car(x))))) #define caaddr(x) (car(car(cdr(cdr(x))))) #define cadaar(x) (car(cdr(car(car(x))))) #define cadadr(x) (car(cdr(car(cdr(x))))) #define caddar(x) (car(cdr(cdr(car(x))))) #define cadddr(x) (car(cdr(cdr(cdr(x))))) #define cdaaar(x) (cdr(car(car(car(x))))) #define cdaadr(x) (cdr(car(car(cdr(x))))) #define cdadar(x) (cdr(car(cdr(car(x))))) #define cdaddr(x) (cdr(car(cdr(cdr(x))))) #define cddaar(x) (cdr(cdr(car(car(x))))) #define cddadr(x) (cdr(cdr(car(cdr(x))))) #define cdddar(x) (cdr(cdr(cdr(car(x))))) #define cddddr(x) (cdr(cdr(cdr(cdr(x))))) #define data(c) ((c).car) #define Save(c) ((c).cdr=Env.stack, Env.stack=&(c)) #define drop(c) (Env.stack=(c).cdr) #define Push(c,x) (data(c)=(x), Save(c)) #define Tuck(c1,c2,x) (data(c1)=(x), (c1).cdr=(c2).cdr, (c2).cdr=&(c1)) #define Pop(c) (drop(c), data(c)) #define Bind(s,f) ((f).i=0, (f).cnt=1, (f).bnd[0].sym=(s), (f).bnd[0].val=val(s), (f).link=Env.bind, Env.bind=&(f)) #define Unbind(f) (val((f).bnd[0].sym)=(f).bnd[0].val, Env.bind=(f).link) /* Predicates */ #define isNil(x) ((x)==Nil) #define isNum(x) (num(x)&(WORD/2)) #define isSym(x) (num(x)&WORD) #define isCell(x) (!(num(x)&(2*WORD-2))) #define isExt(s) (num(tail(s))&1) #define IsZero(n) (!unDig(n) && !isNum(cdr(numCell(n)))) /* Evaluation */ #define EVAL(x) (isNum(x)? x : isSym(x)? val(x) : evList(x)) #define evSubr(f,x) (*(fun)unDig(f))(x) /* Error checking */ #define NeedNum(ex,x) if (!isNum(x)) numError(ex,x) #define NeedCnt(ex,x) if (!isNum(x) || isNum(cdr(numCell(x)))) cntError(ex,x) #define NeedSym(ex,x) if (!isSym(x)) symError(ex,x) #define NeedExt(ex,x) if (!isSym(x) || !isExt(x)) extError(ex,x) #define NeedPair(ex,x) if (!isCell(x)) pairError(ex,x) #define NeedAtom(ex,x) if (isCell(x)) atomError(ex,x) #define NeedLst(ex,x) if (!isCell(x) && !isNil(x)) lstError(ex,x) #define NeedVar(ex,x) if (isNum(x)) varError(ex,x) #define CheckNil(ex,x) if (isNil(x)) protError(ex,x) #define CheckVar(ex,x) if ((x)>=Nil && (x)<=T) protError(ex,x) /* External symbol access */ #define Fetch(ex,x) if (isExt(x)) db(ex,x,1) #define Touch(ex,x) if (isExt(x)) db(ex,x,2) /* Globals */ extern int Repl, Chr, Slot, Spkr, Mic, Hear, Tell, Children, ExtN; extern char **AV, *AV0, *Home; extern child *Child; extern heap *Heaps; extern cell *Avail; extern stkEnv Env; extern catchFrame *CatchPtr; extern struct termios OrgTermio, *Termio; extern int InFDs, OutFDs; extern inFile *InFile, **InFiles; extern outFile *OutFile, **OutFiles; extern int (*getBin)(void); extern void (*putBin)(int); extern any TheKey, TheCls, Thrown; extern any Alarm, Sigio, Line, Zero, One; extern any Intern[IHASH], Transient[IHASH], Extern[EHASH]; extern any ApplyArgs, ApplyBody, DbVal, DbTail; extern any Nil, DB, Meth, Quote, T; extern any Solo, PPid, Pid, At, At2, At3, This, Prompt, Dbg, Zap, Ext, Scl, Class; extern any Run, Hup, Sig1, Sig2, Up, Err, Msg, Uni, Led, Tsm, Adr, Fork, Bye; extern bool Break; extern sig_atomic_t Signal[NSIG]; /* Prototypes */ void *alloc(void*,size_t); any apply(any,any,bool,int,cell*); void argError(any,any) __attribute__ ((noreturn)); void atomError(any,any) __attribute__ ((noreturn)); void begString(void); void bigAdd(any,any); int bigCompare(any,any); any bigCopy(any); void bigSub(any,any); void binPrint(int,any); any binRead(int); int binSize(any); adr blk64(any); any boxChar(int,int*,any*); any boxWord2(word2); any brkLoad(any); int bufSize(any); void bufString(any,char*); void bye(int) __attribute__ ((noreturn)); void byteSym(int,int*,any*); void pairError(any,any) __attribute__ ((noreturn)); void charSym(int,int*,any*); any circ(any); void closeInFile(int); void closeOnExec(any,int); void closeOutFile(int); void cntError(any,any) __attribute__ ((noreturn)); int compare(any,any); any cons(any,any); any consNum(word,any); any consStr(any); any consSym(any,any); void newline(void); void ctOpen(any,any,ctlFrame*); void db(any,any,int); int dbSize(any,any); void digAdd(any,word); void digDiv2(any); void digMul(any,word); void digMul2(any); void digSub1(any); any doubleToNum(double); unsigned long ehash(any); any endString(void); bool eol(void); bool equal(any,any); void erOpen(any,any,errFrame*); void err(any,any,char*,...) __attribute__ ((noreturn)); any evExpr(any,any); long evCnt(any,any); double evDouble(any,any); any evList(any); any evSym(any); void execError(char*) __attribute__ ((noreturn)); void extError(any,any) __attribute__ ((noreturn)); any extOffs(int,any); any findHash(any,any*); int firstByte(any); bool flush(outFile*); void flushAll(void); pid_t forkLisp(any); any funq(any); any get(any,any); int getChar(void); void getStdin(void); void giveup(char*) __attribute__ ((noreturn)); bool hashed(any,any); void heapAlloc(void); any idx(any,any,int); unsigned long ihash(any); inFile *initInFile(int,char*); outFile *initOutFile(int); void initSymbols(void); any intern(char*); bool isBlank(any); bool isLife(any); void lstError(any,any) __attribute__ ((noreturn)); any load(any,int,any); any loadAll(any); any method(any); any mkChar(int); any mkDat(int,int,int); any mkName(char*); any mkStr(char*); any mkTime(int,int,int); any name(any); any new64(adr,any); any newId(any,int); int nonblocking(int); int numBytes(any); void numError(any,any) __attribute__ ((noreturn)); double numToDouble(any); any numToSym(any,int,int,int); void outName(any); void outNum(any); void outString(char*); void outWord(word); void pack(any,int*,any*,cell*); int pathSize(any); void pathString(any,char*); void pipeError(any,char*); void popCtlFiles(void); void popInFiles(void); void popErrFiles(void); void popOutFiles(void); void pr(int,any); void prin(any); void prin1(any); void print(any); void print1(any); void prn(long); void protError(any,any) __attribute__ ((noreturn)); void pushCtlFiles(ctlFrame*); void pushInFiles(inFrame*); void pushErrFiles(errFrame*); void pushOutFiles(outFrame*); void put(any,any,any); void putStdout(int); void rdOpen(any,any,inFrame*); any read1(int); int rdBytes(int,byte*,int,bool); int secondByte(any); void setCooked(void); void setRaw(void); bool sharedLib(any); void sighandler(any); int slow(inFile*,bool); void space(void); bool subStr(any,any); int symByte(any); int symChar(any); void symError(any,any) __attribute__ ((noreturn)); any symToNum(any,int,int,int); word2 unBoxWord2(any); void undefined(any,any); void unintern(any,any*); void unwind (catchFrame*); void varError(any,any) __attribute__ ((noreturn)); long waitFd(any,int,long); bool wrBytes(int,byte*,int); void wrOpen(any,any,outFrame*); long xCnt(any,any); any xSym(any); void zapZero(any); any doAbs(any); any doAccept(any); any doAdd(any); any doAdr(any); any doAlarm(any); any doAll(any); any doAnd(any); any doAny(any); any doAppend(any); any doApply(any); any doArg(any); any doArgs(any); any doArgv(any); any doArrow(any); any doAsoq(any); any doAs(any); any doAssoc(any); any doAt(any); any doAtom(any); any doBind(any); any doBitAnd(any); any doBitOr(any); any doBitQ(any); any doBitXor(any); any doBool(any); any doBox(any); any doBoxQ(any); any doBreak(any); any doBy(any); any doBye(any) __attribute__ ((noreturn)); any doBytes(any); any doCaaaar(any); any doCaaadr(any); any doCaaar(any); any doCaadar(any); any doCaaddr(any); any doCaadr(any); any doCaar(any); any doCadaar(any); any doCadadr(any); any doCadar(any); any doCaddar(any); any doCadddr(any); any doCaddr(any); any doCadr(any); any doCall(any); any doCar(any); any doCase(any); any doCasq(any); any doCatch(any); any doCdaaar(any); any doCdaadr(any); any doCdaar(any); any doCdadar(any); any doCdaddr(any); any doCdadr(any); any doCd(any); any doCdar(any); any doCddaar(any); any doCddadr(any); any doCddar(any); any doCdddar(any); any doCddddr(any); any doCdddr(any); any doCddr(any); any doCdr(any); any doChain(any); any doChar(any); any doChop(any); any doCirc(any); any doCircQ(any); any doClip(any); any doClose(any); any doCmd(any); any doCnt(any); any doCol(any); any doCommit(any); any doCon(any); any doConc(any); any doCond(any); any doConnect(any); any doCons(any); any doCopy(any); any doCtl(any); any doCtty(any); any doCut(any); any doDate(any); any doDbck(any); any doDe(any); any doDec(any); any doDef(any); any doDefault(any); any doDel(any); any doDelete(any); any doDelq(any); any doDiff(any); any doDir(any); any doDiv(any); any doDm(any); any doDo(any); any doE(any); any doEcho(any); any doEnv(any); any doEof(any); any doEol(any); any doEq(any); any doEq0(any); any doEqT(any); any doEqual(any); any doErr(any); any doEval(any); any doExt(any); any doExtern(any); any doExtQ(any); any doExtra(any); any doExtract(any); any doFifo(any); any doFile(any); any doFill(any); any doFilter(any); any doFin(any); any doFinally(any); any doFind(any); any doFish(any); any doFlgQ(any); any doFlip(any); any doFlush(any); any doFold(any); any doFor(any); any doFork(any); any doFormat(any); any doFree(any); any doFrom(any); any doFull(any); any doFunQ(any); any doGc(any); any doGe(any); any doGe0(any); any doGet(any); any doGetd(any); any doGetl(any); any doGlue(any); any doGt(any); any doGt0(any); any doHash(any); any doHead(any); any doHeap(any); any doHear(any); any doHide(any); any doHost(any); any doId(any); any doIdx(any); any doIf(any); any doIf2(any); any doIfn(any); any doIn(any); any doInc(any); any doIndex(any); any doInfo(any); any doIntern(any); any doIpid(any); any doIsa(any); any doJob(any); any doJournal(any); any doKey(any); any doKill(any); any doLast(any); any doLe(any); any doLe0(any); any doLength(any); any doLet(any); any doLetQ(any); any doLieu(any); any doLine(any); any doLines(any); any doLink(any); any doList(any); any doListen(any); any doLit(any); any doLstQ(any); any doLoad(any); any doLock(any); any doLoop(any); any doLowQ(any); any doLowc(any); any doLt(any); any doLt0(any); any doLup(any); any doMade(any); any doMake(any); any doMap(any); any doMapc(any); any doMapcan(any); any doMapcar(any); any doMapcon(any); any doMaplist(any); any doMaps(any); any doMark(any); any doMatch(any); any doMax(any); any doMaxi(any); any doMember(any); any doMemq(any); any doMeta(any); any doMeth(any); any doMethod(any); any doMin(any); any doMini(any); any doMix(any); any doMmeq(any); any doMul(any); any doMulDiv(any); any doName(any); any doNand(any); any doNEq(any); any doNEq0(any); any doNEqT(any); any doNEqual(any); any doNeed(any); any doNew(any); any doNext(any); any doNil(any); any doNond(any); any doNor(any); any doNot(any); any doNth(any); any doNumQ(any); any doOff(any); any doOffset(any); any doOn(any); any doOne(any); any doOnOff(any); any doOpen(any); any doOpid(any); any doOpt(any); any doOr(any); any doOut(any); any doPack(any); any doPair(any); any doPass(any); any doPath(any); any doPatQ(any); any doPeek(any); any doPick(any); any doPipe(any); any doPoll(any); any doPool(any); any doPop(any); any doPort(any); any doPr(any); any doPreQ(any); any doPrin(any); any doPrinl(any); any doPrint(any); any doPrintln(any); any doPrintsp(any); any doPrior(any); any doProg(any); any doProg1(any); any doProg2(any); any doProp(any); any doPropCol(any); any doProtect(any); any doProve(any); any doPush(any); any doPush1(any); any doPut(any); any doPutl(any); any doPwd(any); any doQueue(any); any doQuit(any); any doQuote(any); any doRand(any); any doRange(any); any doRank(any); any doRaw(any); any doRd(any); any doRead(any); any doRem(any); any doReplace(any); any doRest(any); any doReverse(any); any doRewind(any); any doRollback(any); any doRot(any); any doRun(any); any doSect(any); any doSeed(any); any doSeek(any); any doSemicol(any); any doSend(any); any doSeq(any); any doSet(any); any doSetCol(any); any doSetq(any); any doShift(any); any doSigio(any); any doSize(any); any doSkip(any); any doSort(any); any doSpace(any); any doSplit(any); any doSpQ(any); any doSqrt(any); any doState(any); any doStem(any); any doStr(any); any doStrip(any); any doStrQ(any); any doSub(any); any doSubQ(any); any doSum(any); any doSuper(any); any doSwap(any); any doSym(any); any doSymQ(any); any doSync(any); any doSys(any); any doT(any); any doTail(any); any doTell(any); any doText(any); any doThrow(any); any doTick(any); any doTill(any); any doTime(any); any doTouch(any); any doTrace(any); any doTrim(any); any doTry(any); any doType(any); any doUdp(any); any doUnify(any); any doUnless(any); any doUntil(any); any doUp(any); any doUppQ(any); any doUppc(any); any doUse(any); any doUsec(any); any doVal(any); any doVersion(any); any doWait(any); any doWhen(any); any doWhile(any); any doWipe(any); any doWith(any); any doWr(any); any doXchg(any); any doXor(any); any doYoke(any); any doZap(any); any doZero(any); static inline long unBox(any x) { long n = unDig(x) / 2; return unDig(x) & 1? -n : n; } static inline any boxCnt(long n) {return box(n>=0? n*2 : -n*2+1);} /* List element access */ static inline any nCdr(int n, any x) { while (--n >= 0) x = cdr(x); return x; } static inline any nth(int n, any x) { if (--n < 0) return Nil; return nCdr(n,x); } static inline any getn(any x, any y) { if (isNum(x)) { long n = unDig(x) / 2; if (isNeg(x)) { while (--n) y = cdr(y); return cdr(y); } if (n == 0) return Nil; while (--n) y = cdr(y); return car(y); } do if (isCell(car(y)) && x == caar(y)) return cdar(y); while (isCell(y = cdr(y))); return Nil; } /* List length calculation */ static inline int length(any x) { int n; for (n = 0; isCell(x); x = cdr(x)) ++n; return n; } /* Membership */ static inline any member(any x, any y) { any z = y; while (isCell(y)) { if (equal(x, car(y))) return y; if (z == (y = cdr(y))) return NULL; } return isNil(y) || !equal(x,y)? NULL : y; } static inline any memq(any x, any y) { any z = y; while (isCell(y)) { if (x == car(y)) return y; if (z == (y = cdr(y))) return NULL; } return isNil(y) || x != y? NULL : y; } static inline int indx(any x, any y) { int n = 1; any z = y; while (isCell(y)) { if (equal(x, car(y))) return n; ++n; if (z == (y = cdr(y))) return 0; } return 0; } /* List interpreter */ static inline any prog(any x) { any y; do y = EVAL(car(x)); while (isCell(x = cdr(x))); return y; } static inline any run(any x) { any y; cell at; Push(at,val(At)); do y = EVAL(car(x)); while (isCell(x = cdr(x))); val(At) = Pop(at); return y; } picolisp-3.1.5.2.orig/src/ssl.c0000644000000000000000000001474512265263724014717 0ustar rootroot/* 29oct13abu * (c) Software Lab. Alexander Burger */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include typedef enum {NO,YES} bool; static char *File, *Dir, *Data; static off_t Size; static char Get[] = "GET /%s HTTP/1.0\r\n" "User-Agent: PicoLisp\r\n" "Host: %s:%s\r\n" "Accept-Charset: utf-8\r\n\r\n"; static void errmsg(char *msg) { fprintf(stderr, "ssl: %s\n", msg); } static void giveup(char *msg) { errmsg(msg); exit(1); } static void sslChk(int n) { if (n < 0) { ERR_print_errors_fp(stderr); exit(1); } } static int sslConnect(SSL *ssl, char *node, char *service) { struct addrinfo hints, *lst, *p; int sd; memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; hints.ai_socktype = SOCK_STREAM; if (getaddrinfo(node, service, &hints, &lst) == 0) { for (p = lst; p; p = p->ai_next) { if ((sd = socket(p->ai_family, p->ai_socktype, 0)) >= 0) { if (connect(sd, p->ai_addr, p->ai_addrlen) == 0) { SSL_set_fd(ssl, sd); if (SSL_connect(ssl) >= 0) { freeaddrinfo(lst); return sd; } } close(sd); } } freeaddrinfo(lst); } return -1; } static void sslClose(SSL *ssl, int sd) { SSL_shutdown(ssl); close(sd); } static bool sslFile(SSL *ssl, char *file) { int fd, n; char buf[BUFSIZ]; if (file[0] == '-') return SSL_write(ssl, file+1, strlen(file)-1) >= 0; if ((fd = open(file, O_RDONLY)) < 0) return NO; while ((n = read(fd, buf, sizeof(buf))) > 0) if (SSL_write(ssl, buf, n) < 0) { close(fd); return NO; } close(fd); return n == 0; } static void doSigTerm(int n __attribute__((unused))) { int fd1, fd2, cnt; char buf[BUFSIZ]; if (Data && (fd1 = open(File, O_RDWR)) >= 0) { if (unlink(File) < 0) giveup("Can't unlink back"); if ((fd2 = open(File, O_CREAT|O_WRONLY|O_TRUNC, 0666)) < 0) giveup("Can't create back"); if (write(fd2, Data, Size) != Size) giveup("Can't write back"); while ((cnt = read(fd1, buf, sizeof(buf))) > 0) write(fd2, buf, cnt); } exit(0); } // ssl host port url // ssl host port url file // ssl host port url key file // ssl host port url key file dir sec int main(int ac, char *av[]) { SSL_CTX *ctx; SSL *ssl; int n, sec, getLen, lenLen, fd, sd; DIR *dp; struct dirent *p; struct stat st; struct flock fl; char get[1024], buf[4096], nm[4096], len[64]; if (!(ac >= 4 && ac <= 6 || ac == 8)) giveup("host port url [[key] file] | host port url key file dir sec"); if (strlen(Get)+strlen(av[1])+strlen(av[2])+strlen(av[3]) >= sizeof(get)) giveup("Names too long"); getLen = sprintf(get, Get, av[3], av[1], av[2]); SSL_library_init(); SSL_load_error_strings(); if (!(ctx = SSL_CTX_new(SSLv23_client_method()))) { ERR_print_errors_fp(stderr); giveup("SSL init"); } ssl = SSL_new(ctx); if (ac <= 6) { if (sslConnect(ssl, av[1], av[2]) < 0) { errmsg("Can't connect"); return 1; } sslChk(SSL_write(ssl, get, getLen)); if (ac > 4) { if (*av[4] && !sslFile(ssl,av[4])) giveup(av[4]); if (ac > 5 && *av[5] && !sslFile(ssl,av[5])) giveup(av[5]); } while ((n = SSL_read(ssl, buf, sizeof(buf))) > 0) write(STDOUT_FILENO, buf, n); return 0; } signal(SIGCHLD,SIG_IGN); /* Prevent zombies */ if ((n = fork()) < 0) giveup("detach"); if (n) return 0; setsid(); File = av[5]; Dir = av[6]; sec = atoi(av[7]); signal(SIGINT, doSigTerm); signal(SIGTERM, doSigTerm); signal(SIGPIPE, SIG_IGN); signal(SIGALRM, SIG_IGN); for (;;) { if (*File && (fd = open(File, O_RDWR)) >= 0) { if (fstat(fd,&st) < 0 || st.st_size == 0) close(fd); else { fl.l_type = F_WRLCK; fl.l_whence = SEEK_SET; fl.l_start = 0; fl.l_len = 0; if (fcntl(fd, F_SETLKW, &fl) < 0) giveup("Can't lock"); if (fstat(fd,&st) < 0 || (Size = st.st_size) == 0) giveup("Can't access"); lenLen = sprintf(len, "%ld\n", Size); if ((Data = malloc(Size)) == NULL) giveup("Can't alloc"); if (read(fd, Data, Size) != Size) giveup("Can't read"); if (ftruncate(fd,0) < 0) errmsg("Can't truncate"); close(fd); for (;;) { if ((sd = sslConnect(ssl, av[1], av[2])) >= 0) { alarm(420); if (SSL_write(ssl, get, getLen) == getLen && (!*av[4] || sslFile(ssl,av[4])) && // key SSL_write(ssl, len, lenLen) == lenLen && // length SSL_write(ssl, Data, Size) == Size && // data SSL_write(ssl, "T", 1) == 1 && // ack SSL_read(ssl, buf, 1) == 1 && buf[0] == 'T' ) { alarm(0); sslClose(ssl,sd); break; } alarm(0); sslClose(ssl,sd); } sleep(sec); } free(Data), Data = NULL; } } if (*Dir && (dp = opendir(Dir))) { while (p = readdir(dp)) { if (p->d_name[0] != '.') { snprintf(nm, sizeof(nm), "%s%s", Dir, p->d_name); if ((n = readlink(nm, buf, sizeof(buf))) > 0 && (sd = sslConnect(ssl, av[1], av[2])) >= 0 ) { if (SSL_write(ssl, get, getLen) == getLen && (!*av[4] || sslFile(ssl,av[4])) && // key SSL_write(ssl, buf, n) == n && // path SSL_write(ssl, "\n", 1) == 1 && // nl sslFile(ssl, nm) ) // file unlink(nm); sslClose(ssl,sd); } } } closedir(dp); } sleep(sec); } } picolisp-3.1.5.2.orig/src/start.c0000644000000000000000000000034712265263724015244 0ustar rootroot/* 03sep06abu * (c) Software Lab. Alexander Burger */ extern void main2(int ac, char *av[]) __attribute__ ((noreturn)); int main(int ac, char *av[]) __attribute__ ((noreturn)); int main(int ac, char *av[]) { main2(ac,av); } picolisp-3.1.5.2.orig/src/subr.c0000644000000000000000000011172412265263724015064 0ustar rootroot/* 22jul13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" // (car 'var) -> any any doCar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return car(x); } // (cdr 'lst) -> any any doCdr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cdr(x); } any doCaar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return caar(x); } any doCadr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cadr(x); } any doCdar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cdar(x); } any doCddr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cddr(x); } any doCaaar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return caaar(x); } any doCaadr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return caadr(x); } any doCadar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cadar(x); } any doCaddr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return caddr(x); } any doCdaar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cdaar(x); } any doCdadr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cdadr(x); } any doCddar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cddar(x); } any doCdddr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cdddr(x); } any doCaaaar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return caaaar(x); } any doCaaadr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return caaadr(x); } any doCaadar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return caadar(x); } any doCaaddr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return caaddr(x); } any doCadaar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cadaar(x); } any doCadadr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cadadr(x); } any doCaddar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return caddar(x); } any doCadddr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cadddr(x); } any doCdaaar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cdaaar(x); } any doCdaadr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cdaadr(x); } any doCdadar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cdadar(x); } any doCdaddr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cdaddr(x); } any doCddaar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cddaar(x); } any doCddadr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cddadr(x); } any doCdddar(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedVar(ex,x); return cdddar(x); } any doCddddr(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedLst(ex,x); return cddddr(x); } // (nth 'lst 'cnt ..) -> lst any doNth(any ex) { any x; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))), x = cdr(x); for (;;) { if (!isCell(data(c1))) return Pop(c1); data(c1) = nth((int)evCnt(ex,x), data(c1)); if (!isCell(x = cdr(x))) return Pop(c1); data(c1) = car(data(c1)); } } // (con 'lst 'any) -> any any doCon(any ex) { any x; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); NeedPair(ex,data(c1)); x = cdr(x), x = cdr(data(c1)) = EVAL(car(x)); drop(c1); return x; } // (cons 'any ['any ..]) -> lst any doCons(any x) { any y; cell c1; x = cdr(x); Push(c1, y = cons(EVAL(car(x)),Nil)); while (isCell(cdr(x = cdr(x)))) y = cdr(y) = cons(EVAL(car(x)),Nil); cdr(y) = EVAL(car(x)); return Pop(c1); } // (conc 'lst ..) -> lst any doConc(any x) { any y, z; cell c1; x = cdr(x), Push(c1, y = EVAL(car(x))); while (isCell(x = cdr(x))) { z = EVAL(car(x)); if (!isCell(y)) y = data(c1) = z; else { while (isCell(cdr(y))) y = cdr(y); cdr(y) = z; } } return Pop(c1); } // (circ 'any ..) -> lst any doCirc(any x) { any y; cell c1; x = cdr(x); Push(c1, y = cons(EVAL(car(x)),Nil)); while (isCell(x = cdr(x))) y = cdr(y) = cons(EVAL(car(x)),Nil); cdr(y) = data(c1); return Pop(c1); } // (rot 'lst ['cnt]) -> lst any doRot(any ex) { any x, y, z; int n; cell c1; x = cdr(ex), Push(c1, y = EVAL(car(x))); if (isCell(y)) { n = isCell(x = cdr(x))? (int)evCnt(ex,x) : 0; x = car(y); while (--n && isCell(y = cdr(y)) && y != data(c1)) z = car(y), car(y) = x, x = z; car(data(c1)) = x; } return Pop(c1); } // (list 'any ['any ..]) -> lst any doList(any x) { any y; cell c1; x = cdr(x); Push(c1, y = cons(EVAL(car(x)),Nil)); while (isCell(x = cdr(x))) y = cdr(y) = cons(EVAL(car(x)),Nil); return Pop(c1); } // (need 'cnt ['lst ['any]]) -> lst // (need 'cnt ['num|sym]) -> lst any doNeed(any ex) { int n; any x; cell c1, c2; n = (int)evCnt(ex, x = cdr(ex)); x = cdr(x), Push(c1, EVAL(car(x))); if (isCell(data(c1)) || isNil(data(c1))) Push(c2, EVAL(cadr(x))); else { Push(c2, data(c1)); data(c1) = Nil; } x = data(c1); if (n > 0) for (n -= length(x); n > 0; --n) data(c1) = cons(data(c2), data(c1)); else if (n) { if (!isCell(x)) data(c1) = x = cons(data(c2),Nil); else while (isCell(cdr(x))) ++n, x = cdr(x); while (++n < 0) x = cdr(x) = cons(data(c2),Nil); } return Pop(c1); } // (range 'num1 'num2 ['num3]) -> lst any doRange(any ex) { any x; cell c1, c2, c3, c4; x = cdr(ex), Push(c1, EVAL(car(x))); // Start value NeedNum(ex,data(c1)); x = cdr(x), Push(c2, EVAL(car(x))); // End value NeedNum(ex,data(c2)); x = cdr(x), Push(c3, One); // Increment if (!isNil(x = EVAL(car(x)))) { NeedNum(ex, data(c3) = x); if (IsZero(x) || isNeg(x)) argError(ex,x); } Push(c4, x = cons(data(c1), Nil)); if (bigCompare(data(c2), data(c1)) >= 0) { for (;;) { data(c1) = bigCopy(data(c1)); if (!isNeg(data(c1))) bigAdd(data(c1), data(c3)); else { bigSub(data(c1), data(c3)); if (!IsZero(data(c1))) neg(data(c1)); } if (bigCompare(data(c2), data(c1)) < 0) break; x = cdr(x) = cons(data(c1), Nil); } } else { for (;;) { data(c1) = bigCopy(data(c1)); if (!isNeg(data(c1))) bigSub(data(c1), data(c3)); else { bigAdd(data(c1), data(c3)); if (!IsZero(data(c1))) neg(data(c1)); } if (bigCompare(data(c2), data(c1)) > 0) break; x = cdr(x) = cons(data(c1),Nil); } } drop(c1); return data(c4); } // (full 'any) -> bool any doFull(any x) { x = cdr(x); for (x = EVAL(car(x)); isCell(x); x = cdr(x)) if (isNil(car(x))) return Nil; return T; } // (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any any doMake(any x) { any *make, *yoke; cell c1; Push(c1, Nil); make = Env.make; yoke = Env.yoke; Env.make = Env.yoke = &data(c1); while (isCell(x = cdr(x))) if (isCell(car(x))) evList(car(x)); Env.yoke = yoke; Env.make = make; return Pop(c1); } static void makeError(any ex) {err(ex, NULL, "Not making");} // (made ['lst1 ['lst2]]) -> lst any doMade(any x) { if (!Env.make) makeError(x); if (isCell(x = cdr(x))) { *Env.yoke = EVAL(car(x)); if (x = cdr(x), !isCell(x = EVAL(car(x)))) { any y; x = *Env.yoke; while (isCell(y = cdr(x))) x = y; } Env.make = &cdr(x); } return *Env.yoke; } // (chain 'lst ..) -> lst any doChain(any x) { any y; if (!Env.make) makeError(x); x = cdr(x); do if (isCell(*Env.make = y = EVAL(car(x)))) do Env.make = &cdr(*Env.make); while (isCell(*Env.make)); while (isCell(x = cdr(x))); return y; } // (link 'any ..) -> any any doLink(any x) { any y; if (!Env.make) makeError(x); x = cdr(x); do { y = EVAL(car(x)); Env.make = &cdr(*Env.make = cons(y, Nil)); } while (isCell(x = cdr(x))); return y; } // (yoke 'any ..) -> any any doYoke(any x) { any y; if (!Env.make) makeError(x); x = cdr(x); do { y = EVAL(car(x)); *Env.yoke = cons(y, *Env.yoke); } while (isCell(x = cdr(x))); while (isCell(*Env.make)) Env.make = &cdr(*Env.make); return y; } // (copy 'any) -> any any doCopy(any x) { any y, z; cell c1; x = cdr(x); if (!isCell(x = EVAL(car(x)))) return x; Push(c1, y = cons(car(x), cdr(z = x))); while (isCell(x = cdr(y))) { if (x == z) { cdr(y) = data(c1); break; } y = cdr(y) = cons(car(x), cdr(x)); } return Pop(c1); } // (mix 'lst cnt|'any ..) -> lst any doMix(any x) { any y; cell c1, c2; x = cdr(x); if (!isCell(data(c1) = EVAL(car(x))) && !isNil(data(c1))) return data(c1); if (!isCell(x = cdr(x))) return Nil; Save(c1); Push(c2, y = cons( isNum(car(x))? car(nth((int)unBox(car(x)),data(c1))) : EVAL(car(x)), Nil ) ); while (isCell(x = cdr(x))) y = cdr(y) = cons( isNum(car(x))? car(nth((int)unBox(car(x)),data(c1))) : EVAL(car(x)), Nil ); drop(c1); return data(c2); } // (append 'lst ..) -> lst any doAppend(any x) { any y, z; cell c1; while (isCell(cdr(x = cdr(x)))) { if (isCell(y = EVAL(car(x)))) { Push(c1, z = cons(car(y), cdr(y))); while (isCell(y = cdr(z))) z = cdr(z) = cons(car(y), cdr(y)); while (isCell(cdr(x = cdr(x)))) { for (y = EVAL(car(x)); isCell(y); y = cdr(z)) z = cdr(z) = cons(car(y), cdr(y)); cdr(z) = y; } cdr(z) = EVAL(car(x)); return Pop(c1); } } return EVAL(car(x)); } // (delete 'any 'lst) -> lst any doDelete(any x) { any y, z; cell c1, c2, c3; x = cdr(x), Push(c1, y = EVAL(car(x))); x = cdr(x); if (!isCell(x = EVAL(car(x)))) { drop(c1); return x; } if (equal(y, car(x))) { drop(c1); return cdr(x); } Push(c2, x); Push(c3, z = cons(car(x), Nil)); while (isCell(x = cdr(x))) { if (equal(y, car(x))) { cdr(z) = cdr(x); drop(c1); return data(c3); } z = cdr(z) = cons(car(x), Nil); } cdr(z) = x; drop(c1); return data(c3); } // (delq 'any 'lst) -> lst any doDelq(any x) { any y, z; cell c1, c2, c3; x = cdr(x), Push(c1, y = EVAL(car(x))); x = cdr(x); if (!isCell(x = EVAL(car(x)))) { drop(c1); return x; } if (y == car(x)) { drop(c1); return cdr(x); } Push(c2, x); Push(c3, z = cons(car(x), Nil)); while (isCell(x = cdr(x))) { if (y == car(x)) { cdr(z) = cdr(x); drop(c1); return data(c3); } z = cdr(z) = cons(car(x), Nil); } cdr(z) = x; drop(c1); return data(c3); } // (replace 'lst 'any1 'any2 ..) -> lst any doReplace(any x) { any y; int i, n = length(cdr(x = cdr(x))) + 1 & ~1; cell c1, c2, c[n]; if (!isCell(data(c1) = EVAL(car(x)))) return data(c1); Save(c1); for (i = 0; i < n; ++i) x = cdr(x), Push(c[i], EVAL(car(x))); for (x = car(data(c1)), i = 0; i < n; i += 2) if (equal(x, data(c[i]))) { x = data(c[i+1]); break; } Push(c2, y = cons(x,Nil)); while (isCell(data(c1) = cdr(data(c1)))) { for (x = car(data(c1)), i = 0; i < n; i += 2) if (equal(x, data(c[i]))) { x = data(c[i+1]); break; } y = cdr(y) = cons(x, Nil); } cdr(y) = data(c1); drop(c1); return data(c2); } // (strip 'any) -> any any doStrip(any x) { x = cdr(x), x = EVAL(car(x)); while (isCell(x) && car(x) == Quote && x != cdr(x)) x = cdr(x); return x; } // (split 'lst 'any ..) -> lst any doSplit(any x) { any y; int i, n = length(cdr(x = cdr(x))); cell c1, c[n], res, sub; if (!isCell(data(c1) = EVAL(car(x)))) return data(c1); Save(c1); for (i = 0; i < n; ++i) x = cdr(x), Push(c[i], EVAL(car(x))); Push(res, x = Nil); Push(sub, y = Nil); do { for (i = 0; i < n; ++i) { if (equal(car(data(c1)), data(c[i]))) { if (isNil(x)) x = data(res) = cons(data(sub), Nil); else x = cdr(x) = cons(data(sub), Nil); y = data(sub) = Nil; goto spl1; } } if (isNil(y)) y = data(sub) = cons(car(data(c1)), Nil); else y = cdr(y) = cons(car(data(c1)), Nil); spl1: ; } while (isCell(data(c1) = cdr(data(c1)))); y = cons(data(sub), Nil); drop(c1); if (isNil(x)) return y; cdr(x) = y; return data(res); } // (reverse 'lst) -> lst any doReverse(any x) { any y; cell c1; x = cdr(x), Push(c1, x = EVAL(car(x))); for (y = Nil; isCell(x); x = cdr(x)) y = cons(car(x), y); drop(c1); return y; } // (flip 'lst ['cnt])) -> lst any doFlip(any ex) { any x, y, z; int n; cell c1; x = cdr(ex); if (!isCell(y = EVAL(car(x))) || !isCell(z = cdr(y))) return y; if (!isCell(x = cdr(x))) { cdr(y) = Nil; for (;;) { x = cdr(z), cdr(z) = y; if (!isCell(x)) return z; y = z, z = x; } } Push(c1, y); n = (int)evCnt(ex,x) - 1; drop(c1); if (n <= 0) return y; cdr(y) = cdr(z), cdr(z) = y; while (--n && isCell(x = cdr(y))) cdr(y) = cdr(x), cdr(x) = z, z = x; return z; } static any trim(any x) { any y; if (!isCell(x)) return x; if (isNil(y = trim(cdr(x))) && isBlank(car(x))) return Nil; return cons(car(x),y); } // (trim 'lst) -> lst any doTrim(any x) { cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = trim(data(c1)); drop(c1); return x; } // (clip 'lst) -> lst any doClip(any x) { cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(data(c1)) && isBlank(car(data(c1)))) data(c1) = cdr(data(c1)); x = trim(data(c1)); drop(c1); return x; } // (head 'cnt|lst 'lst) -> lst any doHead(any ex) { long n; any x, y; cell c1, c2; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; x = cdr(x); if (isCell(data(c1))) { Save(c1); if (isCell(x = EVAL(car(x)))) { for (y = data(c1); equal(car(y), car(x)); x = cdr(x)) if (!isCell(y = cdr(y))) return Pop(c1); } drop(c1); return Nil; } if ((n = xCnt(ex,data(c1))) == 0) return Nil; if (!isCell(x = EVAL(car(x)))) return x; if (n < 0 && (n += length(x)) <= 0) return Nil; Push(c1,x); Push(c2, x = cons(car(data(c1)), Nil)); while (--n && isCell(data(c1) = cdr(data(c1)))) x = cdr(x) = cons(car(data(c1)), Nil); drop(c1); return data(c2); } // (tail 'cnt|lst 'lst) -> lst any doTail(any ex) { long n; any x, y; cell c1; x = cdr(ex); if (isNil(data(c1) = EVAL(car(x)))) return Nil; x = cdr(x); if (isCell(data(c1))) { Save(c1); if (isCell(x = EVAL(car(x)))) { do if (equal(x,data(c1))) return Pop(c1); while (isCell(x = cdr(x))); } drop(c1); return Nil; } if ((n = xCnt(ex,data(c1))) == 0) return Nil; if (!isCell(x = EVAL(car(x)))) return x; if (n < 0) return nth(1 - n, x); for (y = cdr(x); --n; y = cdr(y)) if (!isCell(y)) return x; while (isCell(y)) x = cdr(x), y = cdr(y); return x; } // (stem 'lst 'any ..) -> lst any doStem(any x) { int i, n = length(cdr(x = cdr(x))); cell c1, c[n]; Push(c1, EVAL(car(x))); for (i = 0; i < n; ++i) x = cdr(x), Push(c[i], EVAL(car(x))); for (x = data(c1); isCell(x); x = cdr(x)) { for (i = 0; i < n; ++i) if (equal(car(x), data(c[i]))) { data(c1) = cdr(x); break; } } return Pop(c1); } // (fin 'any) -> num|sym any doFin(any x) { x = cdr(x), x = EVAL(car(x)); while (isCell(x)) x = cdr(x); return x; } // (last 'lst) -> any any doLast(any x) { x = cdr(x), x = EVAL(car(x)); if (!isCell(x)) return x; while (isCell(cdr(x))) x = cdr(x); return car(x); } // (== 'any ..) -> flg any doEq(any x) { cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) if (data(c1) != EVAL(car(x))) { drop(c1); return Nil; } drop(c1); return T; } // (n== 'any ..) -> flg any doNEq(any x) { cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) if (data(c1) != EVAL(car(x))) { drop(c1); return T; } drop(c1); return Nil; } // (= 'any ..) -> flg any doEqual(any x) { cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) if (!equal(data(c1), EVAL(car(x)))) { drop(c1); return Nil; } drop(c1); return T; } // (<> 'any ..) -> flg any doNEqual(any x) { cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) if (!equal(data(c1), EVAL(car(x)))) { drop(c1); return T; } drop(c1); return Nil; } // (=0 'any) -> 0 | NIL any doEq0(any x) { x = cdr(x); return isNum(x = EVAL(car(x))) && IsZero(x)? x : Nil; } // (=T 'any) -> flg any doEqT(any x) { x = cdr(x); return T == EVAL(car(x))? T : Nil; } // (n0 'any) -> flg any doNEq0(any x) { x = cdr(x); return isNum(x = EVAL(car(x))) && IsZero(x)? Nil : T; } // (nT 'any) -> flg any doNEqT(any x) { x = cdr(x); return T == EVAL(car(x))? Nil : T; } // (< 'any ..) -> flg any doLt(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) { y = EVAL(car(x)); if (compare(data(c1), y) >= 0) { drop(c1); return Nil; } data(c1) = y; } drop(c1); return T; } // (<= 'any ..) -> flg any doLe(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) { y = EVAL(car(x)); if (compare(data(c1), y) > 0) { drop(c1); return Nil; } data(c1) = y; } drop(c1); return T; } // (> 'any ..) -> flg any doGt(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) { y = EVAL(car(x)); if (compare(data(c1), y) <= 0) { drop(c1); return Nil; } data(c1) = y; } drop(c1); return T; } // (>= 'any ..) -> flg any doGe(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) { y = EVAL(car(x)); if (compare(data(c1), y) < 0) { drop(c1); return Nil; } data(c1) = y; } drop(c1); return T; } // (max 'any ..) -> any any doMax(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) if (compare(y = EVAL(car(x)), data(c1)) > 0) data(c1) = y; return Pop(c1); } // (min 'any ..) -> any any doMin(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) if (compare(y = EVAL(car(x)), data(c1)) < 0) data(c1) = y; return Pop(c1); } // (atom 'any) -> flg any doAtom(any x) { x = cdr(x); return !isCell(EVAL(car(x)))? T : Nil; } // (pair 'any) -> any any doPair(any x) { x = cdr(x); return isCell(x = EVAL(car(x)))? x : Nil; } // (circ? 'any) -> any any doCircQ(any x) { x = cdr(x); return isCell(x = EVAL(car(x))) && (x = circ(x))? x : Nil; } // (lst? 'any) -> flg any doLstQ(any x) { x = cdr(x); return isCell(x = EVAL(car(x))) || isNil(x)? T : Nil; } // (num? 'any) -> num | NIL any doNumQ(any x) { x = cdr(x); return isNum(x = EVAL(car(x)))? x : Nil; } // (sym? 'any) -> flg any doSymQ(any x) { x = cdr(x); return isSym(EVAL(car(x)))? T : Nil; } // (flg? 'any) -> flg any doFlgQ(any x) { x = cdr(x); return isNil(x = EVAL(car(x))) || x==T? T : Nil; } // (member 'any 'lst) -> any any doMember(any x) { cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), x = EVAL(car(x)); return member(Pop(c1), x) ?: Nil; } // (memq 'any 'lst) -> any any doMemq(any x) { cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), x = EVAL(car(x)); return memq(Pop(c1), x) ?: Nil; } // (mmeq 'lst 'lst) -> any any doMmeq(any x) { any y, z; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), y = EVAL(car(x)); for (x = Pop(c1); isCell(x); x = cdr(x)) if (z = memq(car(x), y)) return z; return Nil; } // (sect 'lst 'lst) -> lst any doSect(any x) { cell c1, c2, c3; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); Push(c3, x = Nil); while (isCell(data(c1))) { if (member(car(data(c1)), data(c2))) if (isNil(x)) x = data(c3) = cons(car(data(c1)), Nil); else x = cdr(x) = cons(car(data(c1)), Nil); data(c1) = cdr(data(c1)); } drop(c1); return data(c3); } // (diff 'lst 'lst) -> lst any doDiff(any x) { cell c1, c2, c3; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); Push(c3, x = Nil); while (isCell(data(c1))) { if (!member(car(data(c1)), data(c2))) if (isNil(x)) x = data(c3) = cons(car(data(c1)), Nil); else x = cdr(x) = cons(car(data(c1)), Nil); data(c1) = cdr(data(c1)); } drop(c1); return data(c3); } // (index 'any 'lst) -> cnt | NIL any doIndex(any x) { int n; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), x = EVAL(car(x)); return (n = indx(Pop(c1), x))? boxCnt(n) : Nil; } // (offset 'lst1 'lst2) -> cnt | NIL any doOffset(any x) { int n; any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), y = EVAL(car(x)); for (n = 1, x = Pop(c1); isCell(y); ++n, y = cdr(y)) if (equal(x,y)) return boxCnt(n); return Nil; } // (prior 'lst1 'lst2) -> lst | NIL any doPrior(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), y = EVAL(car(x)); if ((x = Pop(c1)) != y) while (isCell(y)) { if (x == cdr(y)) return y; y = cdr(y); } return Nil; } // (length 'any) -> cnt | T any doLength(any x) { int n, c; any y; if (isNum(x = EVAL(cadr(x)))) return numToSym(x, 0, -1, 0); if (isSym(x)) { for (n = 0, c = symChar(name(x)); c; ++n, c = symChar(NULL)); return boxCnt(n); } for (n = 0, y = x;;) { ++n; *(word*)&car(y) |= 1; if (!isCell(y = cdr(y))) { do *(word*)&car(x) &= ~1; while (isCell(x = cdr(x))); return boxCnt(n); } if (num(car(y)) & 1) { while (x != y) *(word*)&car(x) &= ~1, x = cdr(x); do *(word*)&car(x) &= ~1; while (y != (x = cdr(x))); return T; } } } static int size(any x) { int n; any y; for (n = 0, y = x;;) { ++n; if (isCell(car(y))) n += size(car(y)); *(word*)&car(y) |= 1; if (!isCell(y = cdr(y))) { do *(word*)&car(x) &= ~1; while (isCell(x = cdr(x))); return n; } if (num(car(y)) & 1) { while (x != y) *(word*)&car(x) &= ~1, x = cdr(x); do *(word*)&car(x) &= ~1; while (y != (x = cdr(x))); return n; } } } // (size 'any) -> cnt any doSize(any ex) { any x = cdr(ex); if (isNum(x = EVAL(car(x)))) return boxCnt(numBytes(x)); if (!isSym(x)) return boxCnt(size(x)); if (isExt(x)) return boxCnt(dbSize(ex,x)); return isNum(x = name(x))? boxCnt(numBytes(x)) : Zero; } // (bytes 'any) -> cnt any doBytes(any x) { return boxCnt(binSize(EVAL(cadr(x)))); } // (assoc 'any 'lst) -> lst any doAssoc(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), y = EVAL(car(x)); for (x = Pop(c1); isCell(y); y = cdr(y)) if (isCell(car(y)) && equal(x,caar(y))) return car(y); return Nil; } // (asoq 'any 'lst) -> lst any doAsoq(any x) { any y; cell c1; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), y = EVAL(car(x)); for (x = Pop(c1); isCell(y); y = cdr(y)) if (isCell(car(y)) && x == caar(y)) return car(y); return Nil; } static any Rank; any rank1(any lst, int n) { int i; if (isCell(car(lst)) && compare(caar(lst), Rank) > 0) return NULL; if (n == 1) return car(lst); i = n / 2; return rank1(nCdr(i,lst), n-i) ?: rank1(lst, i); } any rank2(any lst, int n) { int i; if (isCell(car(lst)) && compare(Rank, caar(lst)) > 0) return NULL; if (n == 1) return car(lst); i = n / 2; return rank2(nCdr(i,lst), n-i) ?: rank2(lst, i); } // (rank 'any 'lst ['flg]) -> lst any doRank(any x) { any y; cell c1, c2; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, y = EVAL(car(x))); x = cdr(x), x = EVAL(car(x)); Rank = Pop(c1); if (isCell(y)) return (isNil(x)? rank1(y, length(y)) : rank2(y, length(y))) ?: Nil; return Nil; } /* Pattern matching */ bool match(any p, any d) { any x; for (;;) { if (!isCell(p)) { if (isSym(p) && firstByte(p) == '@') { val(p) = d; return YES; } return equal(p,d); } if (isSym(x = car(p)) && firstByte(x) == '@') { if (!isCell(d)) { if (equal(d, cdr(p))) { val(x) = Nil; return YES; } return NO; } if (match(cdr(p), cdr(d))) { val(x) = cons(car(d), Nil); return YES; } if (match(cdr(p), d)) { val(x) = Nil; return YES; } if (match(p, cdr(d))) { val(x) = cons(car(d), val(x)); return YES; } } if (!isCell(d) || !match(x, car(d))) return NO; p = cdr(p); d = cdr(d); } } // (match 'lst1 'lst2) -> flg any doMatch(any x) { cell c1, c2; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); x = match(data(c1), data(c2))? T : Nil; drop(c1); return x; } // Fill template structure static any fill(any x, any s) { any y; cell c1; if (isNum(x)) return NULL; if (isSym(x)) return x != val(x) && (isNil(s)? x!=At && firstByte(x)=='@' : memq(x,s)!=NULL)? val(x) : NULL; if (car(x) == Up) { x = cdr(x); if (!isCell(y = EVAL(car(x)))) return fill(cdr(x), s) ?: cdr(x); Push(c1, y); while (isCell(cdr(y))) y = cdr(y); cdr(y) = fill(cdr(x), s) ?: cdr(x); return Pop(c1); } if (y = fill(car(x), s)) { Push(c1,y); y = fill(cdr(x), s); return cons(Pop(c1), y ?: cdr(x)); } if (y = fill(cdr(x), s)) return cons(car(x), y); return NULL; } // (fill 'any ['sym|lst]) -> any any doFill(any x) { cell c1, c2; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); if (x = fill(data(c1), data(c2))) { drop(c1); return x; } return Pop(c1); } /* Declarative Programming */ cell *Penv, *Pnl; static bool unify(any n1, any x1, any n2, any x2) { any x, env; lookup1: if (isSym(x1) && firstByte(x1) == '@') for (x = data(*Penv); isCell(car(x)); x = cdr(x)) if (unDig(n1) == unDig(caaar(x)) && x1 == cdaar(x)) { n1 = cadar(x); x1 = cddar(x); goto lookup1; } lookup2: if (isSym(x2) && firstByte(x2) == '@') for (x = data(*Penv); isCell(car(x)); x = cdr(x)) if (unDig(n2) == unDig(caaar(x)) && x2 == cdaar(x)) { n2 = cadar(x); x2 = cddar(x); goto lookup2; } if (unDig(n1) == unDig(n2) && equal(x1, x2)) return YES; if (isSym(x1) && firstByte(x1) == '@') { if (x1 != At) { data(*Penv) = cons(cons(cons(n1,x1), Nil), data(*Penv)); cdar(data(*Penv)) = cons(n2,x2); } return YES; } if (isSym(x2) && firstByte(x2) == '@') { if (x2 != At) { data(*Penv) = cons(cons(cons(n2,x2), Nil), data(*Penv)); cdar(data(*Penv)) = cons(n1,x1); } return YES; } if (!isCell(x1) || !isCell(x2)) return equal(x1, x2); env = data(*Penv); if (unify(n1, car(x1), n2, car(x2)) && unify(n1, cdr(x1), n2, cdr(x2))) return YES; data(*Penv) = env; return NO; } static any lup(any n, any x) { any y; cell c1; lup: if (isSym(x) && firstByte(x) == '@') for (y = data(*Penv); isCell(car(y)); y = cdr(y)) if (unDig(n) == unDig(caaar(y)) && x == cdaar(y)) { n = cadar(y); x = cddar(y); goto lup; } if (!isCell(x)) return x; Push(c1, lup(n, car(x))); x = lup(n, cdr(x)); return cons(Pop(c1), x); } static any lookup(any n, any x) { return isSym(x = lup(n,x)) && firstByte(x)=='@'? Nil : x; } static any uniFill(any x) { cell c1; if (isNum(x)) return x; if (isSym(x)) return lup(car(data(*Pnl)), x); Push(c1, uniFill(car(x))); x = uniFill(cdr(x)); return cons(Pop(c1), x); } // (prove 'lst ['lst]) -> lst any doProve(any x) { int i; cell *envSave, *nlSave, at, q, dbg, env, n, nl, alt, tp1, tp2, e; x = cdr(x); if (!isCell(data(q) = EVAL(car(x)))) return Nil; Save(q); Push(at,val(At)); envSave = Penv, Penv = &env, nlSave = Pnl, Pnl = &nl; if (x = cdr(x), isNil(x = EVAL(car(x)))) data(dbg) = NULL; else Push(dbg, x); Push(env, caar(data(q))), car(data(q)) = cdar(data(q)); Push(n, car(data(env))), data(env) = cdr(data(env)); Push(nl, car(data(env))), data(env) = cdr(data(env)); Push(alt, car(data(env))), data(env) = cdr(data(env)); Push(tp1, car(data(env))), data(env) = cdr(data(env)); Push(tp2, car(data(env))), data(env) = cdr(data(env)); Push(e,Nil); while (isCell(data(tp1)) || isCell(data(tp2))) { if (isCell(data(alt))) { data(e) = data(env); if (!unify(car(data(nl)), cdar(data(tp1)), data(n), caar(data(alt)))) { if (!isCell(data(alt) = cdr(data(alt)))) { data(env) = caar(data(q)), car(data(q)) = cdar(data(q)); data(n) = car(data(env)), data(env) = cdr(data(env)); data(nl) = car(data(env)), data(env) = cdr(data(env)); data(alt) = car(data(env)), data(env) = cdr(data(env)); data(tp1) = car(data(env)), data(env) = cdr(data(env)); data(tp2) = car(data(env)), data(env) = cdr(data(env)); } } else { if (data(dbg) && memq(caar(data(tp1)), data(dbg))) { outWord(indx(car(data(alt)), get(caar(data(tp1)), T))); space(); print(uniFill(car(data(tp1)))), newline(); } if (isCell(cdr(data(alt)))) car(data(q)) = cons( cons(data(n), cons(data(nl), cons(cdr(data(alt)), cons(data(tp1), cons(data(tp2),data(e))) ) ) ), car(data(q)) ); data(nl) = cons(data(n), data(nl)); data(n) = box(2 + unDig(data(n))); data(tp2) = cons(cdr(data(tp1)), data(tp2)); data(tp1) = cdar(data(alt)); data(alt) = Nil; } } else if (!isCell(x = data(tp1))) { data(tp1) = car(data(tp2)), data(tp2) = cdr(data(tp2)); data(nl) = cdr(data(nl)); } else if (car(x) == T) { while (isCell(car(data(q))) && unDig(caaar(data(q))) >= unDig(car(data(nl))) ) car(data(q)) = cdar(data(q)); data(tp1) = cdr(x); } else if (isNum(caar(x))) { data(e) = prog(cdar(x)); for (i = unDig(caar(x)), x = data(nl); (i -= 2) > 0;) x = cdr(x); data(nl) = cons(car(x), data(nl)); data(tp2) = cons(cdr(data(tp1)), data(tp2)); data(tp1) = data(e); } else if (caar(x) == Up) { if (!isNil(data(e) = prog(cddar(x))) && unify(car(data(nl)), cadar(x), car(data(nl)), data(e)) ) data(tp1) = cdr(x); else { data(env) = caar(data(q)), car(data(q)) = cdar(data(q)); data(n) = car(data(env)), data(env) = cdr(data(env)); data(nl) = car(data(env)), data(env) = cdr(data(env)); data(alt) = car(data(env)), data(env) = cdr(data(env)); data(tp1) = car(data(env)), data(env) = cdr(data(env)); data(tp2) = car(data(env)), data(env) = cdr(data(env)); } } else if (!isCell(data(alt) = get(caar(x), T))) { data(env) = caar(data(q)), car(data(q)) = cdar(data(q)); data(n) = car(data(env)), data(env) = cdr(data(env)); data(nl) = car(data(env)), data(env) = cdr(data(env)); data(alt) = car(data(env)), data(env) = cdr(data(env)); data(tp1) = car(data(env)), data(env) = cdr(data(env)); data(tp2) = car(data(env)), data(env) = cdr(data(env)); } } for (data(e) = Nil, x = data(env); isCell(cdr(x)); x = cdr(x)) if (!unDig(caaar(x))) data(e) = cons(cons(cdaar(x), lookup(Zero, cdaar(x))), data(e)); val(At) = data(at); drop(q); Penv = envSave, Pnl = nlSave; return isCell(data(e))? data(e) : isCell(data(env))? T : Nil; } // (-> any [num]) -> any any doArrow(any x) { int i; any y; if (!isNum(caddr(x))) return lookup(car(data(*Pnl)), cadr(x)); for (i = unDig(caddr(x)), y = data(*Pnl); (i -= 2) > 0;) y = cdr(y); return lookup(car(y), cadr(x)); } // (unify 'any) -> lst any doUnify(any x) { cell c1; Push(c1, EVAL(cadr(x))); if (unify(cadr(data(*Pnl)), data(c1), car(data(*Pnl)), data(c1))) { drop(c1); return data(*Penv); } drop(c1); return Nil; } /* List Merge Sort: Bill McDaniel, DDJ Jun99 */ static bool cmp(any ex, any foo, cell c[2]) { if (isNil(foo)) return compare(car(data(c[0])), car(data(c[1]))) < 0; return !isNil(apply(ex, foo, YES, 2, c)); } // (sort 'lst ['fun]) -> lst any doSort(any ex) { int i; any x; cell p, foo, in[2], out[2], last[2]; any *tail[2]; x = cdr(ex); if (!isCell(data(out[0]) = EVAL(car(x)))) return data(out[0]); Save(out[0]); x = cdr(x), Push(foo, EVAL(car(x))); Push(out[1], Nil); Save(in[0]); Save(in[1]); Push(p, Nil); Push(last[1], Nil); do { data(in[0]) = data(out[0]); data(in[1]) = data(out[1]); i = isCell(data(in[1])) && !cmp(ex, data(foo), in); if (isCell(data(p) = data(in[i]))) data(in[i]) = cdr(data(in[i])); data(out[0]) = data(p); tail[0] = &cdr(data(p)); data(last[1]) = data(out[0]); cdr(data(p)) = Nil; i = 0; data(out[1]) = Nil; tail[1] = &data(out[1]); while (isCell(data(in[0])) || isCell(data(in[1]))) { if (!isCell(data(in[1]))) { if (isCell(data(p) = data(in[0]))) data(in[0]) = cdr(data(in[0])); data(last[0]) = data(p); if (cmp(ex, data(foo), last)) i = 1 - i; } else if (!isCell(data(in[0]))) { data(last[0]) = data(p) = data(in[1]), data(in[1]) = cdr(data(in[1])); if (cmp(ex, data(foo), last)) i = 1 - i; } else if (data(last[0]) = data(in[0]), cmp(ex, data(foo), last)) { data(last[0]) = data(in[1]); if (!cmp(ex, data(foo), last)) data(p) = data(in[1]), data(in[1]) = cdr(data(in[1])); else { if (cmp(ex, data(foo), in)) data(p) = data(in[0]), data(in[0]) = cdr(data(in[0])); else data(p) = data(in[1]), data(in[1]) = cdr(data(in[1])); i = 1 - i; } } else { data(last[0]) = data(in[1]); if (cmp(ex, data(foo), last)) data(p) = data(in[0]), data(in[0]) = cdr(data(in[0])); else { if (cmp(ex, data(foo), in)) data(p) = data(in[0]), data(in[0]) = cdr(data(in[0])); else data(p) = data(in[1]), data(in[1]) = cdr(data(in[1])); } } *tail[i] = data(p); tail[i] = &cdr(data(p)); cdr(data(p)) = Nil; data(last[1]) = data(p); } } while (isCell(data(out[1]))); return Pop(out[0]); } picolisp-3.1.5.2.orig/src/sym.c0000644000000000000000000030015412265263724014716 0ustar rootroot/* 15nov13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" /* Internal/transient hash */ unsigned long ihash(any x) { unsigned long g, h; word n; for (h = 0; isNum(x); x = cdr(numCell(x))) for (n = unDig(x); n; n >>= 8) g = (h = (h<<4) + (n&0xFF)) & 0xF0000000, h = (h ^ g>>24) & ~g; return h % IHASH; } /* External hash */ unsigned long ehash(any x) { unsigned long h; word n; for (h = 0; isNum(x); x = cdr(numCell(x))) for (n = unDig(x); n; n >>= 11) h += n; return h % EHASH; } bool hashed(any s, any x) { while (isCell(x)) { if (s == car(x)) return YES; x = cdr(x); } return NO; } any findHash(any s, any *p) { any x, y, *q, h; if (isCell(h = *p)) { x = s, y = name(car(h)); while (unDig(x) == unDig(y)) { x = cdr(numCell(x)); y = cdr(numCell(y)); if (!isNum(x) && !isNum(y)) return car(h); } while (isCell(h = *(q = &cdr(h)))) { x = s, y = name(car(h)); while (unDig(x) == unDig(y)) { x = cdr(numCell(x)); y = cdr(numCell(y)); if (!isNum(x) && !isNum(y)) { *q = cdr(h), cdr(h) = *p, *p = h; return car(h); } } } } return NULL; } void unintern(any s, any *p) { any x; while (isCell(x = *p)) { if (s == car(x)) { *p = cdr(x); return; } p = &x->cdr; } } /* Get symbol name */ any name(any s) { for (s = tail1(s); isCell(s); s = cdr(s)); return s; } // (name 'sym ['sym2]) -> sym any doName(any ex) { any x, y, *p; unsigned long n; cell c1; x = cdr(ex), data(c1) = EVAL(car(x)); NeedSym(ex,data(c1)); y = name(data(c1)); if (!isCell(x = cdr(x))) return isNum(y)? consStr(y) : Nil; n = ihash(y); if (isNil(data(c1)) || isExt(data(c1)) || hashed(data(c1), Intern[n])) err(ex, data(c1), "Can't rename"); Save(c1); x = EVAL(car(x)); NeedSym(ex,x); unintern(data(c1), Transient + n); for (p = &tail(data(c1)); isCell(*p); p = &cdr(*p)); *p = name(x); return Pop(c1); } /* Find or create single-char symbol */ any mkChar(int c) { if (c >= 0x80) { if (c < 0x800) c = 0xC0 | c>>6 & 0x1F | (0x80 | c & 0x3F) << 8; else if (c == TOP) c = 0xFF; else c = 0xE0 | c>>12 & 0x0F | (0x80 | c>>6 & 0x3F) << 8 | (0x80 | c & 0x3F) << 16; } return consStr(box(c)); } /* Make name */ any mkName(char *s) { int i; any nm; cell c1; i = 0, Push(c1, nm = box(*(byte*)s++)); while (*s) byteSym(*(byte*)s++, &i, &nm); return Pop(c1); } any intern(char *s) { any nm, x, *h; if (!*s) return Nil; nm = mkName(s); if (x = findHash(nm, h = Intern + ihash(nm))) return x; *h = cons(x = consStr(nm), *h); return x; } /* Make string */ any mkStr(char *s) {return s && *s? consStr(mkName(s)) : Nil;} /* Get first byte of symbol name */ int firstByte(any s) { return !isNum(s = name(s))? 0 : unDig(s) & 0xFF; } int secondByte(any s) { return !isNum(s = name(s))? 0 : unDig(s) >> 8 & 0xFF; } bool isBlank(any x) { int c; if (!isSym(x)) return NO; for (c = symChar(name(x)); c; c = symChar(NULL)) if (c > ' ') return NO; return YES; } // (sp? 'any) -> flg any doSpQ(any x) { x = cdr(x); return isBlank(EVAL(car(x)))? T : Nil; } // (pat? 'any) -> sym | NIL any doPatQ(any x) { x = cdr(x); return isSym(x = EVAL(car(x))) && firstByte(x) == '@'? x : Nil; } // (fun? 'any) -> any any doFunQ(any x) { x = cdr(x); return funq(EVAL(car(x))); } // (getd 'any) -> fun | NIL any doGetd(any x) { x = cdr(x); if (!isSym(x = EVAL(car(x)))) return Nil; return !isNil(funq(val(x))) || isNil(val(x)) && sharedLib(x)? val(x) : Nil; } // (all ['T | '0]) -> lst any doAll(any x) { any *p; int mod, i; cell c1; x = cdr(x), x = EVAL(car(x)); if isNil(x) p = Intern, mod = IHASH; else if (x == T) p = Transient, mod = IHASH; else p = Extern, mod = EHASH; Push(c1, Nil); for (i = 0; i < mod; ++i) for (x = p[i]; isCell(x); x = cdr(x)) data(c1) = cons(car(x), data(c1)); return Pop(c1); } // (intern 'sym) -> sym any doIntern(any ex) { any x, y, z, *h; x = cdr(ex), x = EVAL(car(x)); NeedSym(ex,x); if (!isNum(y = name(x))) return Nil; if (unDig(y) == ('L'<<16 | 'I'<<8 | 'N')) return Nil; if (z = findHash(y, h = Intern + ihash(y))) return z; *h = cons(x,*h); return x; } // (extern 'sym) -> sym | NIL any doExtern(any ex) { int c, i; any x, y, *h, nm; cell c1, c2; x = cdr(ex), x = EVAL(car(x)); NeedSym(ex,x); if (!isNum(x = name(x))) return Nil; if (!(y = findHash(x, Extern + ehash(x)))) { Push(c1, x); if ((c = symChar(x)) == '{') c = symChar(NULL); Push(c2, boxChar(c, &i, &nm)); while ((c = symChar(NULL)) && c != '}') charSym(c, &i, &nm); if (!(y = findHash(data(c2), h = Extern + ehash(data(c2))))) { mkExt(y = consSym(Nil,data(c2))); *h = cons(y,*h); } drop(c1); } return isLife(y)? y : Nil; } // (==== ['sym ..]) -> NIL any doHide(any ex) { any x, y, z, *h; int i; for (i = 0; i < IHASH; ++i) Transient[i] = Nil; for (x = cdr(ex); isCell(x); x = cdr(x)) { y = EVAL(car(x)); NeedSym(ex,y); if (isNum(z = name(y)) && !findHash(z, h = Transient + ihash(z))) *h = cons(y,*h); } return Nil; } // (box? 'any) -> sym | NIL any doBoxQ(any x) { x = cdr(x); return isSym(x = EVAL(car(x))) && !isNum(name(x))? x : Nil; } // (str? 'any) -> sym | NIL any doStrQ(any x) { x = cdr(x); return isSym(x = EVAL(car(x))) && !isExt(x) && !hashed(x, Intern[ihash(name(x))])? x : Nil; } // (ext? 'any) -> sym | NIL any doExtQ(any x) { x = cdr(x); return isSym(x = EVAL(car(x))) && isExt(x) && isLife(x) ? x : Nil; } // (touch 'sym) -> sym any doTouch(any ex) { any x = cdr(ex); x = EVAL(car(x)); NeedSym(ex,x); Touch(ex,x); return x; } // (zap 'sym) -> sym any doZap(any ex) { any x; x = cdr(ex), x = EVAL(car(x)); NeedSym(ex,x); if (isExt(x)) db(ex,x,3); else { if (x >= Nil && x <= Bye) protError(ex,x); unintern(x, Intern + ihash(name(x))); } return x; } // (chop 'any) -> lst any doChop(any x) { int c; cell c1, c2; if (isCell(x = EVAL(cadr(x)))) return x; if (!(c = symChar(name(x = xSym(x))))) return Nil; Push(c1, x); Push(c2, x = cons(mkChar(c), Nil)); while (c = symChar(NULL)) x = cdr(x) = cons(mkChar(c), Nil); drop(c1); return data(c2); } void pack(any x, int *i, any *nm, cell *p) { int c; cell c1; if (isCell(x)) do pack(car(x), i, nm, p); while (isCell(x = cdr(x))); if (!isNil(x)) { if (isNum(x)) { Push(c1, x = numToSym(x, 0, 0, 0)); c = symChar(name(x)); if (*nm) charSym(c, i, nm); else Tuck(*p, c1, boxChar(c, i, nm)); while (c = symChar(NULL)) charSym(c, i, nm); drop(c1); } else if (c = symChar(name(x))) { if (*nm) { if (isExt(x)) charSym('{', i, nm); charSym(c, i, nm); } else if (!isExt(x)) Push(*p, boxChar(c, i, nm)); else { Push(*p, boxChar('{', i, nm)); charSym(c, i, nm); } while (c = symChar(NULL)) charSym(c, i, nm); if (isExt(x)) charSym('}', i, nm); } } } // (pack 'any ..) -> sym any doPack(any x) { int i; any nm; cell c1, c2; x = cdr(x), Push(c1, EVAL(car(x))); nm = NULL, pack(data(c1), &i, &nm, &c2); while (isCell(x = cdr(x))) pack(data(c1) = EVAL(car(x)), &i, &nm, &c2); drop(c1); return nm? consStr(data(c2)) : Nil; } // (glue 'any 'lst) -> sym any doGlue(any x) { int i; any nm; cell c1, c2, c3; x = cdr(x), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, x = EVAL(car(x))); if (!isCell(x)) { drop(c1); return x; } nm = NULL, pack(car(x), &i, &nm, &c3); while (isCell(x = cdr(x))) { pack(data(c1), &i, &nm, &c3); pack(car(x), &i, &nm, &c3); } drop(c1); return nm? consStr(data(c3)) : Nil; } // (text 'any1 'any ..) -> sym any doText(any x) { int c, n, i; any nm; any y = evSym(x = cdr(x)); char *p, buf[bufSize(y)]; cell c1; bufString(y, buf); if (!*(p = buf)) return Nil; { cell arg[length(x = cdr(x))]; for (n = 0; isCell(x); ++n, x = cdr(x)) Push(arg[n], EVAL(car(x))); nm = NULL; do { if ((c = *p++) != '@') { if (nm) byteSym(c, &i, &nm); else i = 0, Push(c1, nm = box(c & 0xFF)); } else if (!(c = *p++)) break; else if (c == '@') { if (nm) byteSym('@', &i, &nm); else i = 0, Push(c1, nm = box('@')); } else if (c >= '1') { if ((c -= '1') > 8) c -= 7; if (n > c) pack(data(arg[c]), &i, &nm, &c1); } } while (*p); if (n) drop(arg[0]); else if (nm) drop(c1); return nm? consStr(data(c1)) : Nil; } } static bool pre(word n1, any y, word n2, any x) { for (;;) { if ((n1 & 0xFF) != (n2 & 0xFF)) return NO; if ((n1 >>= 8) == 0) { if (!isNum(y = cdr(numCell(y)))) return YES; n1 = unDig(y); } if ((n2 >>= 8) == 0) { if (!isNum(x = cdr(numCell(x)))) return NO; n2 = unDig(x); } } } bool subStr(any y, any x) { word n; if (!isNum(y = name(y))) return YES; if (!isNum(x = name(x))) return NO; n = unDig(x); for (;;) { if (pre(unDig(y), y, n, x)) return YES; if ((n >>= 8) == 0) { if (!isNum(x = cdr(numCell(x)))) return NO; n = unDig(x); } } } // (pre? 'any1 'any2) -> any2 | NIL any doPreQ(any x) { any y, z; cell c1; x = cdr(x), Push(c1, evSym(x)); x = cdr(x), x = evSym(x); drop(c1); if (!isNum(y = name(data(c1)))) return x; if (!isNum(z = name(x))) return Nil; return pre(unDig(y), y, unDig(z), z)? x : Nil; } // (sub? 'any1 'any2) -> any2 | NIL any doSubQ(any x) { cell c1; x = cdr(x), Push(c1, evSym(x)); x = cdr(x), x = evSym(x); drop(c1); return subStr(data(c1), x)? x : Nil; } // (val 'var) -> any any doVal(any ex) { any x; x = cdr(ex), x = EVAL(car(x)); NeedVar(ex,x); if (isSym(x)) Fetch(ex,x); return val(x); } // (set 'var 'any ..) -> any any doSet(any ex) { any x; cell c1, c2; x = cdr(ex); do { Push(c1, EVAL(car(x))), x = cdr(x); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); Push(c2, EVAL(car(x))), x = cdr(x); val(data(c1)) = data(c2); drop(c1); } while (isCell(x)); return val(data(c1)); } // (setq var 'any ..) -> any any doSetq(any ex) { any x, y; x = cdr(ex); do { y = car(x), x = cdr(x); NeedVar(ex,y); CheckVar(ex,y); val(y) = EVAL(car(x)); } while (isCell(x = cdr(x))); return val(y); } // (swap 'var 'any) -> any any doSwap(any ex) { any x, y; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); y = val(data(c1)); x = cdr(x), val(data(c1)) = EVAL(car(x)); drop(c1); return y; } // (xchg 'var 'var ..) -> any any doXchg(any ex) { any x, y; cell c1, c2; x = cdr(ex); do { Push(c1, EVAL(car(x))), x = cdr(x); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); Push(c2, EVAL(car(x))), x = cdr(x); NeedVar(ex,data(c2)); CheckVar(ex,data(c2)); if (isSym(data(c2))) Touch(ex,data(c2)); y = val(data(c1)), val(data(c1)) = val(data(c2)), val(data(c2)) = y; drop(c1); } while (isCell(x)); return y; } // (on var ..) -> T any doOn(any ex) { any x = cdr(ex); do { NeedVar(ex,car(x)); CheckVar(ex,car(x)); val(car(x)) = T; } while (isCell(x = cdr(x))); return T; } // (off var ..) -> NIL any doOff(any ex) { any x = cdr(ex); do { NeedVar(ex,car(x)); CheckVar(ex,car(x)); val(car(x)) = Nil; } while (isCell(x = cdr(x))); return Nil; } // (onOff var ..) -> flg any doOnOff(any ex) { any x = cdr(ex); any y; do { NeedVar(ex,car(x)); CheckVar(ex,car(x)); y = val(car(x)) = isNil(val(car(x)))? T : Nil; } while (isCell(x = cdr(x))); return y; } // (zero var ..) -> 0 any doZero(any ex) { any x = cdr(ex); do { NeedVar(ex,car(x)); CheckVar(ex,car(x)); val(car(x)) = Zero; } while (isCell(x = cdr(x))); return Zero; } // (one var ..) -> 1 any doOne(any ex) { any x = cdr(ex); do { NeedVar(ex,car(x)); CheckVar(ex,car(x)); val(car(x)) = One; } while (isCell(x = cdr(x))); return One; } // (default var 'any ..) -> any any doDefault(any ex) { any x, y; x = cdr(ex); do { y = car(x), x = cdr(x); NeedVar(ex,y); CheckVar(ex,y); if (isNil(val(y))) val(y) = EVAL(car(x)); } while (isCell(x = cdr(x))); return val(y); } // (push 'var 'any ..) -> any any doPush(any ex) { any x; cell c1, c2; x = cdr(ex), Push(c1, EVAL(car(x))); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); x = cdr(x), Push(c2, EVAL(car(x))); val(data(c1)) = cons(data(c2), val(data(c1))); while (isCell(x = cdr(x))) { data(c2) = EVAL(car(x)); val(data(c1)) = cons(data(c2), val(data(c1))); } drop(c1); return data(c2); } // (push1 'var 'any ..) -> any any doPush1(any ex) { any x; cell c1, c2; x = cdr(ex), Push(c1, EVAL(car(x))); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); x = cdr(x), Push(c2, EVAL(car(x))); if (!member(data(c2), val(data(c1)))) val(data(c1)) = cons(data(c2), val(data(c1))); while (isCell(x = cdr(x))) if (!member(data(c2) = EVAL(car(x)), val(data(c1)))) val(data(c1)) = cons(data(c2), val(data(c1))); drop(c1); return data(c2); } // (pop 'var) -> any any doPop(any ex) { any x, y; x = cdr(ex), x = EVAL(car(x)); NeedVar(ex,x); CheckVar(ex,x); if (isSym(x)) Touch(ex,x); if (!isCell(y = val(x))) return y; val(x) = cdr(y); return car(y); } // (cut 'cnt 'var) -> lst any doCut(any ex) { long n; any x, y; cell c1, c2; if ((n = evCnt(ex, x = cdr(ex))) <= 0) return Nil; x = cdr(x), Push(c1, EVAL(car(x))); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); if (isCell(val(data(c1)))) { Push(c2, y = cons(car(val(data(c1))), Nil)); while (isCell(val(data(c1)) = cdr(val(data(c1)))) && --n) y = cdr(y) = cons(car(val(data(c1))), Nil); drop(c1); return data(c2); } return val(Pop(c1)); } // (del 'any 'var) -> lst any doDel(any ex) { any x, y; cell c1, c2, c3; x = cdr(ex), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); NeedVar(ex,data(c2)); CheckVar(ex,data(c2)); if (isSym(data(c2))) Touch(ex,data(c2)); if (isCell(x = val(data(c2)))) { if (equal(data(c1), car(x))) { drop(c1); return val(data(c2)) = cdr(x); } Push(c3, y = cons(car(x), Nil)); while (isCell(x = cdr(x))) { if (equal(data(c1), car(x))) { cdr(y) = cdr(x); drop(c1); return val(data(c2)) = data(c3); } y = cdr(y) = cons(car(x), Nil); } } drop(c1); return val(data(c2)); } // (queue 'var 'any) -> any any doQueue(any ex) { any x, y; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); x = cdr(x), x = EVAL(car(x)); if (!isCell(y = val(data(c1)))) val(data(c1)) = cons(x,Nil); else { while (isCell(cdr(y))) y = cdr(y); cdr(y) = cons(x,Nil); } drop(c1); return x; } // (fifo 'var ['any ..]) -> any any doFifo(any ex) { any x, y, z; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (isSym(data(c1))) Touch(ex,data(c1)); if (isCell(x = cdr(x))) { y = EVAL(car(x)); if (isCell(z = val(data(c1)))) val(data(c1)) = z = cdr(z) = cons(y,cdr(z)); else { z = val(data(c1)) = cons(y,Nil); cdr(z) = z; } while (isCell(x = cdr(x))) val(data(c1)) = z = cdr(z) = cons(y = EVAL(car(x)), cdr(z)); } else if (!isCell(z = val(data(c1)))) y = Nil; else { if (z == cdr(z)) { y = car(z); val(data(c1)) = Nil; } else { y = cadr(z); cdr(z) = cddr(z); } } drop(c1); return y; } any idx(any var, any key, int flg) { any x, y, z, *p; int n; if (!key) { cell c1, c2; if (!isCell(x = val(var))) return Nil; y = Nil; // Result Push(c1, x); // Tree Push(c2, Nil); // TOS for (;;) { while (isCell(cddr(data(c1)))) z = data(c1), data(c1) = cddr(z), cddr(z) = data(c2), data(c2) = z; for (;;) { y = cons(car(data(c1)), y); if (isCell(cadr(data(c1)))) { z = data(c1), data(c1) = cadr(z), cadr(z) = data(c2), data(c2) = symPtr(z); break; } for (;;) { if (isNil(data(c2))) { drop(c1); return y; } if (isCell(data(c2))) { z = data(c2), data(c2) = cddr(z), cddr(z) = data(c1), data(c1) = z; break; } z = cellPtr(data(c2)), data(c2) = cadr(z), cadr(z) = data(c1), data(c1) = z; } } } } if (!isCell(x = val(var))) { if (flg > 0) val(var) = cons(key,Nil); return Nil; } p = (any*)var; for (;;) { if ((n = compare(key, car(x))) == 0) { if (flg < 0) { if (!isCell(cadr(x))) *p = cddr(x); else if (!isCell(y = cddr(x))) *p = cadr(x); else if (!isCell(z = cadr(y))) car(x) = car(y), cddr(x) = cddr(y); else { while (isCell(cadr(z))) z = cadr(y = z); car(x) = car(z), cadr(y) = cddr(z); } } return x; } if (!isCell(cdr(x))) { if (flg > 0) cdr(x) = n < 0? cons(cons(key,Nil), Nil) : cons(Nil, cons(key,Nil)); return Nil; } if (n < 0) { if (!isCell(cadr(x))) { if (flg > 0) cadr(x) = cons(key,Nil); return Nil; } x = *(p = &cadr(x)); } else { if (!isCell(cddr(x))) { if (flg > 0) cddr(x) = cons(key,Nil); return Nil; } x = *(p = &cddr(x)); } } } // (idx 'var 'any 'flg) -> lst // (idx 'var 'any) -> lst // (idx 'var) -> lst any doIdx(any ex) { any x; int flg; cell c1, c2; x = cdr(ex), Push(c1, EVAL(car(x))); NeedVar(ex,data(c1)); CheckVar(ex,data(c1)); if (!isCell(x = cdr(x))) x = idx(data(c1), NULL, 0); else { Push(c2, EVAL(car(x))); if (!isCell(cdr(x))) flg = 0; else flg = isNil(EVAL(cadr(x)))? -1 : +1; x = idx(data(c1), data(c2), flg); } drop(c1); return x; } // (lup 'lst 'any) -> lst // (lup 'lst 'any 'any2) -> lst any doLup(any x) { int n; cell c1, c2, c3, c4, c5; x = cdr(x), data(c1) = EVAL(car(x)); if (!isCell(data(c1))) return data(c1); Save(c1); x = cdr(x), Push(c2, EVAL(car(x))); // from if (isCell(x = cdr(x))) { Push(c3, EVAL(car(x))); // to Push(c4, Nil); // tos Push(c5, Nil); // result for (;;) { while (isCell(cddr(data(c1))) && car(data(c1)) != T && (!isCell(car(data(c1))) || compare(data(c3), caar(data(c1))) >= 0)) x = data(c1), data(c1) = cddr(x), cddr(x) = data(c4), data(c4) = x; for (;;) { if (isCell(car(data(c1))) && compare(data(c2), caar(data(c1))) <= 0) { if (compare(data(c3), caar(data(c1))) >= 0) data(c5) = cons(car(data(c1)), data(c5)); if (isCell(cadr(data(c1)))) { x = data(c1), data(c1) = cadr(x), cadr(x) = data(c4), data(c4) = symPtr(x); break; } } for (;;) { if (isNil(data(c4))) { drop(c1); return data(c5); } if (isCell(data(c4))) { x = data(c4), data(c4) = cddr(x), cddr(x) = data(c1), data(c1) = x; break; } else x = cellPtr(data(c4)), data(c4) = cadr(x), cadr(x) = data(c1), data(c1) = x; } } } } do { if (car(data(c1)) == T) data(c1) = cadr(data(c1)); else if (!isCell(car(data(c1)))) data(c1) = cddr(data(c1)); else if (n = compare(data(c2), caar(data(c1)))) data(c1) = n < 0? cadr(data(c1)) : cddr(data(c1)); else { drop(c1); return car(data(c1)); } } while (isCell(data(c1))); drop(c1); return Nil; } void put(any x, any key, any val) { any y, z; if (isCell(y = tail1(x))) { if (isCell(car(y))) { if (key == cdar(y)) { if (isNil(val)) Tail(x, cdr(y)); else if (val == T) car(y) = key; else caar(y) = val; return; } } else if (key == car(y)) { if (isNil(val)) Tail(x, cdr(y)); else if (val != T) car(y) = cons(val,key); return; } while (isCell(z = cdr(y))) { if (isCell(car(z))) { if (key == cdar(z)) { if (isNil(val)) cdr(y) = cdr(z); else { if (val == T) car(z) = key; else caar(z) = val; cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); } return; } } else if (key == car(z)) { if (isNil(val)) cdr(y) = cdr(z); else { if (val != T) car(z) = cons(val,key); cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); } return; } y = z; } } if (!isNil(val)) Tail(x, cons(val==T? key : cons(val,key), tail1(x))); } any get(any x, any key) { any y, z; if (!isCell(y = tail1(x))) return Nil; if (!isCell(car(y))) { if (key == car(y)) return T; } else if (key == cdar(y)) return caar(y); while (isCell(z = cdr(y))) { if (!isCell(car(z))) { if (key == car(z)) { cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); return T; } } else if (key == cdar(z)) { cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); return caar(z); } y = z; } return Nil; } any prop(any x, any key) { any y, z; if (isCell(y = tail1(x))) { if (!isCell(car(y))) { if (key == car(y)) return key; } else if (key == cdar(y)) return car(y); while (isCell(z = cdr(y))) { if (!isCell(car(z))) { if (key == car(z)) { cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); return key; } } else if (key == cdar(z)) { cdr(y) = cdr(z), cdr(z) = tail1(x), Tail(x, z); return car(z); } y = z; } } Tail(x, cons(y = cons(Nil,key), tail1(x))); return y; } // (put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any any doPut(any ex) { any x; cell c1, c2, c3; x = cdr(ex), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); while (isCell(cdr(x = cdr(x)))) { if (isCell(data(c1))) data(c1) = getn(data(c2), data(c1)); else { NeedSym(ex,data(c1)); Fetch(ex,data(c1)); data(c1) = isNum(data(c2)) && !unDig(data(c2))? val(data(c1)) : get(data(c1), data(c2)); } data(c2) = EVAL(car(x)); } NeedSym(ex,data(c1)); Push(c3, EVAL(car(x))); if (isNum(data(c2)) && IsZero(data(c2))) { Touch(ex,data(c1)); CheckVar(ex,data(c1)); val(data(c1)) = x = data(c3); } else { if (isExt(data(c1))) db(ex, data(c1), !isNil(data(c2))? 2 : 1); put(data(c1), data(c2), x = data(c3)); } drop(c1); return x; } // (get 'sym1|lst ['sym2|cnt ..]) -> any any doGet(any ex) { any x, y; cell c1; x = cdr(ex), data(c1) = EVAL(car(x)); if (!isCell(x = cdr(x))) return data(c1); Save(c1); do { y = EVAL(car(x)); if (isCell(data(c1))) data(c1) = getn(y, data(c1)); else { NeedSym(ex,data(c1)); Fetch(ex,data(c1)); data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y); } } while (isCell(x = cdr(x))); return Pop(c1); } // (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var any doProp(any ex) { any x; cell c1, c2; x = cdr(ex), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); while (isCell(x = cdr(x))) { if (isCell(data(c1))) data(c1) = getn(data(c2), data(c1)); else { NeedSym(ex,data(c1)); Fetch(ex,data(c1)); data(c1) = isNum(data(c2)) && !unDig(data(c2))? val(data(c1)) : get(data(c1), data(c2)); } data(c2) = EVAL(car(x)); } NeedSym(ex,data(c1)); CheckNil(ex,data(c1)); if (isExt(data(c1))) db(ex, data(c1), !isNil(data(c2))? 2 : 1); return prop(Pop(c1), data(c2)); } // (; 'sym1|lst [sym2|cnt ..]) -> any any doSemicol(any ex) { any x; cell c1; x = cdr(ex), data(c1) = EVAL(car(x)); if (!isCell(x = cdr(x))) return data(c1); Save(c1); do { if (isCell(data(c1))) data(c1) = getn(car(x), data(c1)); else { NeedSym(ex,data(c1)); Fetch(ex,data(c1)); data(c1) = isNum(car(x)) && !unDig(car(x))? val(data(c1)) : get(data(c1), car(x)); } } while (isCell(x = cdr(x))); return Pop(c1); } // (=: sym|0 [sym1|cnt .. sym2|0] 'any) -> any any doSetCol(any ex) { any x, y, z; cell c1; x = cdr(ex), y = val(This); if (z = car(x), isCell(cdr(x = cdr(x)))) { Fetch(ex,y); y = isNum(z) && !unDig(z)? val(y) : get(y,z); while (z = car(x), isCell(cdr(x = cdr(x)))) { if (isCell(y)) y = getn(z,y); else { NeedSym(ex,y); Fetch(ex,y); y = isNum(z) && !unDig(z)? val(y) : get(y,z); } } } NeedSym(ex,y); Push(c1, EVAL(car(x))); if (isNum(z) && IsZero(z)) { Touch(ex,y); CheckVar(ex,y); val(y) = x = data(c1); } else { if (isExt(y)) db(ex, y, !isNil(z)? 2 : 1); put(y, z, x = data(c1)); } drop(c1); return x; } // (: sym|0 [sym1|cnt ..]) -> any any doCol(any ex) { any x, y; x = cdr(ex), y = val(This); Fetch(ex,y); y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x)); while (isCell(x = cdr(x))) { if (isCell(y)) y = getn(car(x), y); else { NeedSym(ex,y); Fetch(ex,y); y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x)); } } return y; } // (:: sym|0 [sym1|cnt .. sym2]) -> var any doPropCol(any ex) { any x, y; x = cdr(ex), y = val(This); if (isCell(cdr(x))) { Fetch(ex,y); y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x)); while (isCell(cdr(x = cdr(x)))) { if (isCell(y)) y = getn(car(x), y); else { NeedSym(ex,y); Fetch(ex,y); y = isNum(car(x)) && !unDig(car(x))? val(y) : get(y, car(x)); } } } NeedSym(ex,y); CheckNil(ex,y); if (isExt(y)) db(ex, y, !isNil(car(x))? 2 : 1); return prop(y, car(x)); } // (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst any doPutl(any ex) { any x; cell c1, c2; x = cdr(ex), Push(c1, EVAL(car(x))); x = cdr(x), Push(c2, EVAL(car(x))); while (isCell(x = cdr(x))) { if (isCell(data(c1))) data(c1) = getn(data(c2), data(c1)); else { NeedSym(ex,data(c1)); Fetch(ex,data(c1)); data(c1) = isNum(data(c2)) && !unDig(data(c2))? val(data(c1)) : get(data(c1), data(c2)); } data(c2) = EVAL(car(x)); } NeedSym(ex,data(c1)); CheckNil(ex,data(c1)); Touch(ex,data(c1)); while (isCell(tail(data(c1)))) Tail(data(c1), cdr(tail1(data(c1)))); for (x = data(c2); isCell(x); x = cdr(x)) { if (!isCell(car(x))) Tail(data(c1), cons(car(x), tail1(data(c1)))); else if (!isNil(caar(x))) Tail(data(c1), cons(caar(x)==T? cdar(x) : car(x), tail1(data(c1)))); } drop(c1); return data(c2); } // (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst any doGetl(any ex) { any x, y; cell c1, c2; x = cdr(ex), Push(c1, EVAL(car(x))); while (isCell(x = cdr(x))) { y = EVAL(car(x)); if (isCell(data(c1))) data(c1) = getn(y, data(c1)); else { NeedSym(ex,data(c1)); Fetch(ex,data(c1)); data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y); } } NeedSym(ex,data(c1)); Fetch(ex,data(c1)); if (!isCell(x = tail1(data(c1)))) data(c2) = Nil; else { Push(c2, y = cons(car(x),Nil)); while (isCell(x = cdr(x))) y = cdr(y) = cons(car(x),Nil); } drop(c1); return data(c2); } static void wipe(any x) { any y, z; for (y = tail1(x); isCell(y); y = cdr(y)); if (!isNum(y)) { val(x) = Nil; tail(x) = y; } else { z = numCell(y); while (isNum(cdr(z))) z = numCell(cdr(z)); if (isNil(cdr(z)) || cdr(z) == At) { val(x) = Nil; Tail(x, y); cdr(z) = Nil; } } } // (wipe 'sym|lst) -> sym|lst any doWipe(any x) { any y; x = cdr(x); if (!isNil(x = EVAL(car(x)))) if (!isCell(x)) wipe(x); else { y = x; do wipe(car(y)); while (isCell(y = cdr(y))); } return x; } static any meta(any x, any y) { any z; while (isCell(x)) { if (isSym(car(x))) if (!isNil(z = get(car(x),y)) || !isNil(z = meta(val(car(x)), y))) return z; x = cdr(x); } return Nil; } // (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any any doMeta(any ex) { any x, y; cell c1; x = cdr(ex), Push(c1, EVAL(car(x))); if (isSym(data(c1))) { Fetch(ex,data(c1)); data(c1) = val(data(c1)); } x = cdr(x), y = EVAL(car(x)); data(c1) = meta(data(c1), y); while (isCell(x = cdr(x))) { y = EVAL(car(x)); if (isCell(data(c1))) data(c1) = getn(y, data(c1)); else { NeedSym(ex,data(c1)); Fetch(ex,data(c1)); data(c1) = isNum(y) && !unDig(y)? val(data(c1)) : get(data(c1), y); } } return Pop(c1); } /*** Case mappings from the GNU Kaffe Project ***/ #define CHAR_UPPERCASE 1 #define CHAR_LOWERCASE 2 #define CHAR_LETTER 62 #define CHAR_DIGIT 512 static uint16_t Blocks[] = { 0x1C2, 0x1C2, 0x1C1, 0x12C, 0x12B, 0x1A0, 0x1F8, 0x2DC, 0x25F, 0x2EE, 0x215, 0x346, 0x2DC, 0x326, 0x2BC, 0x216, 0x15F, 0x2D4, 0x376, 0x376, 0x376, 0x369, 0xFE8F, 0x344, 0xFF85, 0xFF65, 0xFDB5, 0xFDA1, 0x1B, 0x2C4, 0x1C, 0x47, 0xFEA8, 0xFF8C, 0x235, 0xFEFF, 0x1A, 0xFEBF, 0x26, 0xFB20, 0xFE28, 0x113, 0x104, 0xFB61, 0xFB5A, 0x10B, 0x109, 0xFE, 0xFF08, 0x229, 0x25E, 0x1C7, 0x1FC, 0x1DC, 0xFC46, 0x229, 0xFE27, 0xFB55, 0x169, 0xFBC8, 0xFC, 0x103, 0xFB68, 0xFB48, 0xFB28, 0xFB08, 0xFAE8, 0xFAC8, 0xFAA8, 0xFA88, 0xFA68, 0xFA48, 0x65, 0x50, 0xAB, 0x139, 0xFE0E, 0x63, 0x155, 0x1A8, 0xF669, 0x129, 0x128, 0xF91F, 0xFE56, 0x108, 0x107, 0xFAC0, 0xFC8E, 0xFEAD, 0xC6, 0xFCA7, 0xFB95, 0xF47D, 0x9F, 0xFB17, 0xFE20, 0xFD28, 0xFB2F, 0x3B, 0xF3B9, 0xFE57, 0xFCCE, 0xFFBB, 0xF339, 0xFA98, 0xFF8B, 0xFF3B, 0xFA54, 0xF7E3, 0xFF2B, 0xFAD7, 0xFB69, 0xFC3A, 0xFEE5, 0xF4C8, 0xFCB0, 0xFA88, 0xFDBF, 0xF448, 0xFE45, 0xFCC7, 0xFE4F, 0xF7F1, 0xF715, 0xF2E8, 0xFD9F, 0xF348, 0xF96A, 0xFC02, 0xFD97, 0xF2C8, 0xF2A8, 0xF4B9, 0xF4B3, 0xEF6B, 0xF86A, 0xF84A, 0xFC58, 0xF80A, 0xF7EA, 0xFC0F, 0xF7AA, 0xEE9C, 0xFB90, 0xF74A, 0xF7FA, 0xF70A, 0xF7CA, 0xF792, 0xF471, 0xF4D2, 0xF732, 0xF64A, 0xF401, 0xF64D, 0xEFA8, 0xF5CA, 0xF5AA, 0xECA1, 0xF569, 0xF54A, 0xF52A, 0xF50A, 0xF4EA, 0xF4CA, 0xF4AA, 0xF48A, 0xF46A, 0xF44A, 0xF42A, 0xF40A, 0xF3EA, 0xF3CA, 0xF3AA, 0xF38A, 0xF36A, 0xF34A, 0xF32A, 0xF289, 0xF777, 0xF2CA, 0xF2AA, 0xF737, 0xEC28, 0xEC08, 0xEBE8, 0xEBC8, 0xF1EA, 0xF4A2, 0xF545, 0xEDC6, 0xF2D7, 0xF14A, 0xE8ED, 0xE81E, 0xF0EA, 0xF597, 0xEA68, 0xEA48, 0xEA28, 0xEA08, 0xE9E8, 0xE9C8, 0xE9A8, 0xE988, 0xE968, 0xE948, 0xE928, 0xE908, 0xE8E8, 0xE8C8, 0xE8A8, 0xE888, 0xE868, 0xE848, 0xE828, 0xE808, 0xE7E8, 0xE7C8, 0xE7A8, 0xE788, 0xE768, 0xE748, 0xE728, 0xE708, 0xE6E8, 0xE6C8, 0xE6A8, 0xE688, 0xE668, 0xE648, 0xE628, 0xE608, 0xE5E8, 0xE5C8, 0xE5A8, 0xE588, 0xE568, 0xE548, 0xE55F, 0xE53F, 0xE51F, 0xE4FF, 0xEFD7, 0xE4BF, 0xE49F, 0xE485, 0xEF87, 0xEF57, 0xEF57, 0xEF57, 0xEF57, 0xEF47, 0xE1AD, 0xEF46, 0xEF46, 0xEF46, 0xE1E0, 0xE3DD, 0xEF06, 0xE9D9, 0xEBEB, 0xE244, 0xEED4, 0xEF65, 0xE1F5, 0xEF45, 0xEEE9, 0xEF7C, 0xEE74, 0xEF70, 0xEF7D, 0xEF78, 0xEE91, 0xEFD3, 0xEE7D, 0xEE25, 0xEE27, 0xEF65, 0xEFDD, 0xEE96, 0xEFD3, 0xEFE1, 0xEF69, 0xDF88, 0xDF68, 0xDF48, 0xED2B, 0xED3D, 0xED19, 0xEF1C, 0xEF08, 0xED47, 0xED3D, 0xED33, 0xEC2B, 0xEC0B, 0xEBEB, 0xEBCB, 0xEBCE, 0xEA7C, 0xEB69, 0xEB6C, 0xE9B6, 0xEB0B, 0xEAEB, 0xE9E9, 0xDCA8, 0xDC88, 0xDC68, 0xDC48, 0xE910, 0xEA23, 0xEB58, 0xEB4F, 0xEB45, 0xEAE5, 0xDB68, 0xDB48, 0xE92B, 0xE90B, 0xE8EB, 0xE8CB, 0xE8AB, 0xE88B, 0xE86B, 0xE84B, 0xDA28, 0xDA08, 0xD9E8, 0xD9C8, 0xD9A8, 0xD988, 0xD968, 0xD948, 0xD928, 0xD908, 0xD8E8, 0xD8C8, 0xD8A8, 0xD888, 0xD868, 0xD848, 0xD828, 0xD808, 0xD7E8, 0xD7C8, 0xD7A8, 0xD788, 0xD768, 0xD748, 0xD728, 0xD708, 0xD6E8, 0xD6C8, 0xD6A8, 0xD688, 0xD668, 0xD648, 0xD628, 0xD608, 0xD5E8, 0xD5C8, 0xD5A8, 0xD588, 0xD568, 0xD548, 0xD528, 0xD508, 0xD4E8, 0xD4C8, 0xE2B1, 0xE28B, 0xE26B, 0xE270, 0xE22B, 0xE20B, 0xE1EB, 0xE1CB, 0xE1AB, 0xE18B, 0xE18E, 0xDD8F, 0xE3A8, 0xDFD3, 0xD929, 0xD90A, 0xE348, 0xD8C9, 0xD8AA, 0xDCD7, 0xDCB2, 0xD681, 0xD82A, 0xD80A, 0xE268, 0xCEDE, 0xD168, 0xD148, 0xE116, 0xE0E9, 0xE1CB, 0xE0B7, 0xE0B7, 0xE15E, 0xDF17, 0xE034, 0xE013, 0xDFF3, 0xDFD3, 0xDE6C, 0xDF93, 0xDF73, 0xDF55, 0xDF34, 0xD56A, 0xD54A, 0xD52A, 0xD50A, 0xD4EA, 0xD4CA, 0xD4AA, 0xD48A, 0xD46A, 0xD44A, 0xD42A, 0xD40A, 0xD3EA, 0xD3CA, 0xD3AA, 0xD38A, 0xD36A, 0xD34A, 0xD32A, 0xD30A, 0xD2EA, 0xD2CA, 0xD2AA, 0xD28A, 0xD26A, 0xD24A, 0xD22A, 0xD20A, 0xD1EA, 0xD1CA, 0xD1AA, 0xD18A, 0xD16A, 0xD14A, 0xD12A, 0xD10A, 0xD0EA, 0xD0CA, 0xD0AA, 0xD08A, 0xD06A, 0xD04A, 0xD02A, 0xD00A, 0xCFEA, 0xCFCA, 0xCFAA, 0xCF8A, 0xCF6A, 0xCF4A, 0xCF2A, 0xCF0A, 0xCEEA, 0xCECA, 0xCEAA, 0xCE8A, 0xCE6A, 0xCE4A, 0xCE2A, 0xCE0A, 0xCDEA, 0xCDCA, 0xCDAA, 0xCD8A, 0xCD6A, 0xCD4A, 0xCD2A, 0xCD0A, 0xCCEA, 0xCCCA, 0xCCAA, 0xCC8A, 0xCC6A, 0xCC4A, 0xCC2A, 0xCC0A, 0xCBEA, 0xCBCA, 0xCBAA, 0xCB8A, 0xCB6A, 0xCB4A, 0xCB2A, 0xCB0A, 0xCAEA, 0xCACA, 0xCAAA, 0xCA8A, 0xCA6A, 0xCA4A, 0xCA2A, 0xCA0A, 0xC9EA, 0xC9CA, 0xC9AA, 0xC98A, 0xC96A, 0xC94A, 0xC92A, 0xC90A, 0xC8EA, 0xC8CA, 0xC8AA, 0xC88A, 0xC86A, 0xC84A, 0xC82A, 0xC80A, 0xC7EA, 0xC7CA, 0xC7AA, 0xC78A, 0xC76A, 0xC74A, 0xC72A, 0xC70A, 0xC6EA, 0xC6CA, 0xC6AA, 0xC68A, 0xC66A, 0xC64A, 0xC62A, 0xC60A, 0xC5EA, 0xC5CA, 0xC5AA, 0xC58A, 0xC56A, 0xC54A, 0xC52A, 0xC50A, 0xC4EA, 0xC4CA, 0xC4AA, 0xC48A, 0xC46A, 0xC44A, 0xC42A, 0xC40A, 0xC3EA, 0xC3CA, 0xC3AA, 0xC38A, 0xC36A, 0xC34A, 0xC32A, 0xC30A, 0xC2EA, 0xC2CA, 0xC2AA, 0xC28A, 0xC26A, 0xC24A, 0xC22A, 0xC20A, 0xC1EA, 0xC1CA, 0xC1AA, 0xC18A, 0xC16A, 0xC14A, 0xC12A, 0xC10A, 0xC0EA, 0xC0CA, 0xC0AA, 0xC08A, 0xC06A, 0xC04A, 0xC02A, 0xC00A, 0xBFEA, 0xBFCA, 0xBFAA, 0xBF8A, 0xBF6A, 0xBF4A, 0xBF2A, 0xBF0A, 0xBEEA, 0xBECA, 0xBEAA, 0xBE8A, 0xBE6A, 0xBE4A, 0xBE2A, 0xBE0A, 0xBDEA, 0xBDCA, 0xBDAA, 0xBD8A, 0xBD6A, 0xBD4A, 0xBD2A, 0xBD0A, 0xBCEA, 0xBCCA, 0xBCAA, 0xBC8A, 0xBC6A, 0xBC4A, 0xBC2A, 0xBC0A, 0xBBEA, 0xB2E0, 0xB568, 0xB548, 0xBB6A, 0xBB4A, 0xBB2A, 0xBB0A, 0xBAEA, 0xBACA, 0xBAAA, 0xBA8A, 0xBA6A, 0xBA4A, 0xBA2A, 0xBA0A, 0xB9EA, 0xB9CA, 0xB9AA, 0xB98A, 0xB96A, 0xB94A, 0xB92A, 0xB90A, 0xB8EA, 0xB8CA, 0xB8AA, 0xB88A, 0xB86A, 0xB84A, 0xB82A, 0xB80A, 0xB7EA, 0xB7CA, 0xB7AA, 0xB78A, 0xB76A, 0xB74A, 0xB72A, 0xB70A, 0xB6EA, 0xB6CA, 0xB6AA, 0xB68A, 0xB66A, 0xB64A, 0xB62A, 0xB60A, 0xB5EA, 0xB5CA, 0xB5AA, 0xB58A, 0xB56A, 0xB54A, 0xB52A, 0xB50A, 0xB4EA, 0xB4CA, 0xB4AA, 0xB48A, 0xB46A, 0xB44A, 0xB42A, 0xB40A, 0xB3EA, 0xB3CA, 0xB3AA, 0xB38A, 0xB36A, 0xB34A, 0xB32A, 0xB30A, 0xB2EA, 0xB2CA, 0xB2AA, 0xB28A, 0xB26A, 0xB24A, 0xB22A, 0xB20A, 0xB1EA, 0xB1CA, 0xB1AA, 0xB18A, 0xB16A, 0xB14A, 0xB12A, 0xB10A, 0xB0EA, 0xB0CA, 0xB0AA, 0xB08A, 0xB06A, 0xB04A, 0xB02A, 0xB00A, 0xAFEA, 0xAFCA, 0xAFAA, 0xAF8A, 0xAF6A, 0xAF4A, 0xAF2A, 0xAF0A, 0xAEEA, 0xAECA, 0xAEAA, 0xAE8A, 0xAE6A, 0xAE4A, 0xAE2A, 0xAE0A, 0xADEA, 0xADCA, 0xADAA, 0xAD8A, 0xAD6A, 0xAD4A, 0xAD2A, 0xAD0A, 0xACEA, 0xACCA, 0xACAA, 0xAC8A, 0xAC6A, 0xAC4A, 0xAC2A, 0xAC0A, 0xABEA, 0xABCA, 0xABAA, 0xAB8A, 0xAB6A, 0xAB4A, 0xAB2A, 0xAB0A, 0xAAEA, 0xAACA, 0xAAAA, 0xAA8A, 0xAA6A, 0xAA4A, 0xAA2A, 0xAA0A, 0xA9EA, 0xA9CA, 0xA9AA, 0xA98A, 0xA96A, 0xA94A, 0xA92A, 0xA90A, 0xA8EA, 0xA8CA, 0xA8AA, 0xA88A, 0xA86A, 0xA84A, 0xA82A, 0xA80A, 0xA7EA, 0xA7CA, 0xA7AA, 0xA78A, 0xA76A, 0xA74A, 0xA72A, 0xA70A, 0xA6EA, 0xA6CA, 0xA6AA, 0xA68A, 0xA66A, 0xA64A, 0xA62A, 0xA60A, 0xA5EA, 0xA5CA, 0xA5AA, 0xA58A, 0xA56A, 0xA54A, 0xA52A, 0xA50A, 0xA4EA, 0xA4CA, 0xA4AA, 0xA48A, 0xA46A, 0xA44A, 0xA42A, 0xA40A, 0xA3EA, 0xA3CA, 0xA3AA, 0xA38A, 0xA36A, 0xA34A, 0xA32A, 0xA30A, 0xA2EA, 0xA2CA, 0xA2AA, 0xA28A, 0xA26A, 0xA24A, 0xA22A, 0xA20A, 0xA1EA, 0xA1CA, 0xA1AA, 0xA18A, 0xA16A, 0xA14A, 0xA12A, 0xA10A, 0xA0EA, 0xA0CA, 0xA0AA, 0xA08A, 0xA06A, 0xA04A, 0xA02A, 0xA00A, 0x9FEA, 0x9FCA, 0x9FAA, 0x9F8A, 0x9F6A, 0x9F4A, 0x9F2A, 0x9F0A, 0x9EEA, 0x9ECA, 0x9EAA, 0x9E8A, 0x9E6A, 0x9E4A, 0x9E2A, 0x9E0A, 0x9DEA, 0x9DCA, 0x9DAA, 0x9D8A, 0x9D6A, 0x9D4A, 0x9D2A, 0x9D0A, 0x9CEA, 0x9CCA, 0x9CAA, 0x9C8A, 0x9C6A, 0x9C4A, 0x9C2A, 0x9C0A, 0x9BEA, 0x9BCA, 0x9BAA, 0x9B8A, 0x9B6A, 0x9B4A, 0x9B2A, 0x9B0A, 0x9AEA, 0x9ACA, 0x9AAA, 0x9A8A, 0x9A6A, 0x9A4A, 0x9A2A, 0x9A0A, 0x99EA, 0x99CA, 0x99AA, 0x998A, 0x996A, 0x994A, 0x992A, 0x990A, 0x98EA, 0x98CA, 0x98AA, 0x988A, 0x986A, 0x984A, 0x982A, 0x980A, 0x97EA, 0x97CA, 0x97AA, 0x978A, 0x976A, 0x974A, 0x972A, 0x970A, 0x96EA, 0x96CA, 0x96AA, 0x968A, 0x966A, 0x964A, 0x962A, 0x960A, 0x95EA, 0x95CA, 0x95AA, 0x958A, 0x956A, 0x954A, 0x952A, 0x950A, 0x94EA, 0x94CA, 0x94AA, 0x948A, 0x946A, 0x944A, 0x942A, 0x940A, 0x93EA, 0x93CA, 0x93AA, 0x938A, 0x936A, 0x934A, 0x932A, 0x930A, 0x92EA, 0x92CA, 0x92AA, 0x928A, 0x926A, 0x924A, 0x922A, 0x920A, 0x91EA, 0x91CA, 0x91AA, 0x918A, 0x916A, 0x914A, 0x912A, 0x910A, 0x90EA, 0x90CA, 0x90AA, 0x908A, 0x906A, 0x904A, 0x902A, 0x900A, 0x8FEA, 0x8FCA, 0x8FAA, 0x8F8A, 0x8F6A, 0x8F4A, 0x8F2A, 0x8F0A, 0x8EEA, 0x8ECA, 0x8EAA, 0x8E8A, 0x8E6A, 0x8E4A, 0x8E2A, 0x8E0A, 0x8DEA, 0x8DCA, 0x8DAA, 0x8D8A, 0x8D6A, 0x8D4A, 0x8D2A, 0x8D0A, 0x8CEA, 0x8CCA, 0x8CAA, 0x8C8A, 0x8C6A, 0x8C4A, 0x8C2A, 0x8C0A, 0x8BEA, 0x8BCA, 0x8BAA, 0x8B8A, 0x8B6A, 0x8B4A, 0x8B2A, 0x8B0A, 0x8AEA, 0x8ACA, 0x8AAA, 0x8A8A, 0x8A6A, 0x8A4A, 0x8A2A, 0x8A0A, 0x89EA, 0x89CA, 0x89AA, 0x898A, 0x896A, 0x894A, 0x892A, 0x890A, 0x88EA, 0x88CA, 0x88AA, 0x888A, 0x886A, 0x884A, 0x882A, 0x880A, 0x87EA, 0x87CA, 0x87AA, 0x878A, 0x876A, 0x874A, 0x872A, 0x870A, 0x86EA, 0x86CA, 0x86AA, 0x868A, 0x866A, 0x864A, 0x862A, 0x860A, 0x85EA, 0x85CA, 0x85AA, 0x858A, 0x856A, 0x854A, 0x852A, 0x850A, 0x84EA, 0x84CA, 0x84AA, 0x848A, 0x846A, 0x844A, 0x842A, 0x840A, 0x83EA, 0x83CA, 0x83AA, 0x838A, 0x836A, 0x834A, 0x832A, 0x830A, 0x82EA, 0x82CA, 0x82AA, 0x828A, 0x826A, 0x824A, 0x822A, 0x820A, 0x81EA, 0x81CA, 0x81AA, 0x818A, 0x816A, 0x814A, 0x812A, 0x810A, 0x80EA, 0x80CA, 0x80AA, 0x808A, 0x806A, 0x804A, 0x802A, 0x800A, 0x7FEA, 0x7FCA, 0x7FAA, 0x7F8A, 0x7F6A, 0x7F4A, 0x7F2A, 0x7F0A, 0x7EEA, 0x7ECA, 0x7EAA, 0x7E8A, 0x7E6A, 0x7E4A, 0x7E2A, 0x7E0A, 0x7DEA, 0x7DCA, 0x7DAA, 0x7D8A, 0x7D6A, 0x7D4A, 0x7D2A, 0x7D0A, 0x7CEA, 0x7CCA, 0x7CAA, 0x7C8A, 0x7C6A, 0x7C4A, 0x7C2A, 0x7C0A, 0x7BEA, 0x7BCA, 0x7BAA, 0x7B8A, 0x7B6A, 0x7B4A, 0x7B2A, 0x7B0A, 0x7AEA, 0x7ACA, 0x7AAA, 0x7A8A, 0x7A6A, 0x7A4A, 0x7A2A, 0x7A0A, 0x79EA, 0x79CA, 0x79AA, 0x798A, 0x796A, 0x794A, 0x792A, 0x790A, 0x78EA, 0x78CA, 0x78AA, 0x788A, 0x786A, 0x784A, 0x782A, 0x780A, 0x77EA, 0x77CA, 0x77AA, 0x778A, 0x776A, 0x774A, 0x772A, 0x770A, 0x76EA, 0x76CA, 0x76AA, 0x768A, 0x766A, 0x764A, 0x762A, 0x760A, 0x75EA, 0x75CA, 0x75AA, 0x758A, 0x756A, 0x754A, 0x752A, 0x750A, 0x74EA, 0x74CA, 0x74AA, 0x748A, 0x746A, 0x744A, 0x742A, 0x740A, 0x73EA, 0x73CA, 0x73AA, 0x738A, 0x736A, 0x734A, 0x732A, 0x730A, 0x72EA, 0x72CA, 0x72AA, 0x728A, 0x726A, 0x724A, 0x722A, 0x720A, 0x71EA, 0x71CA, 0x71AA, 0x718A, 0x716A, 0x714A, 0x712A, 0x710A, 0x70EA, 0x70CA, 0x70AA, 0x708A, 0x706A, 0x704A, 0x702A, 0x700A, 0x6FEA, 0x6FCA, 0x6FAA, 0x6F8A, 0x6F6A, 0x6F4A, 0x6F2A, 0x6F0A, 0x6EEA, 0x6ECA, 0x6EAA, 0x6E8A, 0x6E6A, 0x6E4A, 0x6E2A, 0x6E0A, 0x6DEA, 0x6DCA, 0x6DAA, 0x6D8A, 0x6D6A, 0x6D4A, 0x6D2A, 0x6D0A, 0x6CEA, 0x6CCA, 0x6CAA, 0x6C8A, 0x6C6A, 0x6C4A, 0x6C2A, 0x6C0A, 0x6BEA, 0x6BCA, 0x6BAA, 0x6B8A, 0x6B6A, 0x6B4A, 0x6B2A, 0x6B0A, 0x6AEA, 0x6ACA, 0x6AAA, 0x6A8A, 0x6A6A, 0x6A4A, 0x6A2A, 0x6A0A, 0x69EA, 0x60F0, 0x6368, 0x6348, 0x696A, 0x694A, 0x692A, 0x690A, 0x68EA, 0x68CA, 0x68AA, 0x688A, 0x686A, 0x684A, 0x682A, 0x680A, 0x67EA, 0x67CA, 0x67AA, 0x678A, 0x676A, 0x674A, 0x672A, 0x670A, 0x66EA, 0x66CA, 0x66AA, 0x668A, 0x666A, 0x664A, 0x662A, 0x660A, 0x65EA, 0x65CA, 0x65AA, 0x658A, 0x656A, 0x654A, 0x652A, 0x650A, 0x6B26, 0x6DE1, 0x6E9C, 0x5E48, 0x5E28, 0x5E08, 0x5DE8, 0x5DC8, 0x5DA8, 0x5D88, 0x5D68, 0x5D48, 0x5D28, 0x5D08, 0x5CE8, 0x5CC8, 0x5CA8, 0x5C88, 0x5C68, 0x5C48, 0x5C28, 0x5C08, 0x5BE8, 0x5BC8, 0x5BA8, 0x5B88, 0x5B68, 0x5B48, 0x5B28, 0x5B08, 0x5AE8, 0x5AC8, 0x5AA8, 0x5A88, 0x5A68, 0x5A48, 0x5A28, 0x5A08, 0x59E8, 0x59C8, 0x59A8, 0x5988, 0x5968, 0x5948, 0x5928, 0x5908, 0x58E8, 0x58C8, 0x58A8, 0x5888, 0x5868, 0x5848, 0x5828, 0x5808, 0x57E8, 0x57C8, 0x57A8, 0x5788, 0x5768, 0x5748, 0x5D6A, 0x5D4A, 0x5D2A, 0x5D0A, 0x5CEA, 0x5CCA, 0x5CAA, 0x5C8A, 0x5C6A, 0x5C4A, 0x5C2A, 0x5C0A, 0x5BEA, 0x5BCA, 0x5BAA, 0x5B8A, 0x5B6A, 0x5B4A, 0x5B2A, 0x5B0A, 0x5AEA, 0x5ACA, 0x5AAA, 0x5A8A, 0x5A6A, 0x5A4A, 0x5A2A, 0x5A0A, 0x59EA, 0x59CA, 0x59AA, 0x598A, 0x596A, 0x594A, 0x592A, 0x590A, 0x58EA, 0x58CA, 0x58AA, 0x588A, 0x586A, 0x584A, 0x582A, 0x580A, 0x57EA, 0x57CA, 0x57AA, 0x578A, 0x576A, 0x574A, 0x572A, 0x570A, 0x56EA, 0x56CA, 0x56AA, 0x568A, 0x566A, 0x564A, 0x562A, 0x560A, 0x55EA, 0x55CA, 0x55AA, 0x558A, 0x556A, 0x554A, 0x552A, 0x550A, 0x54EA, 0x54CA, 0x54AA, 0x548A, 0x546A, 0x544A, 0x542A, 0x540A, 0x53EA, 0x53CA, 0x53AA, 0x538A, 0x536A, 0x534A, 0x532A, 0x530A, 0x52EA, 0x52CA, 0x52AA, 0x528A, 0x526A, 0x524A, 0x522A, 0x520A, 0x51EA, 0x51CA, 0x51AA, 0x518A, 0x516A, 0x514A, 0x512A, 0x510A, 0x50EA, 0x50CA, 0x50AA, 0x508A, 0x506A, 0x504A, 0x502A, 0x500A, 0x4FEA, 0x4FCA, 0x4FAA, 0x4F8A, 0x4F6A, 0x4F4A, 0x4F2A, 0x4F0A, 0x4EEA, 0x4ECA, 0x4EAA, 0x4E8A, 0x4E6A, 0x4E4A, 0x4E2A, 0x4E0A, 0x4DEA, 0x4DCA, 0x4DAA, 0x4D8A, 0x4D6A, 0x4D4A, 0x4D2A, 0x4D0A, 0x4CEA, 0x4CCA, 0x4CAA, 0x4C8A, 0x4C6A, 0x4C4A, 0x4C2A, 0x4C0A, 0x4BEA, 0x4BCA, 0x4BAA, 0x4B8A, 0x4B6A, 0x4B4A, 0x4B2A, 0x4B0A, 0x4AEA, 0x4ACA, 0x4AAA, 0x4A8A, 0x4A6A, 0x4A4A, 0x4A2A, 0x4A0A, 0x49EA, 0x49CA, 0x49AA, 0x498A, 0x496A, 0x494A, 0x492A, 0x490A, 0x48EA, 0x48CA, 0x48AA, 0x488A, 0x486A, 0x484A, 0x482A, 0x480A, 0x47EA, 0x47CA, 0x47AA, 0x478A, 0x476A, 0x474A, 0x472A, 0x470A, 0x46EA, 0x46CA, 0x46AA, 0x468A, 0x466A, 0x464A, 0x462A, 0x460A, 0x45EA, 0x45CA, 0x45AA, 0x458A, 0x456A, 0x454A, 0x452A, 0x450A, 0x44EA, 0x44CA, 0x44AA, 0x448A, 0x446A, 0x444A, 0x442A, 0x440A, 0x43EA, 0x43CA, 0x43AA, 0x438A, 0x436A, 0x434A, 0x432A, 0x430A, 0x42EA, 0x42CA, 0x42AA, 0x428A, 0x426A, 0x424A, 0x422A, 0x420A, 0x41EA, 0x41CA, 0x41AA, 0x418A, 0x416A, 0x414A, 0x412A, 0x410A, 0x40EA, 0x40CA, 0x40AA, 0x408A, 0x406A, 0x404A, 0x402A, 0x400A, 0x3FEA, 0x3FCA, 0x3FAA, 0x3F8A, 0x3F6A, 0x3F4A, 0x3F2A, 0x3F0A, 0x3EEA, 0x3ECA, 0x3EAA, 0x3E8A, 0x3E6A, 0x3E4A, 0x3E2A, 0x3E0A, 0x3DEA, 0x3DCA, 0x3DAA, 0x3D8A, 0x3D6A, 0x3D4A, 0x3D2A, 0x3D0A, 0x3CEA, 0x3CCA, 0x3CAA, 0x3C8A, 0x3C6A, 0x3C4A, 0x3C2A, 0x3C0A, 0x3BEA, 0x3BCA, 0x3BAA, 0x3B8A, 0x3B6A, 0x3B4A, 0x3B2A, 0x3B0A, 0x3AEA, 0x3ACA, 0x3AAA, 0x3A8A, 0x3A6A, 0x3A4A, 0x3A2A, 0x3A0A, 0x39EA, 0x39CA, 0x39AA, 0x398A, 0x396A, 0x394A, 0x392A, 0x390A, 0x38EA, 0x38CA, 0x38AA, 0x388A, 0x386A, 0x384A, 0x382A, 0x380A, 0x37EA, 0x37CA, 0x37AA, 0x378A, 0x376A, 0x374A, 0x372A, 0x370A, 0x36EA, 0x36CA, 0x36AA, 0x368A, 0x366A, 0x364A, 0x362A, 0x360A, 0x35EA, 0x35CA, 0x35AA, 0x358A, 0x356A, 0x354A, 0x352A, 0x350A, 0x34EA, 0x34CA, 0x34AA, 0x348A, 0x346A, 0x344A, 0x342A, 0x340A, 0x33EA, 0x33CA, 0x33AA, 0x338A, 0x336A, 0x334A, 0x332A, 0x330A, 0x32EA, 0x32CA, 0x32AA, 0x328A, 0x326A, 0x324A, 0x322A, 0x320A, 0x31EA, 0x28F2, 0x2B68, 0x2B48, 0x3C2B, 0x3C0B, 0x3BEB, 0x3BCB, 0x3BAB, 0x3B8B, 0x3B6B, 0x3B4B, 0x3B2B, 0x3B0B, 0x3AEB, 0x3ACB, 0x3AAB, 0x3A8B, 0x3A6B, 0x3A4B, 0x3A2B, 0x3A0B, 0x39EB, 0x39CB, 0x39AB, 0x398B, 0x396B, 0x394B, 0x392B, 0x390B, 0x38EB, 0x38CB, 0x38AB, 0x388B, 0x386B, 0x384B, 0x382B, 0x380B, 0x37EB, 0x37CB, 0x37AB, 0x378B, 0x376B, 0x374B, 0x372B, 0x370B, 0x36EB, 0x36CB, 0x36AB, 0x368B, 0x366B, 0x364B, 0x362B, 0x360B, 0x35EB, 0x35CB, 0x35AB, 0x358B, 0x356B, 0x354B, 0x352B, 0x350B, 0x34EB, 0x34CB, 0x34AB, 0x348B, 0x346B, 0x344B, 0x344B, 0x342B, 0x340B, 0x33EB, 0x33CB, 0x33AB, 0x338B, 0x336B, 0x334B, 0x332B, 0x330B, 0x32EB, 0x32CB, 0x32AB, 0x328B, 0x326B, 0x324B, 0x322B, 0x320B, 0x31EB, 0x31CB, 0x31AB, 0x318B, 0x316B, 0x314B, 0x312B, 0x310B, 0x30EB, 0x30CB, 0x30AB, 0x308B, 0x306B, 0x304B, 0x302B, 0x300B, 0x2FEB, 0x2FCB, 0x2FAB, 0x2F8B, 0x2F6B, 0x2F4B, 0x2F2B, 0x2F0B, 0x2EEB, 0x2ECB, 0x2EAB, 0x2E8B, 0x2E6B, 0x2E4B, 0x2E2B, 0x2E0B, 0x2DEB, 0x2DCB, 0x2DAB, 0x2D8B, 0x2D6B, 0x2D4B, 0x2D2B, 0x2D0B, 0x2CEB, 0x2CCB, 0x2CAB, 0x2C8B, 0x2C6B, 0x2C4B, 0x2C2B, 0x2C0B, 0x2BEB, 0x2BCB, 0x2BAB, 0x2B8B, 0x2B6B, 0x2B4B, 0x2B2B, 0x2B0B, 0x2AEB, 0x2ACB, 0x2AAB, 0x2A8B, 0x2A6B, 0x2A4B, 0x2A2B, 0x2A0B, 0x29EB, 0x29CB, 0x29AB, 0x298B, 0x296B, 0x294B, 0x292B, 0x290B, 0x28EB, 0x28CB, 0x28AB, 0x288B, 0x286B, 0x284B, 0x282B, 0x280B, 0x27EB, 0x27CB, 0x27AB, 0x278B, 0x276B, 0x274B, 0x272B, 0x270B, 0x26EB, 0x26CB, 0x26AB, 0x268B, 0x266B, 0x264B, 0x262B, 0x260B, 0x25EB, 0x25CB, 0x25AB, 0x258B, 0x256B, 0x254B, 0x252B, 0x250B, 0x24EB, 0x24CB, 0x24AB, 0x248B, 0x246B, 0x244B, 0x242B, 0x240B, 0x23EB, 0x23CB, 0x23AB, 0x238B, 0x236B, 0x234B, 0x232B, 0x230B, 0x22EB, 0x22CB, 0x22AB, 0x228B, 0x226B, 0x224B, 0x222B, 0x220B, 0x21EB, 0x21CB, 0x21AB, 0x218B, 0x216B, 0x214B, 0x212B, 0x210B, 0x20EB, 0x20CB, 0x20AB, 0x208B, 0x206B, 0x204B, 0x202B, 0x200B, 0x1FEB, 0x1FCB, 0x1FAB, 0x1F8B, 0x1F6B, 0x1F4B, 0x1F2B, 0x1F0B, 0x1EEB, 0x1ECB, 0x1EAB, 0x1E8B, 0x1E6B, 0x1E4B, 0x1E2B, 0x1E0B, 0x1DEB, 0x1DCB, 0x1DAB, 0x1D8B, 0x1D6B, 0x1D4B, 0x1D2B, 0x1D0B, 0x1CEB, 0x1CCB, 0x1CAB, 0x1C8B, 0x1C6B, 0x1C4B, 0x1C2B, 0x1C0B, 0x1BEB, 0x1BCB, 0x1BAB, 0x1B8B, 0x1B6B, 0x106A, 0x104A, 0x102A, 0x100A, 0xFEA, 0xFCA, 0xFAA, 0xF8A, 0xF6A, 0x668, 0x8E8, 0x8C8, 0x8A8, 0x888, 0x868, 0x848, 0x7D7, 0x194B, 0x7B6, 0xD1C, 0xCFC, 0xCB2, 0xCA9, 0xC9C, 0xC7C, 0xC5C, 0xC3C, 0xC1C, 0xBFC, 0xBDC, 0xBBC, 0xB9C, 0xB7C, 0xB5E, 0xB2C, 0xB1C, 0xAB8, 0xADC, 0xA9C, 0x2C2, 0x528, 0x166B, 0x1667, 0x3FF, 0x9FC, 0x9DC, 0x9BC, 0x659, 0xBB8, 0x15A7, 0xFC6, 0x1C0, 0x1B1, 0x9CB, 0x82C, 0x1285, }; static uint16_t Data[] = { 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x5202, 0x2E82, 0x3E80, 0x5198, 0x2A14, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4686, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x1A1B, 0x1A1B, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4584, 0x3E80, 0x3E80, 0x3E80, 0x298, 0x3E80, 0x298, 0x6615, 0x6696, 0x298, 0x1A97, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4584, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4584, 0x4584, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x4584, 0x4584, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x2E82, 0x7282, 0x2E82, 0x3E80, 0x2E82, 0x4902, 0x7481, 0x7481, 0x7481, 0x7481, 0x7383, 0x1A1B, 0x1A1B, 0x1A1B, 0x6D82, 0x6D82, 0x4902, 0x4902, 0x3E80, 0x3E80, 0x2E82, 0x4902, 0x6E01, 0x6E01, 0x7501, 0x7501, 0x3E80, 0x1A1B, 0x1A1B, 0x1A1B, 0x1B02, 0x1B82, 0x1C02, 0x1C82, 0x1D02, 0x1D82, 0x1E02, 0x1E82, 0x1F02, 0x1F82, 0x2002, 0x2082, 0x2102, 0x2182, 0x2202, 0x2282, 0x2302, 0x2382, 0x2402, 0x2482, 0x2502, 0x2582, 0x2602, 0x2682, 0x2702, 0x2782, 0x455, 0xC99, 0x4D6, 0xC99, 0xF, 0xF, 0xF, 0xF, 0xF, 0x10F, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0x8F, 0x10F, 0x8F, 0x18F, 0x10F, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0xF, 0x10F, 0x10F, 0x10F, 0x8F, 0x20C, 0x298, 0x298, 0x318, 0x39A, 0x318, 0x298, 0x298, 0x455, 0x4D6, 0x298, 0x519, 0x598, 0x614, 0x598, 0x698, 0x709, 0x789, 0x809, 0x889, 0x909, 0x989, 0xA09, 0xA89, 0xB09, 0xB89, 0x598, 0x298, 0xC59, 0xC99, 0xC59, 0x298, 0xD01, 0xD81, 0xE01, 0xE81, 0xF01, 0xF81, 0x1001, 0x1081, 0x1101, 0x1181, 0x1201, 0x1281, 0x1301, 0x1381, 0x1401, 0x1481, 0x1501, 0x1581, 0x1601, 0x1681, 0x1701, 0x1781, 0x1801, 0x1881, 0x1901, 0x1981, 0x455, 0x298, 0x4D6, 0x1A1B, 0x1A97, 0x298, 0x298, 0x298, 0xC99, 0x455, 0x4D6, 0x3E80, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x282C, 0x298, 0x39A, 0x39A, 0x39A, 0x39A, 0x289C, 0x289C, 0x1A1B, 0x289C, 0x2902, 0x29DD, 0xC99, 0x2A14, 0x289C, 0x1A1B, 0x2A9C, 0x519, 0x2B0B, 0x2B8B, 0x1A1B, 0x2C02, 0x289C, 0x298, 0x1A1B, 0x2C8B, 0x2902, 0x2D5E, 0x2D8B, 0x2D8B, 0x2D8B, 0x298, 0x298, 0x519, 0x614, 0xC99, 0xC99, 0xC99, 0x3E80, 0x298, 0x39A, 0x318, 0x298, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5405, 0x5405, 0x5405, 0x3E80, 0x5405, 0x3E80, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x501C, 0x501C, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x4F81, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0xC99, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E82, 0x2E82, 0x2E82, 0x4902, 0x4902, 0x2E82, 0x2E82, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x2E82, 0x2E82, 0x2E82, 0x2E82, 0x2E82, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5305, 0x4606, 0x5305, 0x5305, 0x3E80, 0x5305, 0x5305, 0x3E80, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5398, 0x5405, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5087, 0x5087, 0x4606, 0x5087, 0x5087, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x2D8B, 0x840B, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x2E82, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x4606, 0x4606, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x1A1B, 0x1A1B, 0x4701, 0x298, 0x4781, 0x4781, 0x4781, 0x3E80, 0x4801, 0x3E80, 0x4881, 0x4881, 0x4902, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0xC99, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F82, 0x2F02, 0x2F02, 0x4A82, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x4B02, 0x4B82, 0x4B82, 0x3E80, 0x4C02, 0x4C82, 0x4D01, 0x4D01, 0x4D01, 0x4D82, 0x4E02, 0x2902, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x2E82, 0x3B81, 0x3C03, 0x3C82, 0x3001, 0x3082, 0x3D81, 0x3E01, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3101, 0x3182, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x2902, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x4E82, 0x4F02, 0x3D02, 0x2902, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B10, 0x5B10, 0x5B10, 0x5B10, 0x5B10, 0x5B10, 0x7F0B, 0x3E80, 0x3E80, 0x3E80, 0x7F8B, 0x800B, 0x808B, 0x810B, 0x818B, 0x820B, 0x519, 0x519, 0xC99, 0x455, 0x4D6, 0x2902, 0x3301, 0x3001, 0x3082, 0x3001, 0x3082, 0x3381, 0x3001, 0x3082, 0x3401, 0x3401, 0x3001, 0x3082, 0x2902, 0x3481, 0x3501, 0x3581, 0x3001, 0x3082, 0x3401, 0x3601, 0x3682, 0x3701, 0x3781, 0x3001, 0x3082, 0x2902, 0x2902, 0x3701, 0x3801, 0x2902, 0x3881, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3B81, 0x3C03, 0x3C82, 0x3B81, 0x3C03, 0x3C82, 0x3B81, 0x3C03, 0x3C82, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3D02, 0x3001, 0x3082, 0x501C, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x5087, 0x5087, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3201, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3282, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3901, 0x3001, 0x3082, 0x3901, 0x2902, 0x2902, 0x3001, 0x3082, 0x3901, 0x3001, 0x3082, 0x3981, 0x3981, 0x3001, 0x3082, 0x3001, 0x3082, 0x3A01, 0x3001, 0x3082, 0x2902, 0x3A85, 0x3001, 0x3082, 0x2902, 0x3B02, 0x4D01, 0x3001, 0x3082, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x598, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5398, 0x3E80, 0x3E80, 0x3E80, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x5398, 0x3E80, 0x5B10, 0x5405, 0x4606, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, 0x5B10, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x2902, 0x2902, 0x2902, 0x3F02, 0x3F82, 0x2902, 0x4002, 0x4002, 0x2902, 0x4082, 0x2902, 0x4102, 0x2902, 0x2902, 0x2902, 0x2902, 0x4002, 0x2902, 0x2902, 0x4182, 0x2902, 0x2902, 0x2902, 0x2902, 0x4202, 0x4282, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x4282, 0x2902, 0x2902, 0x4302, 0x2902, 0x2902, 0x4382, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x4402, 0x2902, 0x2902, 0x4402, 0x2902, 0x2902, 0x2902, 0x2902, 0x4402, 0x2902, 0x4482, 0x4482, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x4502, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x2902, 0x3E80, 0x3E80, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x1A1B, 0x1A1B, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x1A1B, 0x4584, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x5101, 0x3E80, 0x3E80, 0x4584, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x2E01, 0x2E01, 0x3E80, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x2E01, 0x4982, 0x4A02, 0x4A02, 0x4A02, 0x4902, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x2F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4F02, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5198, 0x4606, 0x4606, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, 0x4606, 0x5298, 0x4606, 0x4606, 0x5298, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5305, 0x5305, 0x5305, 0x5298, 0x5298, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x640B, 0x648B, 0x650B, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x5B88, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5509, 0x5589, 0x5609, 0x5689, 0x5709, 0x5789, 0x5809, 0x5889, 0x5909, 0x5989, 0x318, 0x5A18, 0x5A18, 0x5398, 0x3E80, 0x3E80, 0x4606, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x6615, 0x6696, 0x5484, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x5405, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x5198, 0x5198, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5484, 0x5484, 0x4606, 0x4606, 0x289C, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x709, 0x789, 0x809, 0x889, 0x909, 0x989, 0xA09, 0xA89, 0xB09, 0xB89, 0x5405, 0x5405, 0x5405, 0x5A9C, 0x5A9C, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4606, 0x3A85, 0x3A85, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3A85, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x4606, 0x5B88, 0x5B88, 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3E80, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x640B, 0x670B, 0x678B, 0x680B, 0x688B, 0x690B, 0x698B, 0x6A0B, 0x6A8B, 0x648B, 0x6B0B, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3A85, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3A85, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4606, 0x3A85, 0x3A85, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x39A, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x4606, 0x4606, 0x5198, 0x5198, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x298, 0x298, 0x318, 0x39A, 0x318, 0x298, 0x298, 0x6615, 0x6696, 0x298, 0x519, 0x598, 0x614, 0x598, 0x698, 0x709, 0x789, 0x809, 0x889, 0x909, 0x989, 0xA09, 0xA89, 0xB09, 0xB89, 0x598, 0x298, 0xC99, 0xC99, 0xC99, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x2A14, 0x298, 0x298, 0x298, 0x298, 0x5B10, 0x5B10, 0x5B10, 0x5B10, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x3A85, 0x3A85, 0x39A, 0x39A, 0x610B, 0x618B, 0x620B, 0x628B, 0x630B, 0x638B, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x4606, 0x3A85, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x4606, 0x5B88, 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x501C, 0x4606, 0x501C, 0x4606, 0x501C, 0x4606, 0x6615, 0x6696, 0x6615, 0x6696, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5B88, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x4584, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5087, 0x5087, 0x5087, 0x5B88, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, 0x3E80, 0x4606, 0x3E80, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x5B88, 0x4606, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x39A, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4584, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x5198, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x5198, 0x5198, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x501C, 0x501C, 0x501C, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x65B8, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x4606, 0x4606, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x4606, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x3E80, 0x3E80, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x1A97, 0x4584, 0x4584, 0x4584, 0x3E80, 0x5C09, 0x5C89, 0x5D09, 0x5D89, 0x5E09, 0x5E89, 0x5F09, 0x5F89, 0x6009, 0x6089, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x5198, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x5B88, 0x5B88, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x20C, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x6615, 0x6696, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x5198, 0x5198, 0x5198, 0x6B8B, 0x6C0B, 0x6C8B, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x3001, 0x3082, 0x2E82, 0x2E82, 0x2E82, 0x2E82, 0x2E82, 0x6D02, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x3E80, 0x3E80, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x3E80, 0x3E80, 0x2E82, 0x6D82, 0x4902, 0x6D82, 0x4902, 0x6D82, 0x4902, 0x6D82, 0x3E80, 0x6E01, 0x3E80, 0x6E01, 0x3E80, 0x6E01, 0x3E80, 0x6E01, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6D82, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E01, 0x6E82, 0x6E82, 0x6F02, 0x6F02, 0x6F02, 0x6F02, 0x6F82, 0x6F82, 0x7002, 0x7002, 0x7082, 0x7082, 0x7102, 0x7102, 0x3E80, 0x3E80, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7182, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x7203, 0x6D82, 0x6D82, 0x2E82, 0x7282, 0x2E82, 0x3E80, 0x2E82, 0x4902, 0x6E01, 0x6E01, 0x7301, 0x7301, 0x7383, 0x1A1B, 0x7402, 0x1A1B, 0x1B02, 0x1B82, 0x1C02, 0x1C82, 0x1D02, 0x1D82, 0x1E02, 0x1E82, 0x1F02, 0x1F82, 0x2002, 0x2082, 0x2102, 0x2182, 0x2202, 0x2282, 0x2302, 0x2382, 0x2402, 0x2482, 0x2502, 0x2582, 0x2602, 0x2682, 0x2702, 0x2782, 0x6615, 0xC99, 0x6696, 0xC99, 0x3E80, 0x6D82, 0x6D82, 0x4902, 0x4902, 0x2E82, 0x7582, 0x2E82, 0x4902, 0x6E01, 0x6E01, 0x7601, 0x7601, 0x7681, 0x1A1B, 0x1A1B, 0x1A1B, 0x3E80, 0x3E80, 0x2E82, 0x7282, 0x2E82, 0x3E80, 0x2E82, 0x4902, 0x7701, 0x7701, 0x7781, 0x7781, 0x7383, 0x1A1B, 0x1A1B, 0x3E80, 0x20C, 0x20C, 0x20C, 0x20C, 0x20C, 0x20C, 0x20C, 0x782C, 0x20C, 0x20C, 0x20C, 0x788C, 0x5B10, 0x5B10, 0x7910, 0x7990, 0x2A14, 0x7A34, 0x2A14, 0x2A14, 0x2A14, 0x2A14, 0x298, 0x298, 0x7A9D, 0x7B1E, 0x6615, 0x7A9D, 0x7A9D, 0x7B1E, 0x6615, 0x7A9D, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x298, 0x7B8D, 0x7C0E, 0x7C90, 0x7D10, 0x7D90, 0x7E10, 0x7E90, 0x782C, 0x318, 0x318, 0x318, 0x318, 0x318, 0x298, 0x298, 0x298, 0x298, 0x29DD, 0x2D5E, 0x298, 0x298, 0x298, 0x298, 0x1A97, 0x7F0B, 0x2C8B, 0x2B0B, 0x2B8B, 0x7F8B, 0x800B, 0x808B, 0x810B, 0x818B, 0x820B, 0x519, 0x519, 0xC99, 0x455, 0x4D6, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x4D01, 0x289C, 0x289C, 0x289C, 0x289C, 0x4D01, 0x289C, 0x289C, 0x2902, 0x4D01, 0x4D01, 0x4D01, 0x2902, 0x2902, 0x4D01, 0x4D01, 0x4D01, 0x2902, 0x289C, 0x4D01, 0x289C, 0x289C, 0x289C, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x4D01, 0x289C, 0x289C, 0xA20A, 0xA28A, 0xA30A, 0xA38A, 0xA40A, 0xA48A, 0xA50A, 0xA58A, 0xA60A, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x4606, 0x2A14, 0x4584, 0x4584, 0x4584, 0x4584, 0x4584, 0x289C, 0x289C, 0xA68A, 0xA70A, 0xA78A, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC99, 0xC99, 0x289C, 0x289C, 0xC99, 0x289C, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x948A, 0x950A, 0x958A, 0x960A, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC99, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x4D01, 0x289C, 0x8281, 0x289C, 0x4D01, 0x289C, 0x8301, 0x8381, 0x4D01, 0x4D01, 0x2A9C, 0x2902, 0x4D01, 0x4D01, 0x289C, 0x4D01, 0x2902, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x2902, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x848A, 0x850A, 0x858A, 0x860A, 0x868A, 0x870A, 0x878A, 0x880A, 0x888A, 0x890A, 0x898A, 0x8A0A, 0x8A8A, 0x8B0A, 0x8B8A, 0x8C0A, 0x8C8A, 0x8D0A, 0x8D8A, 0x8E0A, 0x8E8A, 0x8F0A, 0x8F8A, 0x900A, 0x908A, 0x910A, 0x918A, 0x920A, 0x928A, 0x930A, 0x938A, 0x940A, 0xC99, 0xC99, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC99, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC59, 0x519, 0x519, 0xC99, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC59, 0xC99, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC99, 0xC99, 0xC99, 0xC59, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x455, 0x4D6, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C1C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x9C9C, 0x7F0B, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0xC59, 0xC99, 0xC59, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC59, 0xC99, 0xC99, 0xC59, 0xC59, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x39A, 0x39A, 0xC99, 0x1A1B, 0x289C, 0x39A, 0x39A, 0x3E80, 0x289C, 0xC99, 0xC99, 0xC99, 0xC99, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x5B10, 0x5B10, 0x5B10, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x840B, 0x9D0B, 0x9D8B, 0x9E0B, 0x9E8B, 0x9F0B, 0x9F8B, 0xA00B, 0xA08B, 0xA10B, 0x840B, 0x9D0B, 0x9D8B, 0x9E0B, 0x9E8B, 0x9F0B, 0x9F8B, 0xA00B, 0xA08B, 0xA10B, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0xC59, 0xC59, 0xC59, 0xC59, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x501C, 0x289C, 0x289C, 0x289C, 0x289C, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x630B, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x501C, 0x610B, 0x618B, 0x620B, 0x628B, 0xA80B, 0xA88B, 0xA90B, 0xA98B, 0xAA0B, 0x640B, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x289C, 0x3E80, 0x289C, 0x289C, 0x289C, 0x3E80, 0x289C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x2C8B, 0x2B0B, 0x2B8B, 0x7F8B, 0x800B, 0x808B, 0x810B, 0x818B, 0x820B, 0x968B, 0x970B, 0x978B, 0x980B, 0x988B, 0x990B, 0x998B, 0x9A0B, 0x9A8B, 0x9B0B, 0x9B8B, 0x2C8B, 0x2B0B, 0x2B8B, 0x7F8B, 0x800B, 0x808B, 0x810B, 0x818B, 0x820B, 0x968B, 0x970B, 0x978B, 0x980B, 0x988B, 0x990B, 0x998B, 0x9A0B, 0x9A8B, 0x9B0B, 0x9B8B, 0x501C, 0x501C, 0x501C, 0x501C, 0x20C, 0x298, 0x298, 0x298, 0x289C, 0x4584, 0x3A85, 0xA18A, 0x455, 0x4D6, 0x455, 0x4D6, 0x455, 0x4D6, 0x455, 0x4D6, 0x455, 0x4D6, 0x289C, 0x289C, 0x455, 0x4D6, 0x455, 0x4D6, 0x455, 0x4D6, 0x455, 0x4D6, 0x2A14, 0x6615, 0x6696, 0x6696, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x4606, 0x4606, 0x1A1B, 0x1A1B, 0x4584, 0x4584, 0x3E80, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3A85, 0x3E80, 0x501C, 0x501C, 0x630B, 0x630B, 0x630B, 0x630B, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x501C, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAA93, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0xAB12, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x519, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x3E80, 0x5305, 0x5305, 0x5305, 0x5305, 0x5305, 0x3E80, 0x5305, 0x3E80, 0x4606, 0x4606, 0x4606, 0x4606, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x298, 0x2A14, 0x2A14, 0x1A97, 0x1A97, 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x3E80, 0x3E80, 0x3E80, 0x3E80, 0x298, 0x298, 0x298, 0x298, 0x1A97, 0x1A97, 0x1A97, 0x598, 0x298, 0x598, 0x3E80, 0x298, 0x598, 0x298, 0x298, 0x2A14, 0x6615, 0x6696, 0x6615, 0x6696, 0x6615, 0x6696, 0x318, 0x298, 0xD01, 0xD81, 0xE01, 0xE81, 0xF01, 0xF81, 0x1001, 0x1081, 0x1101, 0x1181, 0x1201, 0x1281, 0x1301, 0x1381, 0x1401, 0x1481, 0x1501, 0x1581, 0x1601, 0x1681, 0x1701, 0x1781, 0x1801, 0x1881, 0x1901, 0x1981, 0x6615, 0x298, 0x6696, 0x1A1B, 0x1A97, }; static int16_t Upper[] = { 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0xFFE0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x2E7, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFE0, 0x79, 0x0, 0xFFFF, 0x0, 0xFF18, 0x0, 0xFED4, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x61, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x38, 0x0, 0xFFFF, 0xFFFE, 0xFFB1, 0x0, 0x0, 0x0, 0xFF2E, 0xFF32, 0xFF33, 0xFF36, 0xFF35, 0xFF31, 0xFF2F, 0xFF2D, 0xFF2B, 0xFF2A, 0xFF26, 0xFF27, 0xFF25, 0x0, 0x0, 0x54, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFDA, 0xFFDB, 0xFFE1, 0xFFC0, 0xFFC1, 0xFFC2, 0xFFC7, 0x0, 0xFFD1, 0xFFCA, 0xFFAA, 0xFFB0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFD0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFC5, 0x8, 0x0, 0x4A, 0x56, 0x64, 0x80, 0x70, 0x7E, 0x8, 0x0, 0x9, 0x0, 0x0, 0xE3DB, 0x0, 0x0, 0x7, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0xFFF0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFE6, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, }; static int16_t Lower[] = { 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x20, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x20, 0x0, 0x0, 0x0, 0x1, 0x0, 0xFF39, 0x0, 0xFF87, 0x0, 0xD2, 0xCE, 0xCD, 0x4F, 0xCA, 0xCB, 0xCF, 0x0, 0xD3, 0xD1, 0xD5, 0xD6, 0xDA, 0xD9, 0xDB, 0x0, 0x0, 0x2, 0x1, 0x0, 0x0, 0xFF9F, 0xFFC8, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x26, 0x25, 0x40, 0x3F, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x50, 0x0, 0x0, 0x30, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFF8, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xFFF8, 0x0, 0xFFB6, 0xFFF7, 0x0, 0xFFAA, 0xFF9C, 0x0, 0xFF90, 0xFFF9, 0xFF80, 0xFF82, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0xE2A3, 0xDF41, 0xDFBA, 0x0, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x10, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x1A, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, 0x0, }; static inline int charType(int c) {return Data[Blocks[c>>5]+c & 0xFFFF] & 0x1F;} static inline bool isLowc(int c) {return charType(c) == CHAR_LOWERCASE;} static inline bool isUppc(int c) {return charType(c) == CHAR_UPPERCASE;} static inline bool isLetterOrDigit(int c) { return (1 << charType(c)) & (CHAR_DIGIT | CHAR_LETTER); } static int toUpperCase(int c) { return c + Upper[Data[Blocks[c>>5]+c & 0xFFFF] >> 7]; } static int toLowerCase(int c) { return c + Lower[Data[Blocks[c>>5]+c & 0xFFFF] >> 7]; } // (low? 'any) -> sym | NIL any doLowQ(any x) { x = cdr(x); return isSym(x = EVAL(car(x))) && isLowc(symChar(name(x)))? x : Nil; } // (upp? 'any) -> sym | NIL any doUppQ(any x) { x = cdr(x); return isSym(x = EVAL(car(x))) && isUppc(symChar(name(x)))? x : Nil; } // (lowc 'any) -> any any doLowc(any x) { int c, i; any nm; cell c1, c2; x = cdr(x); if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) return x; Push(c1, x); Push(c2, boxChar(toLowerCase(c), &i, &nm)); while (c = symChar(NULL)) charSym(toLowerCase(c), &i, &nm); drop(c1); return consStr(data(c2)); } // (uppc 'any) -> any any doUppc(any x) { int c, i; any nm; cell c1, c2; x = cdr(x); if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) return x; Push(c1, x); Push(c2, boxChar(toUpperCase(c), &i, &nm)); while (c = symChar(NULL)) charSym(toUpperCase(c), &i, &nm); drop(c1); return consStr(data(c2)); } // (fold 'any ['cnt]) -> sym any doFold(any ex) { int n, c, i; any x, nm; cell c1, c2; x = cdr(ex); if (!isSym(x = EVAL(car(x))) || !(c = symChar(name(x)))) return x; while (!isLetterOrDigit(c)) if (!(c = symChar(NULL))) return Nil; Push(c1, x); n = isCell(x = cddr(ex))? evCnt(ex,x) : 0; Push(c2, boxChar(toLowerCase(c), &i, &nm)); while (c = symChar(NULL)) if (isLetterOrDigit(c)) { if (!--n) break; charSym(toLowerCase(c), &i, &nm); } drop(c1); return consStr(data(c2)); } picolisp-3.1.5.2.orig/src/tab.c0000644000000000000000000002226212265263724014655 0ustar rootroot/* 28aug13abu * (c) Software Lab. Alexander Burger */ #include "pico.h" typedef struct symInit {fun code; char *name;} symInit; static symInit Symbols[] = { {doAbs, "abs"}, {doAccept, "accept"}, {doAdd, "+"}, {doAdr, "adr"}, {doAlarm, "alarm"}, {doAll, "all"}, {doAnd, "and"}, {doAny, "any"}, {doAppend, "append"}, {doApply, "apply"}, {doArg, "arg"}, {doArgs, "args"}, {doArgv, "argv"}, {doArrow, "->"}, {doAs, "as"}, {doAsoq, "asoq"}, {doAssoc, "assoc"}, {doAt, "at"}, {doAtom, "atom"}, {doBind, "bind"}, {doBitAnd, "&"}, {doBitOr, "|"}, {doBitQ, "bit?"}, {doBitXor, "x|"}, {doBool, "bool"}, {doBox, "box"}, {doBoxQ, "box?"}, {doBreak, "!"}, {doBy, "by"}, {doBye, "bye"}, {doBytes, "bytes"}, {doCaaaar, "caaaar"}, {doCaaadr, "caaadr"}, {doCaaar, "caaar"}, {doCaadar, "caadar"}, {doCaaddr, "caaddr"}, {doCaadr, "caadr"}, {doCaar, "caar"}, {doCadaar, "cadaar"}, {doCadadr, "cadadr"}, {doCadar, "cadar"}, {doCaddar, "caddar"}, {doCadddr, "cadddr"}, {doCaddr, "caddr"}, {doCadr, "cadr"}, {doCall, "call"}, {doCar, "car"}, {doCase, "case"}, {doCasq, "casq"}, {doCatch, "catch"}, {doCdaaar, "cdaaar"}, {doCdaadr, "cdaadr"}, {doCdaar, "cdaar"}, {doCdadar, "cdadar"}, {doCdaddr, "cdaddr"}, {doCdadr, "cdadr"}, {doCd, "cd"}, {doCdar, "cdar"}, {doCddaar, "cddaar"}, {doCddadr, "cddadr"}, {doCddar, "cddar"}, {doCdddar, "cdddar"}, {doCddddr, "cddddr"}, {doCdddr, "cdddr"}, {doCddr, "cddr"}, {doCdr, "cdr"}, {doChar, "char"}, {doChain, "chain"}, {doChop, "chop"}, {doCirc, "circ"}, {doCircQ, "circ?"}, {doClip, "clip"}, {doClose, "close"}, {doCmd, "cmd"}, {doCnt, "cnt"}, {doCol, ":"}, {doCommit, "commit"}, {doCon, "con"}, {doConc, "conc"}, {doCond, "cond"}, {doConnect, "connect"}, {doCons, "cons"}, {doCopy, "copy"}, {doCtl, "ctl"}, {doCtty, "ctty"}, {doCut, "cut"}, {doDate, "date"}, {doDbck, "dbck"}, {doDe, "de"}, {doDec, "dec"}, {doDef, "def"}, {doDefault, "default"}, {doDel, "del"}, {doDelete, "delete"}, {doDelq, "delq"}, {doDiff, "diff"}, {doDir, "dir"}, {doDiv, "/"}, {doDm, "dm"}, {doDo, "do"}, {doE, "e"}, {doEcho, "echo"}, {doEnv, "env"}, {doEof, "eof"}, {doEol, "eol"}, {doEq, "=="}, {doEq0, "=0"}, {doEqT, "=T"}, {doEqual, "="}, {doErr, "err"}, {doEval, "eval"}, {doExt, "ext"}, {doExtern, "extern"}, {doExtQ, "ext?"}, {doExtra, "extra"}, {doExtract, "extract"}, {doFifo, "fifo"}, {doFile, "file"}, {doFill, "fill"}, {doFilter, "filter"}, {doFin, "fin"}, {doFinally, "finally"}, {doFind, "find"}, {doFish, "fish"}, {doFlgQ, "flg?"}, {doFlip, "flip"}, {doFlush, "flush"}, {doFold, "fold"}, {doFor, "for"}, {doFork, "fork"}, {doFormat, "format"}, {doFree, "free"}, {doFrom, "from"}, {doFull, "full"}, {doFunQ, "fun?"}, {doGc, "gc"}, {doGe, ">="}, {doGe0, "ge0"}, {doGet, "get"}, {doGetd, "getd"}, {doGetl, "getl"}, {doGlue, "glue"}, {doGt, ">"}, {doGt0, "gt0"}, {doHash, "hash"}, {doHead, "head"}, {doHeap, "heap"}, {doHear, "hear"}, {doHide, "===="}, {doHost, "host"}, {doId, "id"}, {doIdx, "idx"}, {doIf, "if"}, {doIf2, "if2"}, {doIfn, "ifn"}, {doIn, "in"}, {doInc, "inc"}, {doIndex, "index"}, {doInfo, "info"}, {doIntern, "intern"}, {doIpid, "ipid"}, {doIsa, "isa"}, {doJob, "job"}, {doJournal, "journal"}, {doKey, "key"}, {doKill, "kill"}, {doLast, "last"}, {doLe, "<="}, {doLe0, "le0"}, {doLength, "length"}, {doLet, "let"}, {doLetQ, "let?"}, {doLieu, "lieu"}, {doLine, "line"}, {doLines, "lines"}, {doLink, "link"}, {doList, "list"}, {doListen, "listen"}, {doLit, "lit"}, {doLstQ, "lst?"}, {doLoad, "load"}, {doLock, "lock"}, {doLoop, "loop"}, {doLowQ, "low?"}, {doLowc, "lowc"}, {doLt, "<"}, {doLt0, "lt0"}, {doLup, "lup"}, {doMade, "made"}, {doMake, "make"}, {doMap, "map"}, {doMapc, "mapc"}, {doMapcan, "mapcan"}, {doMapcar, "mapcar"}, {doMapcon, "mapcon"}, {doMaplist, "maplist"}, {doMaps, "maps"}, {doMark, "mark"}, {doMatch, "match"}, {doMax, "max"}, {doMaxi, "maxi"}, {doMember, "member"}, {doMemq, "memq"}, {doMeta, "meta"}, {doMethod, "method"}, {doMin, "min"}, {doMini, "mini"}, {doMix, "mix"}, {doMmeq, "mmeq"}, {doMul, "*"}, {doMulDiv, "*/"}, {doName, "name"}, {doNand, "nand"}, {doNEq, "n=="}, {doNEq0, "n0"}, {doNEqT, "nT"}, {doNEqual, "<>"}, {doNeed, "need"}, {doNew, "new"}, {doNext, "next"}, {doNil, "nil"}, {doNond, "nond"}, {doNor, "nor"}, {doNot, "not"}, {doNth, "nth"}, {doNumQ, "num?"}, {doOff, "off"}, {doOffset, "offset"}, {doOn, "on"}, {doOne, "one"}, {doOnOff, "onOff"}, {doOpen, "open"}, {doOpid, "opid"}, {doOpt, "opt"}, {doOr, "or"}, {doOut, "out"}, {doPack, "pack"}, {doPair, "pair"}, {doPass, "pass"}, {doPath, "path"}, {doPatQ, "pat?"}, {doPeek, "peek"}, {doPick, "pick"}, {doPipe, "pipe"}, {doPoll, "poll"}, {doPool, "pool"}, {doPop, "pop"}, {doPort, "port"}, {doPr, "pr"}, {doPreQ, "pre?"}, {doPrin, "prin"}, {doPrinl, "prinl"}, {doPrint, "print"}, {doPrintln, "println"}, {doPrintsp, "printsp"}, {doPrior, "prior"}, {doProg, "prog"}, {doProg1, "prog1"}, {doProg2, "prog2"}, {doProp, "prop"}, {doPropCol, "::"}, {doProtect, "protect"}, {doProve, "prove"}, {doPush, "push"}, {doPush1, "push1"}, {doPut, "put"}, {doPutl, "putl"}, {doPwd, "pwd"}, {doQueue, "queue"}, {doQuit, "quit"}, {doRand, "rand"}, {doRange, "range"}, {doRank, "rank"}, {doRaw, "raw"}, {doRd, "rd"}, {doRead, "read"}, {doRem, "%"}, {doReplace, "replace"}, {doRest, "rest"}, {doReverse, "reverse"}, {doRewind, "rewind"}, {doRollback, "rollback"}, {doRot, "rot"}, {doRun, "run"}, {doSect, "sect"}, {doSeed, "seed"}, {doSeek, "seek"}, {doSemicol, ";"}, {doSend, "send"}, {doSeq, "seq"}, {doSet, "set"}, {doSetCol, "=:"}, {doSetq, "setq"}, {doShift, ">>"}, {doSigio, "sigio"}, {doSize, "size"}, {doSkip, "skip"}, {doSort, "sort"}, {doSpace, "space"}, {doSplit, "split"}, {doSpQ, "sp?"}, {doSqrt, "sqrt"}, {doState, "state"}, {doStem, "stem"}, {doStr, "str"}, {doStrip, "strip"}, {doStrQ, "str?"}, {doSub, "-"}, {doSubQ, "sub?"}, {doSum, "sum"}, {doSuper, "super"}, {doSwap, "swap"}, {doSym, "sym"}, {doSymQ, "sym?"}, {doSync, "sync"}, {doSys, "sys"}, {doT, "t"}, {doTail, "tail"}, {doTell, "tell"}, {doText, "text"}, {doThrow, "throw"}, {doTick, "tick"}, {doTill, "till"}, {doTime, "time"}, {doTouch, "touch"}, {doTrace, "$"}, {doTrim, "trim"}, {doTry, "try"}, {doType, "type"}, {doUdp, "udp"}, {doUnify, "unify"}, {doUnless, "unless"}, {doUntil, "until"}, {doUp, "up"}, {doUppQ, "upp?"}, {doUppc, "uppc"}, {doUse, "use"}, {doUsec, "usec"}, {doVal, "val"}, {doVersion, "version"}, {doWait, "wait"}, {doWhen, "when"}, {doWhile, "while"}, {doWipe, "wipe"}, {doWith, "with"}, {doWr, "wr"}, {doXchg, "xchg"}, {doXor, "xor"}, {doYoke, "yoke"}, {doZap, "zap"}, {doZero, "zero"}, }; static any initSym(any v, char *s) { any x, *h; h = Intern + ihash(x = mkName(s)); x = consSym(v,x); *h = cons(x,*h); return x; } void initSymbols(void) { int i; Nil = symPtr(Avail), Avail = Avail->car->car; // Allocate 2 cells for NIL val(Nil) = tail(Nil) = val(Nil+1) = tail(Nil+1) = Nil; Zero = box(0); One = box(2); for (i = 0; i < IHASH; ++i) Intern[i] = Transient[i] = Nil; for (i = 0; i < EHASH; ++i) Extern[i] = Nil; initSym(mkStr(_OS), "*OS"); DB = initSym(Nil, "*DB"); Meth = initSym(box(num(doMeth)), "meth"); Quote = initSym(box(num(doQuote)), "quote"); T = initSym(Nil, "T"), val(T) = T; // Last protected symbol mkExt(val(DB) = DbVal = consStr(DbTail = box('1'))); Extern['1'] = cons(DbVal, Nil); Solo = initSym(Zero, "*Solo"); PPid = initSym(Nil, "*PPid"); Pid = initSym(boxCnt(getpid()), "*Pid"); At = initSym(Nil, "@"); At2 = initSym(Nil, "@@"); At3 = initSym(Nil, "@@@"); This = initSym(Nil, "This"); Prompt = initSym(Nil, "*Prompt"); Dbg = initSym(Nil, "*Dbg"); Zap = initSym(Nil, "*Zap"); Ext = initSym(Nil, "*Ext"); Scl = initSym(Zero, "*Scl"); Class = initSym(Nil, "*Class"); Run = initSym(Nil, "*Run"); Hup = initSym(Nil, "*Hup"); Sig1 = initSym(Nil, "*Sig1"); Sig2 = initSym(Nil, "*Sig2"); Up = initSym(Nil, "^"); Err = initSym(Nil, "*Err"); Msg = initSym(Nil, "*Msg"); Uni = initSym(Nil, "*Uni"); Led = initSym(Nil, "*Led"); Tsm = initSym(Nil, "*Tsm"); Adr = initSym(Nil, "*Adr"); Fork = initSym(Nil, "*Fork"); Bye = initSym(Nil, "*Bye"); // Last unremovable symbol for (i = 0; i < (int)(sizeof(Symbols)/sizeof(symInit)); ++i) initSym(box(num(Symbols[i].code)), Symbols[i].name); } picolisp-3.1.5.2.orig/src/utf2.c0000644000000000000000000000322212265263724014762 0ustar rootroot/* utf2.c * 31mar05abu * Convert process or file (ISO-8859-15) to stdout (UTF-8, 2-Byte) */ #include #include #include #include #include #include // utf2 [- [ ..]] // utf2 [] int main(int ac, char *av[]) { int c; pid_t pid = 0; FILE *fp = stdin; if (ac > 1) { if (*av[1] == '-') { int pfd[2]; if (pipe(pfd) < 0) { fprintf(stderr, "utf2: Pipe error\n"); return 1; } if ((pid = fork()) == 0) { close(pfd[0]); if (pfd[1] != STDOUT_FILENO) dup2(pfd[1], STDOUT_FILENO), close(pfd[1]); execvp(av[1]+1, av+1); } if (pid < 0) { fprintf(stderr, "utf2: Fork error\n"); return 1; } close(pfd[1]); if (!(fp = fdopen(pfd[0], "r"))) { fprintf(stderr, "utf2: Pipe open error\n"); return 1; } } else if (!(fp = fopen(av[1], "r"))) { fprintf(stderr, "utf2: '%s' open error\n", av[1]); return 1; } } while ((c = getc_unlocked(fp)) != EOF) { if (c == 0xA4) putchar_unlocked(0xE2), putchar_unlocked(0x82), putchar_unlocked(0xAC); else if (c >= 0x80) { putchar_unlocked(0xC0 | c>>6 & 0x1F); putchar_unlocked(0x80 | c & 0x3F); } else putchar_unlocked(c); } if (pid) { fclose(fp); while (waitpid(pid, NULL, 0) < 0) if (errno != EINTR) { fprintf(stderr, "utf2: Pipe close error\n"); return 1; } } return 0; } picolisp-3.1.5.2.orig/src/vers.h0000644000000000000000000000004412265263724015065 0ustar rootrootstatic byte Version[4] = {3,1,5,2}; picolisp-3.1.5.2.orig/src/Makefile0000644000000000000000000000610012265263724015374 0ustar rootroot# 02jun13abu # 27feb08rdo # (c) Software Lab. Alexander Burger bin = ../bin lib = ../lib picoFiles = main.c gc.c apply.c flow.c sym.c subr.c big.c io.c net.c tab.c CFLAGS = -c -O2 -m32 -pipe \ -falign-functions -fomit-frame-pointer -fno-strict-aliasing \ -W -Wimplicit -Wreturn-type -Wunused -Wformat \ -Wuninitialized -Wstrict-prototypes \ -D_GNU_SOURCE -D_FILE_OFFSET_BITS=64 ifeq ($(shell uname), Linux) OS = Linux PICOLISP-FLAGS = -m32 -rdynamic LIB-FLAGS = -lc -lm -ldl DYNAMIC-LIB-FLAGS = -m32 -shared -export-dynamic LCRYPT = -lcrypt STRIP = strip else ifeq ($(shell uname), OpenBSD) OS = OpenBSD PICOLISP-FLAGS = -m32 -rdynamic -Wl,-E LIB-FLAGS = -lc -lm DYNAMIC-LIB-FLAGS = -Wl,-E -Wl,-shared LCRYPT = -lcrypto STRIP = strip else ifeq ($(shell uname), FreeBSD) OS = FreeBSD PICOLISP-FLAGS = -m32 -rdynamic LIB-FLAGS = -lc -lm DYNAMIC-LIB-FLAGS = -m32 -shared -export-dynamic LCRYPT = -lcrypto STRIP = strip else ifeq ($(shell uname), NetBSD) OS = NetBSD PICOLISP-FLAGS = -m32 -rdynamic LIB-FLAGS = -lc -lm DYNAMIC-LIB-FLAGS = -m32 -shared -export-dynamic LCRYPT = -lcrypto STRIP = strip else ifeq ($(shell uname), Darwin) OS = Darwin PICOLISP-FLAGS = -m32 LIB-FLAGS = -lc -lm -ldl DYNAMIC-LIB-FLAGS = -m32 -dynamiclib -undefined dynamic_lookup LCRYPT = -lcrypto STRIP = strip -x else ifeq ($(shell uname -o), Cygwin) OS = Cygwin DYNAMIC-LIB-FLAGS = -shared PICOLISP-FLAGS = DLL-DEFS = $(bin)/picolisp.dll LCRYPT = -lcrypt STRIP = strip exe = .exe dll = .dll endif endif endif endif endif endif picolisp: $(bin)/picolisp $(lib)/ext$(dll) $(lib)/ht$(dll) tools: $(bin)/lat1 $(bin)/utf2 $(bin)/balance gate: $(bin)/ssl $(bin)/httpGate all: picolisp tools gate .c.o: gcc $(CFLAGS) -D_OS='"$(OS)"' $*.c $(picoFiles:.c=.o) ext.o ht.o: pico.h main.o: vers.h ifeq ($(OS), Cygwin) $(bin)/picolisp$(dll): $(picoFiles:.c=.o) gcc -o $(bin)/picolisp$(dll) $(DYNAMIC-LIB-FLAGS) $(picoFiles:.c=.o) $(STRIP) $(bin)/picolisp$(dll) $(bin)/picolisp: $(picoFiles:.c=.o) $(bin)/picolisp$(dll) start.o mkdir -p $(bin) $(lib) gcc -o $(bin)/picolisp$(exe) $(PICOLISP-FLAGS) start.o -L$(bin) -l$(bin)/picolisp $(STRIP) $(bin)/picolisp$(exe) else $(bin)/picolisp: $(picoFiles:.c=.o) mkdir -p $(bin) $(lib) gcc -o $(bin)/picolisp$(exe) $(PICOLISP-FLAGS) $(picoFiles:.c=.o) $(LIB-FLAGS) $(STRIP) $(bin)/picolisp$(exe) endif $(lib)/ext$(dll): ext.o gcc -o $(lib)/ext$(dll) $(DYNAMIC-LIB-FLAGS) ext.o $(DLL-DEFS) $(LCRYPT) $(STRIP) $(lib)/ext$(dll) $(lib)/ht$(dll): ht.o gcc -o $(lib)/ht$(dll) $(DYNAMIC-LIB-FLAGS) ht.o $(DLL-DEFS) $(STRIP) $(lib)/ht$(dll) $(bin)/lat1: lat1.c gcc -o $(bin)/lat1$(exe) lat1.c $(STRIP) $(bin)/lat1$(exe) $(bin)/utf2: utf2.c gcc -o $(bin)/utf2$(exe) utf2.c $(STRIP) $(bin)/utf2$(exe) $(bin)/balance: balance.c gcc -o $(bin)/balance$(exe) balance.c $(STRIP) $(bin)/balance$(exe) $(bin)/ssl: ssl.c gcc -o $(bin)/ssl$(exe) ssl.c -lssl -lcrypto $(STRIP) $(bin)/ssl$(exe) $(bin)/httpGate: httpGate.c gcc -o $(bin)/httpGate$(exe) httpGate.c -lssl -lcrypto $(STRIP) $(bin)/httpGate$(exe) # Clean up clean: rm -f *.o # vi:noet:ts=4:sw=4 picolisp-3.1.5.2.orig/src/apply.c0000644000000000000000000004204512265263724015235 0ustar rootroot/* 03feb11abu * (c) Software Lab. Alexander Burger */ #include "pico.h" any apply(any ex, any foo, bool cf, int n, cell *p) { while (!isNum(foo)) { if (isCell(foo)) { int i; any x = car(foo); struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(x)+2]; } f; f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = 0; f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); while (isCell(x)) { f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); ++f.cnt, x = cdr(x); } if (isNil(x)) x = prog(cdr(foo)); else if (x != At) { f.bnd[f.cnt].sym = x, f.bnd[f.cnt].val = val(x), val(x) = Nil; while (--n >= 0) val(x) = cons(consSym(cf? car(data(p[n+f.cnt-1])) : data(p[n+f.cnt-1]), Nil), val(x)); ++f.cnt; x = prog(cdr(foo)); } else { int cnt = n; int next = Env.next; cell *arg = Env.arg; cell c[Env.next = n]; Env.arg = c; for (i = f.cnt-1; --n >= 0; ++i) Push(c[n], cf? car(data(p[i])) : data(p[i])); x = prog(cdr(foo)); if (cnt) drop(c[cnt-1]); Env.arg = arg, Env.next = next; } while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; return x; } if (val(foo) == val(Meth)) { any expr, o, x; o = cf? car(data(p[0])) : data(p[0]); NeedSym(ex,o); Fetch(ex,o); TheCls = NULL, TheKey = foo; if (expr = method(o)) { int i; any cls = Env.cls, key = Env.key; struct { // bindFrame struct bindFrame *link; int i, cnt; struct {any sym; any val;} bnd[length(x = car(expr))+3]; } f; Env.cls = TheCls, Env.key = TheKey; f.link = Env.bind, Env.bind = (bindFrame*)&f; f.i = 0; f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At); --n, ++p; while (isCell(x)) { f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x)); val(f.bnd[f.cnt].sym) = --n<0? Nil : cf? car(data(p[f.cnt-1])) : data(p[f.cnt-1]); ++f.cnt, x = cdr(x); } if (isNil(x)) { f.bnd[f.cnt].sym = This; f.bnd[f.cnt++].val = val(This); val(This) = o; x = prog(cdr(expr)); } else if (x != At) { f.bnd[f.cnt].sym = x, f.bnd[f.cnt].val = val(x), val(x) = Nil; while (--n >= 0) val(x) = cons(consSym(cf? car(data(p[n+f.cnt-1])) : data(p[n+f.cnt-1]), Nil), val(x)); ++f.cnt; f.bnd[f.cnt].sym = This; f.bnd[f.cnt++].val = val(This); val(This) = o; x = prog(cdr(expr)); } else { int cnt = n; int next = Env.next; cell *arg = Env.arg; cell c[Env.next = n]; Env.arg = c; for (i = f.cnt-1; --n >= 0; ++i) Push(c[n], cf? car(data(p[i])) : data(p[i])); f.bnd[f.cnt].sym = This; f.bnd[f.cnt++].val = val(This); val(This) = o; x = prog(cdr(expr)); if (cnt) drop(c[cnt-1]); Env.arg = arg, Env.next = next; } while (--f.cnt >= 0) val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val; Env.bind = f.link; Env.cls = cls, Env.key = key; return x; } err(ex, o, "Bad object"); } if (isNil(val(foo)) || foo == val(foo)) undefined(foo,ex); foo = val(foo); } if (--n < 0) cdr(ApplyBody) = Nil; else { any x = ApplyArgs; val(caar(x)) = cf? car(data(p[n])) : data(p[n]); while (--n >= 0) { if (!isCell(cdr(x))) cdr(x) = cons(cons(consSym(Nil,Nil), car(x)), Nil); x = cdr(x); val(caar(x)) = cf? car(data(p[n])) : data(p[n]); } cdr(ApplyBody) = car(x); } return evSubr(foo, ApplyBody); } // (apply 'fun 'lst ['any ..]) -> any any doApply(any ex) { any x, y; int i, n; cell foo; x = cdr(ex), Push(foo, EVAL(car(x))); x = cdr(x), y = EVAL(car(x)); { cell c[(n = length(cdr(x))) + length(y)]; while (isCell(y)) Push(c[n], car(y)), y = cdr(y), ++n; for (i = 0; isCell(x = cdr(x)); ++i) Push(c[i], EVAL(car(x))); x = apply(ex, data(foo), NO, n, c); } drop(foo); return x; } // (pass 'fun ['any ..]) -> any any doPass(any ex) { any x; int n, i; cell foo, c[length(cdr(x = cdr(ex))) + (Env.next>0? Env.next : 0)]; Push(foo, EVAL(car(x))); for (n = 0; isCell(x = cdr(x)); ++n) Push(c[n], EVAL(car(x))); for (i = Env.next; --i >= 0; ++n) Push(c[n], data(Env.arg[i])); x = apply(ex, data(foo), NO, n, c); drop(foo); return x; } // (maps 'fun 'sym ['lst ..]) -> any any doMaps(any ex) { any x; int i, n; cell foo, c[length(cdr(x = cdr(ex)))]; Push(foo, EVAL(car(x))); x = cdr(x), Push(c[0], EVAL(car(x))); NeedSym(ex, data(c[0])); for (n = 1; isCell(x = cdr(x)); ++n) Push(c[n], EVAL(car(x))); Fetch(ex, data(c[0])); data(c[0]) = tail1(data(c[0])); while (isCell(data(c[0]))) { x = apply(ex, data(foo), YES, n, c); for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } drop(foo); return x; } // (map 'fun 'lst ..) -> lst any doMap(any ex) { any x = cdr(ex); cell foo; Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { x = apply(ex, data(foo), NO, n, c); for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } drop(foo); return x; } // (mapc 'fun 'lst ..) -> any any doMapc(any ex) { any x = cdr(ex); cell foo; Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { x = apply(ex, data(foo), YES, n, c); for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } drop(foo); return x; } // (maplist 'fun 'lst ..) -> lst any doMaplist(any ex) { any x = cdr(ex); cell res, foo; Push(res, Nil); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); if (!isCell(data(c[0]))) return Pop(res); data(res) = x = cons(apply(ex, data(foo), NO, n, c), Nil); while (isCell(data(c[0]) = cdr(data(c[0])))) { for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); x = cdr(x) = cons(apply(ex, data(foo), NO, n, c), Nil); } } return Pop(res); } // (mapcar 'fun 'lst ..) -> lst any doMapcar(any ex) { any x = cdr(ex); cell res, foo; Push(res, Nil); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); if (!isCell(data(c[0]))) return Pop(res); data(res) = x = cons(apply(ex, data(foo), YES, n, c), Nil); while (isCell(data(c[0]) = cdr(data(c[0])))) { for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); x = cdr(x) = cons(apply(ex, data(foo), YES, n, c), Nil); } } return Pop(res); } // (mapcon 'fun 'lst ..) -> lst any doMapcon(any ex) { any x = cdr(ex); cell res, foo; Push(res, Nil); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); if (!isCell(data(c[0]))) return Pop(res); while (!isCell(x = apply(ex, data(foo), NO, n, c))) { if (!isCell(data(c[0]) = cdr(data(c[0])))) return Pop(res); for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); } data(res) = x; while (isCell(data(c[0]) = cdr(data(c[0])))) { for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); while (isCell(cdr(x))) x = cdr(x); cdr(x) = apply(ex, data(foo), NO, n, c); } } return Pop(res); } // (mapcan 'fun 'lst ..) -> lst any doMapcan(any ex) { any x = cdr(ex); cell res, foo; Push(res, Nil); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); if (!isCell(data(c[0]))) return Pop(res); while (!isCell(x = apply(ex, data(foo), YES, n, c))) { if (!isCell(data(c[0]) = cdr(data(c[0])))) return Pop(res); for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); } data(res) = x; while (isCell(data(c[0]) = cdr(data(c[0])))) { for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); while (isCell(cdr(x))) x = cdr(x); cdr(x) = apply(ex, data(foo), YES, n, c); } } return Pop(res); } // (filter 'fun 'lst ..) -> lst any doFilter(any ex) { any x = cdr(ex); cell res, foo; Push(res, Nil); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); if (!isCell(data(c[0]))) return Pop(res); while (isNil(apply(ex, data(foo), YES, n, c))) { if (!isCell(data(c[0]) = cdr(data(c[0])))) return Pop(res); for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); } data(res) = x = cons(car(data(c[0])), Nil); while (isCell(data(c[0]) = cdr(data(c[0])))) { for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); if (!isNil(apply(ex, data(foo), YES, n, c))) x = cdr(x) = cons(car(data(c[0])), Nil); } } return Pop(res); } // (extract 'fun 'lst ..) -> lst any doExtract(any ex) { any x = cdr(ex); any y; cell res, foo; Push(res, Nil); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); if (!isCell(data(c[0]))) return Pop(res); while (isNil(y = apply(ex, data(foo), YES, n, c))) { if (!isCell(data(c[0]) = cdr(data(c[0])))) return Pop(res); for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); } data(res) = x = cons(y, Nil); while (isCell(data(c[0]) = cdr(data(c[0])))) { for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); if (!isNil(y = apply(ex, data(foo), YES, n, c))) x = cdr(x) = cons(y, Nil); } } return Pop(res); } // (seek 'fun 'lst ..) -> lst any doSeek(any ex) { any x = cdr(ex); cell foo; Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { if (!isNil(apply(ex, data(foo), NO, n, c))) { drop(foo); return data(c[0]); } for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } drop(foo); return Nil; } // (find 'fun 'lst ..) -> any any doFind(any ex) { any x = cdr(ex); cell foo; Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { if (!isNil(apply(ex, data(foo), YES, n, c))) { drop(foo); return car(data(c[0])); } for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } drop(foo); return Nil; } // (pick 'fun 'lst ..) -> any any doPick(any ex) { any x = cdr(ex); cell foo; Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { if (!isNil(x = apply(ex, data(foo), YES, n, c))) { drop(foo); return x; } for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } drop(foo); return Nil; } // (cnt 'fun 'lst ..) -> cnt any doCnt(any ex) { any x = cdr(ex); int res; cell foo; res = 0; Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { if (!isNil(apply(ex, data(foo), YES, n, c))) res += 2; for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } drop(foo); return box(res); } // (sum 'fun 'lst ..) -> num any doSum(any ex) { any x = cdr(ex); cell res, foo, c1; Push(res, box(0)); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { if (isNum(data(c1) = apply(ex, data(foo), YES, n, c))) { Save(c1); if (isNeg(data(res))) { if (isNeg(data(c1))) bigAdd(data(res),data(c1)); else bigSub(data(res),data(c1)); if (!IsZero(data(res))) neg(data(res)); } else if (isNeg(data(c1))) bigSub(data(res),data(c1)); else bigAdd(data(res),data(c1)); drop(c1); } for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } return Pop(res); } // (maxi 'fun 'lst ..) -> any any doMaxi(any ex) { any x = cdr(ex); cell res, val, foo; Push(res, Nil); Push(val, Nil); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) > 0) data(res) = car(data(c[0])), data(val) = x; for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } return Pop(res); } // (mini 'fun 'lst ..) -> any any doMini(any ex) { any x = cdr(ex); cell res, val, foo; Push(res, Nil); Push(val, T); Push(foo, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); while (isCell(data(c[0]))) { if (compare(x = apply(ex, data(foo), YES, n, c), data(val)) < 0) data(res) = car(data(c[0])), data(val) = x; for (i = 0; i < n; ++i) data(c[i]) = cdr(data(c[i])); } } return Pop(res); } static void fish(any ex, any foo, any x, cell *r) { if (!isNil(apply(ex, foo, NO, 1, (cell*)&x))) data(*r) = cons(x, data(*r)); else if (isCell(x)) { if (!isNil(cdr(x))) fish(ex, foo, cdr(x), r); fish(ex, foo, car(x), r); } } // (fish 'fun 'any) -> lst any doFish(any ex) { any x = cdr(ex); cell res, foo, c1; Push(res, Nil); Push(foo, EVAL(car(x))); x = cdr(x), Push(c1, EVAL(car(x))); fish(ex, data(foo), data(c1), &res); return Pop(res); } // (by 'fun1 'fun2 'lst ..) -> lst any doBy(any ex) { any x = cdr(ex); cell res, foo1, foo2; Push(res, Nil); Push(foo1, EVAL(car(x))), x = cdr(x), Push(foo2, EVAL(car(x))); if (isCell(x = cdr(x))) { int i, n = 0; cell c[length(x)]; do Push(c[n], EVAL(car(x))), ++n; while (isCell(x = cdr(x))); if (!isCell(data(c[0]))) return Pop(res); data(res) = x = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); while (isCell(data(c[0]) = cdr(data(c[0])))) { for (i = 1; i < n; ++i) data(c[i]) = cdr(data(c[i])); x = cdr(x) = cons(cons(apply(ex, data(foo1), YES, n, c), car(data(c[0]))), Nil); } data(res) = apply(ex, data(foo2), NO, 1, &res); for (x = data(res); isCell(x); x = cdr(x)) car(x) = cdar(x); } return Pop(res); } picolisp-3.1.5.2.orig/INSTALL0000644000000000000000000001220612265263724014202 0ustar rootroot26apr13abu (c) Software Lab. Alexander Burger PicoLisp Installation ===================== There is no 'configure' procedure, but the PicoLisp file structure is simple enough to get along without it (we hope). It should compile and run on GNU/Linux, FreeBSD, Mac OS X (Darwin), Cygwin/Win32, and possibly other systems without problems. PicoLisp supports two installation strategies: Local and Global. The default (if you just download, unpack and compile the release) is a local installation. It will not interfere in any way with the world outside its directory. There is no need to touch any system locations, and you don't have to be root to install it. Many different versions - or local modifications - of PicoLisp can co-exist on a single machine. For a global installation, allowing system-wide access to the executable and library/documentation files, you can either install it from a ready-made distribution, or set some symbolic links to one of the local installation directories as described below. Note that you are still free to have local installations along with a global installation, and invoke them explicitly as desired. Local Installation ------------------ 1. Unpack the distribution $ tar xfz picoLisp-XXX.tgz 2. Change the directory $ cd picoLisp-XXX 3. Compile the PicoLisp interpreter $ (cd src; make) or - if you have an x86-64 system (under Linux, FreeBSD or SunOS), or a ppc64 system (under Linux) - build the 64-bit version $ (cd src64; make) To use the 64-bit version also on systems which are not natively supported, you can build the emulator $ (cd src64; make emu) Note that the emulator's execution speed is 10 to 20 times slower than the native versions. In all three cases (32-bits, 64-bits, or emulator), the executable bin/picolisp will be created. To build the 64-bit version the first time (bootstrapping), you have the following three options: - If a Java runtime system (version 1.6 or higher) is installed, it will build right out of the box. - Otherwise, download one of the pre-generated "*.s" file packages - http://software-lab.de/x86-64.linux.tgz - http://software-lab.de/x86-64.freeBsd.tgz - http://software-lab.de/x86-64.sunOs.tgz - http://software-lab.de/ppc64.linux.tgz - Else, build a 32-bit version first, and use the resulting bin/picolisp to generate the "*.s" files: $ (cd src; make) $ (cd src64; make x86-64.linux) After that, the 64-bit binary can be used to rebuild itself. Note that on the BSD family of operating systems, 'gmake' must be used instead of 'make'. Global Installation ------------------- The recommended way for a global installation is to use a picolisp package from the OS distribution. If that is not available, you can (as root) create symbolic links from /usr/lib and /usr/bin to a local installation directory: # ln -s / /usr/lib/picolisp # ln -s /usr/lib/picolisp/bin/picolisp /usr/bin # ln -s /usr/lib/picolisp/bin/pil /usr/bin For additional access to the man pages and some examples: # ln -s //man/man1/picolisp.1 /usr/share/man/man1 # ln -s //man/man1/pil.1 /usr/share/man/man1 # ln -s / /usr/share/picolisp Invocation ---------- In a global installation, the 'pil' command should be used. You can either start in plain or in debug mode. The difference is that for debug mode the command is followed by single plus ('+') sign. The '+' must be the very last argument on the command line. $ pil # Plain mode : $ pil + # Debug mode : In both cases, the colon ':' is PicoLisp's prompt. You may enter some Lisp expression, : (+ 1 2 3) -> 6 To exit the interpreter, enter : (bye) or just type Ctrl-D. For a local invocation, specify a path name, e.g. $ ./pil # Plain mode : $ ./pil + # Debug mode : or $ /home/app/pil # Invoking a local installation from some other directory Note that 'pil' can also serve as a template for your own stand-alone scripts. If you just want to test the ready-to-run Ersatz PicoLisp (it needs a Java runtime system), use $ ersatz/pil + : instead of './pil +'. Documentation ------------- For further information, please look at "doc/index.html". There you find the PicoLisp Reference Manual ("doc/ref.html"), the PicoLisp tutorials ("doc/tut.html", "doc/app.html", "doc/select.html" and "doc/native.html"), and the frequently asked questions ("doc/faq.html"). For details about the 64-bit version, refer to "doc64/README", "doc64/asm" and "doc64/structures". As always, the most accurate and complete documentation is the source code ;-) Included in the distribution are many utilities and pet projects, including tests, demo databases and servers, games (chess, minesweeper), and more. Any feedback is welcome! Hope you enjoy :-) -------------------------------------------------------------------------------- Alexander Burger Software Lab. / 7fach GmbH Bahnhofstr. 24a, D-86462 Langweid abu@software-lab.de, http://www.software-lab.de, +49 8230 5060 picolisp-3.1.5.2.orig/README0000644000000000000000000001035412265263724014033 0ustar rootroot08jan13abu (c) Software Lab. Alexander Burger Perfection is attained not when there is nothing left to add but when there is nothing left to take away (Antoine de Saint-Exupery) The PicoLisp System =================== _PI_co Lisp is not _CO_mmon Lisp PicoLisp can be viewed from two different aspects: As a general purpose programming language, and a dedicated application server framework. (1) As a programming language, PicoLisp provides a 1-to-1 mapping of a clean and powerful Lisp derivate, to a simple and efficient virtual machine. It supports persistent objects as a first class data type, resulting in a database system of Entity/Relation classes and a Prolog-like query language tightly integrated into the system. The virtual machine was designed to be Simple The internal data structure should be as simple as possible. Only one single data structure is used to build all higher level constructs. Unlimited There are no limits imposed upon the language due to limitations of the virtual machine architecture. That is, there is no upper bound in symbol name length, number digit counts, or data structure and buffer sizes, except for the total memory size of the host machine. Dynamic Behavior should be as dynamic as possible ("run"-time vs. "compile"-time). All decisions are delayed till runtime where possible. This involves matters like memory management, dynamic symbol binding, and late method binding. Practical PicoLisp is not just a toy of theoretical value. PicoLisp is used since 1988 in actual application development, research and production. The language inherits the major advantages of classical Lisp systems like - Dynamic data types and structures - Formal equivalence of code and data - Functional programming style - An interactive environment PicoLisp is very different from any other Lisp dialect. This is partly due to the above design principles, and partly due to its long development history since 1984. You can download the latest release version at http://software-lab.de/down.html (2) As an application server framework, PicoLisp provides for NoSQL Database Management Index trees Object local indexes Entity/Relation classes Pilog (PicoLisp Prolog) queries Multi-user synchronization DB Garbage collection Journaling, Replication User Interface Browser GUI (X)HTML/CSS XMLHttpRequest/JavaScript Application Server Process management Process family communication XML I/O Import/export User administration Internationalization Security Object linkage Postscript/Printing PicoLisp is not an IDE. All program development in Software Lab. is done using the console, bash, vim and the Lisp interpreter. The only type of GUI supported for applications is through a browser via HTML. This makes the client side completely platform independent. The GUI is created dynamically. Though it uses JavaScript and XMLHttpRequest for speed improvements, it is fully functional also without JavaScript or CSS. The GUI is deeply integrated with - and generated dynamically from - the application's data model. Because the application logic runs on the server, multiple users can view and modify the same database object without conflicts, everyone seeing changes done by other users on her screen immediately due to the internal process and database synchronization. PicoLisp is free software, and you are welcome to use and redistribute it under the conditions of the MIT/X11 License (see "COPYING"). It compiles and runs on current 32-bit GNU/Linux, FreeBSD, Mac OS X (Darwin), Cygwin/Win32 (and possibly other) systems. A native 64-bit version is available for x86-64/Linux, x86-64/FreeBSD, x86-64/SunOS and ppc64/Linux. -------------------------------------------------------------------------------- Alexander Burger Software Lab. / 7fach GmbH Bahnhofstr. 24a, D-86462 Langweid abu@software-lab.de, http://www.software-lab.de, +49 8230 5060 picolisp-3.1.5.2.orig/app/0000755000000000000000000000000012265263724013730 5ustar rootrootpicolisp-3.1.5.2.orig/app/cusu.l0000644000000000000000000000264012265263724015066 0ustar rootroot# 05jan12abu # (c) Software Lab. Alexander Burger (must "Customer/Supplier" Customer) (menu ,"Customer/Supplier" (idForm ,"Customer/Supplier" '(choCuSu) 'nr '+CuSu T '(may Delete) '((: nr) " -- " (: nm)) (
      ) ( (,"Name" ( 3 ,"Number" NIL (gui '(+E/R +NumField) '(nr : home obj) 10) ,"Salutation" (choDlg 0 ,"Salutations" '(nm +Sal)) (gui '(+E/R +Obj +TextField) '(sal : home obj) '(nm +Sal) 20) ,"Name" NIL (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Name" 40) ,"Name 2" NIL (gui '(+E/R +TextField) '(nm2 : home obj) 40) ) ) (,"Address" ( 2 ,"Street" (gui '(+E/R +TextField) '(str : home obj) 40) NIL NIL ,"Zip" (gui '(+E/R +TextField) '(plz : home obj) 10) ,"City" (gui '(+E/R +TextField) '(ort : home obj) 40) ) ) (,"Contact" ( 2 ,"Phone" (gui '(+E/R +TelField) '(tel : home obj) 40) ,"Fax" (gui '(+E/R +TelField) '(fax : home obj) 40) ,"Mobile" (gui '(+E/R +TelField) '(mob : home obj) 40) ,"EMail" (gui '(+E/R +MailField) '(em : home obj) 40) ) ) ((pack (and (: obj txt) "@ ") ,"Memo") (gui '(+BlobField) '(txt : home obj) 60 8) ) ) (
      ) ( NIL (editButton T)) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/er.l0000644000000000000000000001253312265263724014517 0ustar rootroot# 30may13abu # (c) Software Lab. Alexander Burger ### Entity/Relations ### # # nr nm nr nm nm # | | | | | # +-*----*-+ +-*----*-+ +--*-----+ # | | sup | | | | # str --* CuSu O-----------------* Item *-- inv | Role @-- perm # | | | | | | # +-*-*--O-+ +----O---+ +----@---+ # | | | | | usr # nm tel -+ | | | | # | | | | itm | role # +-*-----+ | | +-------+ +---*---+ +----*---+ # | | | | | | ord | | | | # | Sal +---+ +---* Ord @--------* Pos | nm --* User *-- pw # | | cus | | pos | | | | # +-*---*-+ +-*---*-+ +-*---*-+ +--------+ # | | | | | | # hi sex nr dat pr cnt (extend +Role) (dm url> (Tab) (and (may RoleAdmin) (list "app/role.l" '*ID This)) ) (extend +User) (rel nam (+String)) # Full Name (rel tel (+String)) # Phone (rel em (+String)) # EMail (dm url> (Tab) (and (may UserAdmin) (list "app/user.l" '*ID This)) ) # Salutation (class +Sal +Entity) (rel nm (+Key +String)) # Salutation (rel hi (+String)) # Greeting (rel sex (+Any)) # T:male, 0:female (dm url> (Tab) (and (may Customer) (list "app/sal.l" '*ID This)) ) (dm hi> (Nm) (or (text (: hi) Nm) ,"Dear Sir or Madam,") ) # Customer/Supplier (class +CuSu +Entity) (rel nr (+Need +Key +Number)) # Customer/Supplier Number (rel sal (+Link) (+Sal)) # Salutation (rel nm (+Sn +Idx +String)) # Name (rel nm2 (+String)) # Name 2 (rel str (+String)) # Street (rel plz (+Ref +String)) # Zip (rel ort (+IdxFold +String)) # City (rel tel (+Fold +Ref +String)) # Phone (rel fax (+String)) # Fax (rel mob (+Fold +Ref +String)) # Mobile (rel em (+String)) # EMail (rel txt (+Blob)) # Memo (dm url> (Tab) (and (may Customer) (list "app/cusu.l" '*Tab Tab '*ID This)) ) (dm check> () (make (or (: nr) (link ,"No customer number")) (or (: nm) (link ,"No customer name")) (unless (and (: str) (: plz) (: ort)) (link ,"Incomplete customer address") ) ) ) # Item (class +Item +Entity) (rel nr (+Need +Key +Number)) # Item Number (rel nm (+IdxFold +String)) # Item Description (rel sup (+Ref +Link) NIL (+CuSu)) # Supplier (rel inv (+Number)) # Inventory (rel pr (+Ref +Number) NIL 2) # Price (rel txt (+Blob)) # Memo (rel jpg (+Blob)) # Picture (dm url> (Tab) (and (may Item) (list "app/item.l" '*ID This)) ) (dm cnt> () (- (or (: inv) 0) (sum '((This) (: cnt)) (collect 'itm '+Pos This) ) ) ) (dm check> () (make (or (: nr) (link ,"No item number")) (or (: nm) (link ,"No item description")) ) ) # Order (class +Ord +Entity) (rel nr (+Need +Key +Number)) # Order Number (rel dat (+Need +Ref +Date)) # Order date (rel cus (+Ref +Link) NIL (+CuSu)) # Customer (rel pos (+List +Joint) ord (+Pos)) # Positions (dm lose> () (mapc 'lose> (: pos)) (super) ) (dm url> (Tab) (and (may Order) (list "app/ord.l" '*ID This)) ) (dm sum> () (sum 'sum> (: pos)) ) (dm check> () (make (or (: nr) (link ,"No order number")) (or (: dat) (link ,"No order date")) (if (: cus) (chain (check> @)) (link ,"No customer") ) (if (: pos) (chain (mapcan 'check> @)) (link ,"No positions") ) ) ) (class +Pos +Entity) (rel ord (+Dep +Joint) # Order (itm) pos (+Ord) ) (rel itm (+Ref +Link) NIL (+Item)) # Item (rel pr (+Number) 2) # Price (rel cnt (+Number)) # Quantity (dm sum> () (* (: pr) (: cnt)) ) (dm check> () (make (if (: itm) (chain (check> @)) (link ,"Position without item") ) (or (: pr) (link ,"Position without price")) (or (: cnt) (link ,"Position without quantity")) ) ) # Database sizes (dbs (3 +Role +User +Sal (+User pw)) # 512 Prevalent objects (0 +Pos) # A:64 Tiny objects (1 +Item +Ord) # B:128 Small objects (2 +CuSu) # C:256 Normal objects (2 (+Role nm) (+User nm) (+Sal nm)) # D:256 Small indexes (4 (+CuSu nr plz tel mob)) # E:1024 Normal indexes (4 (+CuSu nm)) # F:1024 (4 (+CuSu ort)) # G:1024 (4 (+Item nr sup pr)) # H:1024 (4 (+Item nm)) # I:1024 (4 (+Ord nr dat cus)) # J:1024 (4 (+Pos itm)) ) # K:1024 # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/gui.l0000644000000000000000000002012412265263724014670 0ustar rootroot# 31aug13abu # (c) Software Lab. Alexander Burger ### GUI ### (de menu (Ttl . Prg) (action (html 0 Ttl *Css NIL ( ((180 0 'menu) (
      @ (expires) ( (,"Home" "!work") (,"logout" (and *Login "!stop")) (NIL (
      )) (T ,"Data" (,"Orders" (and (may Order) "app/ord.l")) (,"Items" (and (may Item) "app/item.l")) (,"Customers/Suppliers" (and (may Customer) "app/cusu.l")) (,"Salutations" (and (may Customer) "app/sal.l")) ) (T ,"Report" (,"Inventory" (and (may Report) "app/inventory.l")) (,"Sales" (and (may Report) "app/sales.l")) ) (T ,"System" (,"Role Administration" (and (may RoleAdmin) "app/role.l")) (,"User Administration" (and (may UserAdmin) "app/user.l")) ) ) ) ((NIL NIL 'main) (
      @ (run Prg 1)) ) ) ) ) ) ) (de work () (setq *Url "!work") (and (app) (setq *Menu 3)) (menu "PicoLisp App" (

      NIL "PicoLisp App") ( "@img/7fach.gif" "7fach Logo") (----) (form NIL (gui '(+Init +Map +TextField) (cons *Ctry *Lang) *Locales (mapcar car *Locales) ',"Language" ) (gui '(+Button) ',"Change" '(let V (val> (field -1)) (locale (car V) (cdr V) "app/loc/") ) ) ) (loginForm) ) ) (de stop () (logout) (work) ) # Search dialogs (de choCuSu (Dst) (diaform '(Dst) ( "--.-.-." ,"Number" (gui 'nr '(+Var +NumField) '*CuSuNr 10) ,"Name" (gui 'nm '(+Focus +Var +TextField) '*CuSuNm 30) ,"Phone" (gui 'tel '(+Var +TelField) '*CuSuTel 20) (searchButton '(init> (: home query))) ,"Zip" (gui 'plz '(+Var +TextField) '*CuSuPlz 10) ,"City" (gui 'ort '(+Var +TextField) '*CuSuOrt 30) ,"Mobile" (gui 'mob '(+Var +TelField) '*CuSuMob 20) (resetButton '(nr nm tel plz ort mob query)) ) (gui 'query '(+QueryChart) (cho) '(goal (quote @Nr (and *CuSuNr (cons @ T)) @Nm *CuSuNm @Tel *CuSuTel @Plz *CuSuPlz @Ort *CuSuOrt @Mob *CuSuMob (select (@@) ((nr +CuSu @Nr) (nm +CuSu @Nm) (tel +CuSu @Tel) (plz +CuSu @Plz) (ort +CuSu @Ort) (mob +CuSu @Mob) ) (range @Nr @@ nr) (tolr @Nm @@ nm) (fold @Tel @@ tel) (head @Plz @@ plz) (part @Ort @@ ort) (fold @Mob @@ mob) ) ) ) 9 '((This) (list This (: nr) This (: nm2) (: em) (: plz) (: ort) (: tel) (: mob))) ) (

'chart (choTtl ,"Customers/Suppliers" 'nr '+CuSu) (quote (btn) (align "#") (NIL ,"Name") (NIL) (NIL ,"EMail") (NIL ,"Zip") (NIL ,"City") (NIL ,"Phone") (NIL ,"Mobile") ) (do (cho) ( (alternating) (gui 1 '(+DstButton) Dst) (gui 2 '(+NumField)) (gui 3 '(+ObjView +TextField) '(: nm)) (gui 4 '(+TextField)) (gui 5 '(+MailField)) (gui 6 '(+TextField)) (gui 7 '(+TextField)) (gui 8 '(+TelField)) (gui 9 '(+TelField)) ) ) ) ( (scroll (cho)) (newButton T Dst '(+CuSu) '(nr genKey 'nr '+CuSu) 'nm *CuSuNm 'plz *CuSuPlz 'ort *CuSuOrt 'tel *CuSuTel 'mob *CuSuMob ) (cancelButton) ) ) ) (de choItem (Dst) (diaform '(Dst) ( "--.-." ,"Number" (gui 'nr '(+Focus +Var +NumField) '*ItemNr 10) ,"Supplier" (gui 'sup '(+Var +TextField) '*ItemSup 20) (searchButton '(init> (: home query))) ,"Description" (gui 'nm '(+Var +TextField) '*ItemNm 30) ,"Price" (gui 'pr '(+Var +FixField) '*ItemPr 2 12) (resetButton '(nr nm pr sup query)) ) (gui 'query '(+QueryChart) (cho) '(goal (quote @Nr (and *ItemNr (cons @ T)) @Nm *ItemNm @Pr (and *ItemPr (cons @ T)) @Sup *ItemSup (select (@@) ((nr +Item @Nr) (nm +Item @Nm) (pr +Item @Pr) (nm +CuSu @Sup (sup +Item))) (range @Nr @@ nr) (part @Nm @@ nm) (range @Pr @@ pr) (tolr @Sup @@ sup nm) ) ) ) 6 '((This) (list This (: nr) This (: sup) (: sup ort) (: pr))) ) (
'chart (choTtl ,"Items" 'nr '+Item) (quote (btn) (align "#") (NIL ,"Description") (NIL ,"Supplier") (NIL ,"City") (align ,"Price") ) (do (cho) ( (alternating) (gui 1 '(+DstButton) Dst) (gui 2 '(+NumField)) (gui 3 '(+ObjView +TextField) '(: nm)) (gui 4 '(+ObjView +TextField) '(: nm)) (gui 5 '(+TextField)) (gui 6 '(+FixField) 2) ) ) ) ( (scroll (cho)) (newButton T Dst '(+Item) '(nr genKey 'nr '+Item) 'nm *ItemNm 'pr *ItemPr ) (cancelButton) ) ) ) (de choOrd (Dst) (diaform '(Dst) ( "--.-.-." ,"Number" (gui 'nr '(+Focus +Var +NumField) '*OrdNr 10) ,"Customer" (gui 'cus '(+Var +TextField) '*OrdCus 20) ,"City" (gui 'ort '(+Var +TextField) '*OrdOrt 20) (searchButton '(init> (: home query))) ,"Date" (gui 'dat '(+Var +DateField) '*OrdDat 10) ,"Supplier" (gui 'sup '(+Var +TextField) '*OrdSup 20) ,"Item" (gui 'item '(+Var +TextField) '*OrdItem 20) (resetButton '(nr cus ort dat sup item query)) ) (gui 'query '(+QueryChart) (cho) '(goal (quote @Nr (cons (or *OrdNr T)) @Dat (cons (or *OrdDat T)) @Cus *OrdCus @Ort *OrdOrt @Sup *OrdSup @Item *OrdItem (select (@@) ((nr +Ord @Nr) (dat +Ord @Dat) (nm +CuSu @Cus (cus +Ord)) (ort +CuSu @Ort (cus +Ord)) (nm +Item @Item (itm +Pos) ord) (nm +CuSu @Sup (sup +Item) (itm +Pos) ord) ) (range @Nr @@ nr) (range @Dat @@ dat) (tolr @Cus @@ cus nm) (part @Ort @@ cus ort) (part @Item @@ pos itm nm) (tolr @Sup @@ pos itm sup nm) ) ) ) 9 '((This) (list This (: nr) This (: cus) (: cus ort) (: pos 1 itm sup) (: pos 1 itm) (: pos 2 itm sup) (: pos 2 itm) ) ) ) (
'chart (choTtl ,"Orders" 'nr '+Ord) (quote (btn) (align "#") (NIL ,"Date") (NIL ,"Customer") (NIL ,"City") (NIL ,"Supplier" "(1)") (NIL ,"Item" "(1)") (NIL ,"Supplier" "(2)") (NIL ,"Item" "(2)") ) (do (cho) ( (alternating) (gui 1 '(+DstButton) Dst) (gui 2 '(+NumField)) (gui 3 '(+ObjView +DateField) '(: dat)) (gui 4 '(+ObjView +TextField) '(: nm)) (gui 5 '(+TextField)) (gui 6 '(+ObjView +TextField) '(: nm)) (gui 7 '(+ObjView +TextField) '(: nm)) (gui 8 '(+ObjView +TextField) '(: nm)) (gui 9 '(+ObjView +TextField) '(: nm)) ) ) ) ( (scroll (cho)) (newButton T Dst '(+Ord) '(nr genKey 'nr '+Ord) 'dat (date) ) (cancelButton) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/init.l0000644000000000000000000000576512265263724015065 0ustar rootroot# 21jan13abu # (c) Software Lab. Alexander Burger ### Role ### (obj ((+Role) nm "Administration") perm `*Perms) (obj ((+Role) nm "Accounting") perm (Customer Item Order Report Delete)) (obj ((+Role) nm "Assistance") perm (Order)) (commit) ### User ### (obj ((+User) nm "admin") pw `(passwd "admin") nam "Administrator" role `(db 'nm '+Role "Administration")) (obj ((+User) nm "ben") pw `(passwd "ben") nam "Ben Affleck" role `(db 'nm '+Role "Accounting")) (obj ((+User) nm "jodie") pw `(passwd "jodie") nam "Jodie Foster" role `(db 'nm '+Role "Accounting")) (obj ((+User) nm "sandy") pw `(passwd "sandy") nam "Sandra Bullock" role `(db 'nm '+Role "Accounting")) (obj ((+User) nm "depp") pw `(passwd "depp") nam "Johnny Depp" role `(db 'nm '+Role "Assistance")) (obj ((+User) nm "tom") pw `(passwd "tom") nam "Tom Hanks" role `(db 'nm '+Role "Assistance")) (commit) (obj ((+Sal) nm "Department") hi "Dear Sir or Madam,") (obj ((+Sal) nm "Mr.") hi "Dear Mr. @1," sex T) (obj ((+Sal) nm "Mrs.") hi "Dear Mrs. @1," sex 0) (obj ((+Sal) nm "Ms.") hi "Dear Ms. @1," sex 0) (obj ((+Sal) nm "Mme") hi "Bonjour Mme @1," sex 0) (obj ((+Sal) nm "Herr") hi "Sehr geehrter Herr @1," sex T) (obj ((+Sal) nm "Herr Dr.") hi "Sehr geehrter Herr Dr. @1," sex T) (obj ((+Sal) nm "Frau") hi "Sehr geehrte Frau @1," sex 0) (obj ((+Sal) nm "Frau Dr.") hi "Sehr geehrte Frau Dr. @1," sex 0) (obj ((+Sal) nm "Señor") hi "Estimado Señor @1," sex T) (obj ((+Sal) nm "Señora") hi "Estimada Señora @1," sex 0) (commit) ### Customer/Supplier ### (obj ((+CuSu) nr 1) nm "Active Parts Inc." nm2 "East Division" str "Wildcat Lane" plz "3425" ort "Freetown" tel "37 4967 6846-0" fax "37 4967 68462" mob "37 176 86303" em "info@api.tld" ) (obj ((+CuSu) nr 2) nm "Seven Oaks Ltd." str "Sunny Side Heights 202" plz "1795" ort "Winterburg" tel "37 6295 5855-0" fax "37 6295 58557" em "info@7oaks.tld" ) (obj ((+CuSu) nr 3) sal `(db 'nm '+Sal "Mr.") nm "Miller" nm2 "Thomas Edwin" str "Running Lane 17" plz "1208" ort "Kaufstadt" tel "37 4773 82534" mob "37 129 276877" em "tem@shoppers.tld" ) (commit) ### Item ### (obj ((+Item) nr 1) nm "Main Part" sup `(db 'nr '+CuSu 1) inv 100 pr 29900) (obj ((+Item) nr 2) nm "Spare Part" sup `(db 'nr '+CuSu 2) inv 100 pr 1250) (obj ((+Item) nr 3) nm "Auxiliary Construction" sup `(db 'nr '+CuSu 1) inv 100 pr 15700) (obj ((+Item) nr 4) nm "Enhancement Additive" sup `(db 'nr '+CuSu 2) inv 100 pr 999) (obj ((+Item) nr 5) nm "Metal Fittings" sup `(db 'nr '+CuSu 1) inv 100 pr 7980) (obj ((+Item) nr 6) nm "Gadget Appliance" sup `(db 'nr '+CuSu 2) inv 100 pr 12500) (commit) ### Order ### (let Ord (new (db: +Ord) '(+Ord) 'nr 1 'dat (date 2007 2 14) 'cus (db 'nr '+CuSu 3)) (put> Ord 'pos (list (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 1) 'pr 29900 'cnt 1) (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 2) 'pr 1250 'cnt 8) (new (db: +Pos) '(+Pos) 'itm (db 'nr '+Item 4) 'pr 999 'cnt 20) ) ) ) (commit) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/inventory.l0000644000000000000000000000362212265263724016145 0ustar rootroot# 15sep13abu # (c) Software Lab. Alexander Burger (must "Inventory" Report) (menu ,"Inventory" (

NIL ,"Inventory") (form NIL ( "-.-" ,"Number" NIL (prog (gui '(+Var +NumField) '*InvFrom 10) (prin " - ") (gui '(+Var +NumField) '*InvTill 10) ) ,"Description" NIL (gui '(+Var +TextField) '*InvNm 30) ,"Supplier" (choCuSu 0) (gui '(+Var +Obj +TextField) '*InvSup '(nm +CuSu) 30) ) (--) (gui '(+ShowButton) NIL '(csv ,"Inventory" (

'chart NIL ( (quote (align) (NIL ,"Description") (align ,"Inventory") (NIL ,"Supplier") NIL (NIL ,"Zip") (NIL ,"City") (align ,"Price") ) ) (catch NIL (pilog (quote @Rng (cons *InvFrom (or *InvTill T)) @Nm *InvNm @Sup *InvSup (select (@Item) ((nr +Item @Rng) (nm +Item @Nm) (sup +Item @Sup)) (range @Rng @Item nr) (part @Nm @Item nm) (same @Sup @Item sup) ) ) (with @Item ( (alternating) (<+> (: nr) This) (<+> (: nm) This) (<+> (cnt> This)) (<+> (: sup nm) (: sup)) (<+> (: sup nm2)) (<+> (: sup plz)) (<+> (: sup ort)) (<-> (money (: pr))) ) ) (at (0 . 10000) (or (flush) (throw))) ) ) ) ) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/item.l0000644000000000000000000000257612265263724015055 0ustar rootroot# 05mar13abu # (c) Software Lab. Alexander Burger (must "Item" Item) (menu ,"Item" (idForm ,"Item" '(choItem) 'nr '+Item T '(may Delete) '((: nr) " -- " (: nm)) ( 4 ,"Number" NIL (gui '(+E/R +NumField) '(nr : home obj) 10) NIL ,"Description" NIL (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Item" 30) NIL ,"Supplier" (choCuSu 0) (gui '(+E/R +Obj +TextField) '(sup : home obj) '(nm +CuSu) 30) (gui '(+View +TextField) '(field -1 'obj 'ort) 30) ,"Inventory" NIL (gui '(+E/R +NumField) '(inv : home obj) 12) (gui '(+View +NumField) '(cnt> (: home obj)) 12) ,"Price" NIL (gui '(+E/R +FixField) '(pr : home obj) 2 12) ) (--) ( 2 ,"Memo" (gui '(+BlobField) '(txt : home obj) 60 8) ,"Picture" (prog (gui '(+Able +UpField) '(not (: home obj jpg)) 30) (gui '(+Drop +Button) '(field -1) '(if (: home obj jpg) ,"Uninstall" ,"Install") '(cond ((: home obj jpg) (ask ,"Uninstall Picture?" (put!> (: home top 1 obj) 'jpg NIL) ) ) ((: drop) (blob! (: home obj) 'jpg @)) ) ) ) ) ( NIL (editButton T)) (gui '(+Upd +Img) '(and (: home obj jpg) (allow (blob (: home obj) 'jpg))) ,"Picture" ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/lib.l0000644000000000000000000000345312265263724014660 0ustar rootroot# 09may11abu # (c) Software Lab. Alexander Burger ### PDF-Print ### (dm (ps> . +Ord) () (a4 (pack "Order" (: nr))) (font (12 . "Helvetica")) (eps "@img/7fach.eps" 340 150 75) (window 380 120 120 30 (font (21 . "Times-Roman") (ps ,"Order" 0)) ) (brief NIL 8 "7fach GmbH, Bawaria" (ps) (with (: cus) (ps (pack (and (: sal) (pack (: sal nm) " ")) (: nm2) " " (: nm) ) ) (ps (: str)) (ps (pack (: plz) " " (: ort))) ) ) (window 360 280 240 60 (let Fmt (80 12 60) (table Fmt ,"Customer" ":" (ps (: cus nr))) (table Fmt ,"Order" ":" (ps (: nr))) (table Fmt ,"Date" ":" (ps (datStr (: dat)))) ) ) (down 360) (indent 60 60) (let (Page 1 Fmt (14 6 200 80 80 80)) (width "0.5" (hline 0 470 -8) (font "Helvetica-Bold" (table Fmt NIL NIL (ps ,"Item") (ps ,"Price" T) (ps ,"Quantity" T) (ps ,"Total" T) ) ) (hline 4 470 -8) (pages 720 (hline 0 470 -8) (down 12) (font 9 (ps (text ,"Continued on page @1" (inc 'Page)))) (page T) (eps "@img/7fach.eps" 340 150 75) (down 40) (font 9 (ps (text ,"Page @1" Page))) (down 80) (hline 0 470 -8) ) (for (I . This) (: pos) (down 4) (table Fmt (ps I T) NIL (ps (: itm nm)) (ps (money (: pr)) T) (ps (: cnt) T) (ps (money (sum> This)) T) ) ) (pages) (hline 4 470 -8) (down 4) (table Fmt NIL NIL NIL NIL NIL (ps (money (sum> This)) T)) (hline 4 470 -8) ) ) (page) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/loc/0000755000000000000000000000000012265263724014505 5ustar rootrootpicolisp-3.1.5.2.orig/app/loc/ar0000644000000000000000000000012212265263724015025 0ustar rootroot# 26aug09art # Armadillo T "@app/loc/es" "Mobile" "Celular" picolisp-3.1.5.2.orig/app/loc/ch0000644000000000000000000000010212265263724015013 0ustar rootroot# 10may08abu # (c) Software Lab. Alexander Burger T "app/loc/de" picolisp-3.1.5.2.orig/app/loc/de0000644000000000000000000000344512265263724015026 0ustar rootroot# 09may08abu # (c) Software Lab. Alexander Burger "(@1 Positions)" "(@1 Positionen)" "Address" "Adresse" "Can't print order" "Beleg kann nicht gedruckt werden" "Change" "Ändern" "City" "Ort" "Contact" "Kontakt" "Continued on page @1" "Fortsetzung auf Seite @1" "Country" "Land" "Customer" "Kunde" "Customer/Supplier" "Kunde/Lieferant" "Customers/Suppliers" "Kunden/Lieferanten" "Data" "Daten" "Date" "Datum" "Dear Sir or Madam," "Sehr geehrte Damen und Herren," "Description" "Bezeichnung" "eMail" "eMail" "Fax" "Fax" "Full Name" "Vollständiger Name" "Greeting" "Gruß" "Home" "Startseite" "Incomplete customer address" "Unvollständige Kundenadresse" "Install" "Installieren" "Inventory" "Lagerbestand" "Item" "Artikel" "Items" "Artikel" "Login Name" "Login-Name" "Memo" "Memo" "Mobile" "Mobil" "Name" "Name" "Name 2" "Name 2" "No customer" "Kunde fehlt" "No customer name" "Kundenname fehlt" "No customer number" "Kundennummer fehlt" "No item description" "Artikelbezeichnung fehlt" "No item number" "Artikelnummer fehlt" "No order date" "Belegdatum fehlt" "No order number" "Belegnummer fehlt" "No positions" "Keine Positionen" "Number" "Nummer" "Order" "Bestellung" "Orders" "Bestellungen" "Page @1" "Seite @1" "PDF-Print" "PDF-Druck" "Phone" "Telefon" "Picture" "Bild" "Position without item" "Position ohne Artikel" "Position without price" "Position ohne Preis" "Position without quantity" "Position ohne Menge" "Price" "Preis" "Quantity" "Menge" "Report" "Auswertung" "Role Administration" "Rollenverwaltung" "Sales" "Verkauf" "Salutation" "Anrede" "Salutations" "Anreden" "Sex" "Geschlecht" "Street" "Straße" "Supplier" "Lieferant" "System" "System" "Total" "Gesamt" "Uninstall" "De-installieren" "Uninstall Picture?" "Bild de-installieren?" "User Administration" "Benutzerverwaltung" "Zip" "PLZ" picolisp-3.1.5.2.orig/app/loc/es0000644000000000000000000000362112265263724015041 0ustar rootroot# 20aug09art # Armadillo "(@1 Positions)" "(@1 Posiciones)" "Address" "Dirección" "Can't print order" "No se puede imprimir la órden" "Change" "Cambiar" "City" "Ciudad" "Contact" "Contacto" "Continued on page @1" "Continuado en la página @1" "Country" "País" "Customer" "Cliente" "Customer/Supplier" "Cliente/Proveedor" "Customers/Suppliers" "Clientes/Proveedores" "Data" "Datos" "Date" "Fecha" "Dear Sir or Madam," "Estimado/a Sr/a," "Description" "Descripción" "eMail" "eMail" "Fax" "Fax" "Full Name" "Nombre Completo" "Greeting" "Saludos" "Home" "Inicio" "Incomplete customer address" "Dirección del cliente incompleta" "Install" "Instalar" "Inventory" "Inventario" "Item" "Artículo" "Items" "Artículos" "Login Name" "Nombre de usuario" "Memo" "Memo" "Mobile" "Móbil" "Name" "Nombre" "Name 2" "Segundo nombre" "No customer" "No cliente" "No customer name" "Nombre de cliente indefinido" "No customer number" "Número de cliente indefinido" "No item description" "Descripción de artículo indefinida" "No item number" "Número de artículo no definido" "No order date" "Fecha de órden, indefinida" "No order number" "Número de órden indefinido" "No positions" "Posiciones indefinidas" "Number" "Número" "Order" "Orden" "Orders" "Órdenes" "Page @1" "Página @1" "PDF-Print" "Imprimir-PDF" "Phone" "Teléfono" "Picture" "Foto" "Position without item" "Posición sin artículo" "Position without price" "Posición sin precio" "Position without quantity" "Posición sin cantidad" "Price" "Precio" "Quantity" "Cantidad" "Report" "Reporte" "Role Administration" "Administración de roles" "Sales" "Ventas" "Salutation" "Saludo" "Salutations" "Saludos" "Sex" "Género" "Street" "Calle" "Supplier" "Proveedor" "System" "Sistema" "Total" "Total" "Uninstall" "Desinstalar" "Uninstall Picture?" "Desinstalar foto?" "User Administration" "Administración de usuarios" "Zip" "Código Postal" picolisp-3.1.5.2.orig/app/loc/jp0000644000000000000000000000373412265263724015050 0ustar rootroot# 09may08abu # (c) Software Lab. Alexander Burger "(@1 Positions)" "(ポジション数:@1)" "Address" "住所" "Can't print order" "注文書の印刷ができない" "Change" "変換" "City" "都市" "Contact" "問い合わせ" "Continued on page @1" "@1ページに続く" "Country" "国" "Customer" "カスタマー" "Customer/Supplier" "カスタマー/注文先" "Customers/Suppliers" "カスタマー/注文先" "Data" "データ" "Date" "日付" "Dear Sir or Madam," "拝啓," "Description" "仕様" "eMail" "eメール" "Fax" "Fax" "Full Name" "フルネーム" "Greeting" "手紙の書きだし" "Home" "ホーム" "Incomplete customer address" "カスタマーの住所不十分" "Install" "インストール" "Inventory" "在庫目録" "Item" "商品" "Items" "商品" "Login Name" "ログイン名" "Memo" "メモ" "Mobile" "携帯電話" "Name" "名前" "Name 2" "名前 2" "No customer" "カスタマーなし" "No customer name" "カスタマー名なし" "No customer number" "カスタマー番号なし" "No item description" "商品仕様なし" "No item number" "商品番号なし" "No order date" "注文書日付なし" "No order number" "注文番号なし" "No positions" "ポジションなし" "Number" "番号" "Order" "注文" "Orders" "注文" "Page @1" "@1 ページ" "PDF-Print" "PDF印刷" "Phone" "電話番号" "Picture" "写真" "Position without item" "ポジションに商品がない" "Position without price" "ポジションに価格がない" "Position without quantity" "ポジションに数量がない" "Price" "価格" "Quantity" "数量" "Report" "レポート" "Role Administration" "役割管理" "Sales" "セールス" "Salutation" "敬称" "Salutations" "敬称" "Sex" "性別" "Street" "住所" "Supplier" "注文先" "System" "システム" "Total" "総計" "Uninstall" "アンインストール" "Uninstall Picture?" "写真をアンインストールしますか?" "User Administration" "ユーザー管理" "Zip" "郵便番号" picolisp-3.1.5.2.orig/app/loc/no0000644000000000000000000000346312265263724015052 0ustar rootroot# 14jan10jk # Jon Kleiser, jon.kleiser@usit.uio.no "(@1 Positions)" "(@1 Posisjoner)" "Address" "Adresse" "Can't print order" "Kan ikke skrive ut bestilling" "Change" "Endre" "City" "By" "Contact" "Kontakt" "Continued on page @1" "Fortsettes på side @1" "Country" "Land" "Customer" "Kunde" "Customer/Supplier" "Kunde/Leverandør" "Customers/Suppliers" "Kunder/Leverandører" "Data" "Data" "Date" "Dato" "Dear Sir or Madam," "Kjære frue/herre," "Description" "Beskrivelse" "eMail" "e-post" "Fax" "Fax" "Full Name" "Fullt navn" "Greeting" "Hilsen" "Home" "Startside" "Incomplete customer address" "Ufullstendig kundeadresse" "Install" "Installer" "Inventory" "Lagerbeholdning" "Item" "Artikkel" "Items" "Artikler" "Login Name" "Innloggingsnavn" "Memo" "Merknad" "Mobile" "Mobil" "Name" "Navn" "Name 2" "Navn 2" "No customer" "Kunde mangler" "No customer name" "Kundenavn mangler" "No customer number" "Kundenummer mangler" "No item description" "Artikkelbeskrivelse mangler" "No item number" "Artikkelnummer mangler" "No order date" "Bestillingsdato mangler" "No order number" "Bestillingsnummer mangler" "No positions" "Ingen posisjoner" "Number" "Nummer" "Order" "Bestilling" "Orders" "Bestillinger" "Page @1" "Side @1" "PDF-Print" "PDF-utskrift" "Phone" "Telefon" "Picture" "Bilde" "Position without item" "Posisjon uten artikkel" "Position without price" "Posisjon uten pris" "Position without quantity" "Posisjon uten antall" "Price" "Pris" "Quantity" "Antall" "Report" "Rapport" "Role Administration" "Rolle-administrasjon" "Sales" "Salg" "Salutation" "Titulering" "Salutations" "Tituleringer" "Sex" "Kjønn" "Street" "Gate" "Supplier" "Leverandør" "System" "System" "Total" "Total" "Uninstall" "Av-installer" "Uninstall Picture?" "Av-installere bilde?" "User Administration" "Bruker-administrasjon" "Zip" "Postnr." picolisp-3.1.5.2.orig/app/loc/ru0000644000000000000000000000461112265263724015060 0ustar rootroot# 25apr08 # Mansur Mamkin "(@1 Positions)" "(@1 позиций)" "Address" "Адрес" "Can't print order" "Невозможно напечатать заказ" "Change" "Изменить" "City" "Город" "Contact" "Контакт" "Continued on page @1" "Продолжение на странице @1" "Country" "Страна" "Customer" "Покупатель" "Customer/Supplier" "Покупатель/Поставщик" "Customers/Suppliers" "Покупатели/Поставщики" "Data" "Данные" "Date" "Дата" "Dear Sir or Madam," "Уважаемый(ая)" "Description" "Описание" "eMail" "емейл" "Fax" "Факс" "Full Name" "Полное имя" "Greeting" "Приветствие" "Home" "Домой" "Incomplete customer address" "Неполный адрес покупателя" "Install" "Установить" "Inventory" "Инвентаризация" "Item" "Товар" "Items" "Товары" "Login Name" "Имя регистрации" "Memo" "Мемо" "Mobile" "Мобильный" "Name" "Имя" "Name 2" "Имя 2" "No customer" "Нет покупателя" "No customer name" "Нет имени покупателя" "No customer number" "Нет номера покупателя" "No item description" "Нет описания товара" "No item number" "Нет номера товара" "No order date" "Нет даты заказа" "No order number" "Нет номера заказа" "No positions" "Нет позиций" "Number" "Номер" "Order" "Заказ" "Orders" "Заказы" "Page @1" "Страница @1" "PDF-Print" "Печать PDF" "Phone" "Телефон" "Picture" "Картинка" "Position without item" "Позиция без товара" "Position without price" "Позиция без цены" "Position without quantity" "Позиция без количества" "Price" "Цена" "Quantity" "Количество" "Report" "Отчет" "Role Administration" "Управление ролями" "Sales" "Продажи" "Salutation" "Приветствие" "Salutations" "Приветствия" "Sex" "Пол" "Street" "Улица" "Supplier" "Поставщик" "System" "Система" "Total" "Всего" "Uninstall" "Удалить" "Uninstall Picture?" "Удалить картинку?" "User Administration" "Управление пользователями" "Zip" "Индекс" picolisp-3.1.5.2.orig/app/main.l0000644000000000000000000000266112265263724015036 0ustar rootroot# 31aug13abu # (c) Software Lab. Alexander Burger (allowed ("app/") "!work" "!stop" "@lib.css" "!psh" ) (scl 2) (load "@lib/http.l" "@lib/xhtml.l" "@lib/form.l" "@lib/ps.l" "@lib/adm.l" "@lib/boss.l" ) (setq *Css "@lib.css" *Blob "blob/app/" *Salt (16 . "$6$@1$") ) (load "app/er.l" "app/lib.l" "app/gui.l") (permission Customer ,"Customer" Item ,"Item" Order ,"Order" Report ,"Report" RoleAdmin ,"Role Administration" UserAdmin ,"User Administration" Password ,"Password" Delete ,"Delete" ) (de *Locales ("English" NIL) ("English (US)" "US") ("English (UK)" "UK") ("Español (AR)" "AR" . "ar") ("Español (ES)" "ES" . "es") ("Deutsch (DE)" "DE" . "de") ("Deutsch (CH)" "CH" . "ch") ("Norsk" "NO" . "no") ("Русский" "RU" . "ru") ("日本語" "JP" . "jp") ) # Entry point (de main () (call 'mkdir "-p" "db/app/" *Blob) (pool "db/app/" *Dbs) (unless (seq *DB) (load "app/init.l") ) ) (de go () (pw 12) (task (port 4040) # Set up query server in the background (let? Sock (accept @) (unless (fork) # Child process (in Sock (while (rd) (sync) (tell) (out Sock (pr (eval @)) ) ) ) (bye) ) (close Sock) ) ) (forked) (rollback) (server 8080 "!work") ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/ord.l0000644000000000000000000000354012265263724014673 0ustar rootroot# 17jul13abu # (c) Software Lab. Alexander Burger (must "Order" Order) (menu ,"Order" (idForm ,"Order" '(choOrd) 'nr '+Ord T '(may Delete) '((: nr)) ( 4 ,"Date" NIL (gui '(+E/R +DateField) '(dat : home obj) 10) (gui '(+View +TextField) '(text ,"(@1 Positions)" (length (: home obj pos))) ) ,"Customer" (choCuSu 0) (gui '(+E/R +Obj +TextField) '(cus : home obj) '(nm +CuSu) 30) (gui '(+View +TextField) '(field -1 'obj 'ort) 30) ) (--) (gui '(+Set +E/R +Chart) '((L) (filter bool L)) '(pos : home obj) 8 '((Pos I) (with Pos (list I NIL (: itm) (or (: pr) (: itm pr)) (: cnt) (sum> Pos)) ) ) '((L D) (cond (D (put!> D 'itm (caddr L)) (put!> D 'pr (cadddr L)) (put!> D 'cnt (; L 5)) (and (; D itm) D) ) ((caddr L) (new! '(+Pos) 'itm (caddr L)) ) ) ) ) (
NIL NIL '(("align em2") (btn) (NIL ,"Item") (NIL ,"Price") (NIL ,"Quantity") (NIL ,"Total")) (do 8 ( NIL (gui 1 '(+NumField)) (choItem 2) (gui 3 '(+Obj +TextField) '(nm +Item) 30) (gui 4 '(+FixField) 2 12) (gui 5 '(+NumField) 8) (gui 6 '(+Sgn +Lock +FixField) 2 12) (gui 7 '(+DelRowButton)) (gui 8 '(+BubbleButton)) ) ) ( NIL NIL NIL (scroll 8 T) NIL NIL (gui '(+Sgn +View +FixField) '(sum> (: home obj)) 2 12) ) ) ( (gui '(+Rid +Button) ,"PDF-Print" '(if (check> (: home obj)) (note ,"Can't print order" (uniq @)) (psOut 0 ,"Order" (ps> (: home obj))) ) ) (editButton T) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/role.l0000644000000000000000000000163112265263724015047 0ustar rootroot# 05jan12abu # (c) Software Lab. Alexander Burger (must "Role Administration" RoleAdmin) (menu ,"Role Administration" (idForm ,"Role" ,"Roles" 'nm '+Role T '(may Delete) '((: nm)) (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Role" 30 ,"Name") (
NIL NIL NIL (gui '(+E/R +Fmt +Chart) '(perm : home obj) '((Val) (mapcar '((S) (list S (memq S Val))) *Perms)) '((Lst) (extract '((L P) (and (cadr L) P)) Lst *Perms)) 2 ) (do (length *Perms) ( NIL (gui 1 '(+Set +TextField) '((Sym) (val (val Sym)))) (gui 2 '(+Checkbox)) ) ) ) (gui '(+/R +Chart) '(usr : home obj) 1 list) (
'chart ,"User" NIL (do 8 ( (alternating) (gui 1 '(+Obj +TextField) '(nm +User)) ) ) ) ( (scroll 8 T) (editButton T)) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/sal.l0000644000000000000000000000072112265263724014664 0ustar rootroot# 05jan12abu # (c) Software Lab. Alexander Burger (must "Salutation" Customer) (menu ,"Salutation" (idForm ,"Salutation" ,"Salutations" 'nm '+Sal T '(may Delete) '((: nm)) ( 2 ,"Salutation" (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"Salutation" 40) ,"Greeting" (gui '(+E/R +TextField) '(hi : home obj) 40) ,"Sex" (gui '(+E/R +SexField) '(sex : home obj)) ) ( NIL (editButton T)) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/sales.l0000644000000000000000000000373312265263724015222 0ustar rootroot# 05jan12abu # (c) Software Lab. Alexander Burger (must "Sales" Report) (menu ,"Sales" (

NIL ,"Sales") (form NIL ( "-.-" ,"Date" NIL (prog (gui '(+Var +DateField) '*SalFrom 10) (prin " - ") (gui '(+Var +DateField) '*SalTill 10) ) ,"Customer" (choCuSu 0) (gui '(+Var +Obj +TextField) '*SalCus '(nm +CuSu) 30) ) (--) (gui '(+ShowButton) NIL '(csv ,"Sales" (

'chart NIL ( (quote (align) (NIL ,"Date") (NIL ,"Customer") NIL (NIL ,"Zip") (NIL ,"City") (align ,"Total") ) ) (catch NIL (let Sum 0 (pilog (quote @Rng (cons *SalFrom (or *SalTill T)) @Cus *SalCus (select (@Ord) ((dat +Ord @Rng) (cus +Ord @Cus)) (range @Rng @Ord dat) (same @Cus @Ord cus) ) ) (with @Ord (let N (sum> This) ( (alternating) (<+> (: nr) This) (<+> (datStr (: dat)) This) (<+> (: cus nm) (: cus)) (<+> (: cus nm2)) (<+> (: cus plz)) (<+> (: cus ort)) (<-> (money N)) ) (inc 'Sum N) ) ) (at (0 . 10000) (or (flush) (throw))) ) ( 'nil ( ,"Total") - - - - - ( (prin (money Sum))) ) ) ) ) ) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/app/user.l0000644000000000000000000000201612265263724015062 0ustar rootroot# 30may13abu # (c) Software Lab. Alexander Burger (must "User Administration" UserAdmin) (menu ,"User Administration" (idForm ,"User" ,"Users" 'nm '+User T '(may Delete) '((: nm)) ( 2 ,"Login Name" (gui '(+E/R +Cue +TextField) '(nm : home obj) ,"User" 30) ,"Password" (gui '(+Able +E/R +Fmt +TextField) '(or (may Password) (== *Login (: home obj))) '(pw : home obj) '((V) (and V "****")) '((V) (if (= V "****") (: home obj pw 0) (passwd V (: home obj pw 0)) ) ) 30 ) ,"Role" (gui '(+Able +E/R +Obj +TextField) '(may RoleAdmin) '(role : home obj) '(nm +Role) T ) ,"Full Name" (gui '(+E/R +TextField) '(nam : home obj) 40) ,"Phone" (gui '(+E/R +TelField) '(tel : home obj) 40) ,"EMail" (gui '(+E/R +MailField) '(em : home obj) 40) ) ( NIL (editButton T)) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/doc64/0000755000000000000000000000000012265263724014067 5ustar rootrootpicolisp-3.1.5.2.orig/doc64/README0000644000000000000000000001415412265263724014754 0ustar rootroot08jan13abu (c) Software Lab. Alexander Burger 64-bit PicoLisp =============== The 64-bit version of PicoLisp is a complete rewrite of the 32-bit version. While the 32-bit version was written in C, the 64-bit version is implemented in a generic assembler, which in turn is written in PicoLisp. In most respects, the two versions are compatible (see "Differences" below). Building the Kernel ------------------- No C-compiler is needed to build the interpreter kernel, only a 64-bit version of the GNU assembler for the target architecture. The kernel sources are the "*.l" files in the "src64/" directory. The PicoLisp assembler parses them and generates a few "*.s" files, which the GNU assembler accepts to build the executable binary file. See the details for bootstrapping the "*.s" files in INSTALL. The generic assembler is in "src64/lib/asm.l". It is driven by the script "src64/mkAsm" which is called by "src64/Makefile". The CPU registers and instruction set of the PicoLisp processor are described in "doc64/asm", and the internal data structures of the PicoLisp machine in "doc64/structures". Currently, x86-64/Linux, x86-64/FreeBSD, x86-64/SunOS and ppc64/Linux are supported. The platform dependent files are in the "src64/arch/" for the target architecture, and in "src64/sys/" for the target operating system. In addition, an emulator which "assembles" to C code can be built. It is much slower than the native code, but otherwise completely compatible. Reasons for the Use of Assembly Language ---------------------------------------- Contrary to the common expectation: Runtime execution speed was not a primary design decision factor. In general, pure code efficiency has not much influence on the overall execution speed of an application program, as memory bandwidth (and later I/O bandwidth) is the main bottleneck. The reasons to choose assembly language (instead of C) were, in decreasing order of importance: 1. Stack manipulations Alignment to cell boundaries: To be able to directly express the desired stack data structures (see "doc64/structures", e.g. "Apply frame"), a better control over the stack (as compared to C) was required. Indefinite pushs and pops: A Lisp interpreter operates on list structures of unknown length all the time. The C version always required two passes, the first to determine the length of the list to allocate the necessary stack structures, and then the second to do the actual work. An assembly version can simply push as many items as are encountered, and clean up the stack with pop's and stack pointer arithmetics. 2. Alignments and memory layout control Similar to the stack structures, there are also heap data structures that can be directly expressed in assembly declarations (built at assembly time), while a C implementation has to defer that to runtime. Built-in functions (SUBRs) need to be aligned to to a multiple of 16+2, reflecting the data type tag requirements, and thus allow direct jumps to the SUBR code without further pointer arithmetic and masking, as is necessary in the C version. 3. Multi-precision arithmetics (Carry-Flag) The bignum functions demand an extensive use of CPU flags. Overflow and carry/borrow have to emulated in C with awkward comparisons of signed numbers. 4. Register allocation A manual assembly implementation can probably handle register allocation more flexibly, with minimal context saves and reduced stack space, and multiple values can be returned from functions in registers. As mentioned above, this has no measurable effect on execution speed, but the binary's overall size is significantly reduced. 5. Return status register flags from functions Functions can return condition codes directly. The callee does not need to re-check returned values. Again, this has only a negligible impact on performance. 6. Multiple function entry points Some things can be handled more flexibly, and existing code may be easier to re-use. This is on the same level as wild jumps within functions ('goto's), but acceptable in the context of an often-used but rarely modified program like a Lisp kernel. It would indeed be feasible to write only certain parts of the system in assembly, and the rest in C. But this would be rather unsatisfactory. And it gives a nice feeling to be independent of a heavy-weight C compiler. Differences to the 32-bit Version --------------------------------- Except for the following seven cases, the 64-bit version should be upward compatible to the 32-bit version. 1. Internal format and printed representation of external symbols This is probably the most significant change. External (i.e. database) symbols are coded more efficiently internally (occupying only a single cell), and have a slightly different printed representation. Existing databases need to be converted. 2. Short numbers are pointer-equal As there is now an internal "short number" type, an expression like (== 64 64) will evaluate to 'T' on a 64-bit system, but to 'NIL' on a 32-bit system. 3. Bit manipulation functions may differ for negative arguments Numbers are represented internally in a different format. Bit manipulations are not really defined for negative numbers, but (& -15 -6) will give -6 on 32 bits, and 6 on 64 bits. 4. 'do' takes only a 'cnt' argument (not a bignum) For the sake of simplicity, a short number (60 bits) is considered to be enough for counted loops. 5. Calling native functions is different. Direct calls using the 'lib:fun' notation is still possible (see the 'ext' and 'ht' libraries), but the corresponding functions must of course be coded in assembly and not in C. To call C functions, the new 'native' function should be used, which can interface to native C functions directly, without the need of glue code to convert arguments and return values. 6. New features were added, like coroutines or namespaces. 7. Bugs (in the implementation, or in this list ;-) picolisp-3.1.5.2.orig/doc64/asm0000644000000000000000000002042512265263724014575 0ustar rootroot# 05jan13abu # (c) Software Lab. Alexander Burger CPU Registers: +---+---+---+---+---+---+---+---+ | A | B | \ [A]ccumulator +---+---+---+---+---+---+---+---+ D [B]yte register | C | / [C]ount register +---+---+---+---+---+---+---+---+ [D]ouble register | E | [E]xpression register +---+---+---+---+---+---+---+---+ +---+---+---+---+---+---+---+---+ | X | [X] Index register +---+---+---+---+---+---+---+---+ [Y] Index register | Y | [Z] Index register +---+---+---+---+---+---+---+---+ | Z | +---+---+---+---+---+---+---+---+ +---+---+---+---+---+---+---+---+ | L | [L]ink register +---+---+---+---+---+---+---+---+ [S]tack pointer | S | +---+---+---+---+---+---+---+---+ +-------------------------------+ | [z]ero [s]ign [c]arry | [F]lags +-------------------------------+ ======================================================================== Source Addressing Modes: ld A 1234 # Immediate ld A "(a+b-c)" ld A R # Register ld A Global # Direct ld A (R) # Indexed ld A (R 8) # Indexed with offset ld A (R OFFS) ld A (R Global) ld A (Global) # Indirect ld A (Global OFFS) # Indirect with offset ld A ((R)) # Indexed indirect ld A ((R 8)) # Indexed with offset indirect ld A ((R 8) OFFS) ld A ((R Global) OFFS) ld A ((R OFFS) Global) ... Destination Addressing Modes: ld R A # Register ld (R) A # Indexed ld (R 8) A # Indexed with offset ld (R OFFS) A ld (R Global) A ld (Global) A # Indirect ld (Global OFFS) A # Indirect with offset ld ((R)) A # Indexed indirect ld ((R 8)) A # Indexed with offset indirect ld ((R 8) OFFS) A ld ((R Global) OFFS) A ld ((R OFFS) Global) A ... Target Addressing Modes: jmp 1234 # Absolute jmp Label jmp (R) # Indexed jmp (R T) # Indexed SUBR jmp (Global) # Indirect ======================================================================== Instruction set: nop # No operation Move Instructions: ld dst src # Load 'dst' from 'src' [---] ld2 src # Load 'A' from two bytes 'src' (unsigned) [---] ld4 src # Load 'A' from four bytes 'src' (unsigned) [---] ldc reg src # Load if Carry 'reg' from 'src' [---] ldnc reg src # Load if not Carry 'reg' from 'src' [---] ldz reg src # Load if Zero 'reg' from 'src' [---] ldnz reg src # Load if not Zero 'reg' from 'src' [---] lea dst src # Load 'dst' with effective address of 'src' [---] st2 dst # Store two bytes from 'A' into 'dst' [---] st4 dst # Store four bytes from 'A' into 'dst' [---] xchg dst dst # Exchange 'dst's [---] movn dst src cnt # Move 'cnt' bytes from 'src' to 'dst' (non-overlapping) mset dst cnt # Set 'cnt' bytes of memory to B movm dst src end # Move memory 'src'..'end' to 'dst' (aligned) save src end dst # Save 'src'..'end' to 'dst' (aligned, non-overlapping) load dst end src # Load 'dst'..'end' from 'src' (aligned, non-overlapping) Arithmetics: add dst src # Add 'src' to 'dst' [zsc] addc dst src # Add 'src' to 'dst' with Carry [zsc] sub dst src # Subtract 'src' from 'dst' [zsc] subc dst src # Subtract 'src' from 'dst' with Carry [zsc] inc dst # Increment 'dst' [zs.] dec dst # Increment 'dst' [zs.] not dst # One's complement negation of 'dst' [z..] neg dst # Two's complement negation of 'dst' [zs.] and dst src # Bitwise AND 'dst' with 'src' [zs.] or dst src # Bitwise OR 'dst' with 'src' [zs.] xor dst src # Bitwise XOR 'dst' with 'src' [zs.] off dst src # Clear 'src' bits in 'dst' [zs.] test dst src # Bit-test 'dst' with 'src' [zs.] shl dst src # Shift 'dst' left into Carry by 'src' bits [zsc] shr dst src # Shift 'dst' right into Carry by 'src' bits [zsc] rol dst src # Rotate 'dst' left by 'src' bits [...] ror dst src # Rotate 'dst' right by 'src' bits [...] rcl dst src # Rotate 'dst' with Carry left by 'src' bits [zsc] rcr dst src # Rotate 'dst' with Carry right by 'src' bits [zsc] mul src # Multiplication of 'A' and 'src' into 'D' [...] div src # Division of 'D' by 'src' into 'A', 'C' [...] zxt # Zero-extend 'B' to 'A' [...] setz # Set Zero flag [z__] clrz # Clear Zero flag [z..] setc # Set Carry flag [--c] clrc # Clear Carry flag [--c] Comparisons: cmp dst src # Compare 'dst' with 'src' [zsc] cmpn dst src cnt # Compare 'cnt' bytes 'dst' with 'src' [z..] slen dst src # Set 'dst' to the string length of 'src' [...] memb src cnt # Find B in 'cnt' bytes of 'src' memory [z..] null src # Compare 'src' with 0 [zs_] nulp src # Check 'src' for null-pointer [z..] nul4 # Compare four bytes in 'A' with 0 [zs_] Byte addressing: set dst src # Set 'dst' byte to 'src' [---] nul src # Compare byte 'src' with 0 [zs_] Types: cnt src # Non-'z' if small number [z..] big src # Non-'z' if bignum [z..] num src # Non-'z' if number [z..] sym src # Non-'z' if symbol [z..] atom src # Non-'z' if atom [z..] Flow Control: jmp adr # Jump to 'adr' [---] jz adr # Jump to 'adr' if Zero [---] jnz adr # Jump to 'adr' if not Zero [---] js adr # Jump to 'adr' if Sign [---] jns adr # Jump to 'adr' if not Sign [---] jc adr # Jump to 'adr' if Carry [---] jnc adr # Jump to 'adr' if not Carry [---] call adr # Call 'adr' cc adr(src ..) # C-Call to 'adr' with 'src' arguments cc adr reg # C-Call to 'adr' with top of stacked args in 'reg' ldd # Load double value pointed to by 'C' ldf # Load float value pointed to by 'C' fixnum # Convert double with scale 'E' to fixnum in 'E' float # Convert fixnum with scale 'A' pointed to by 'X' std # Store double value at address 'Z' stf # Store float value at address 'Z' ret # Return [---] func # Convert 'E' to function pointer begin # Called from foreign function return # Return to foreign function Stack Manipulations: push src # Push 'src' [---] pop dst # Pop 'dst' [---] link # Setup frame [---] tuck src # Extend frame [---] drop # Drop frame [---] Evaluation: eval # Evaluate expression in 'E' eval+ # Evaluate expression in partial stack frame eval/ret # Evaluate expression and return exec reg # Execute lists in 'reg', ignore results prog reg # Evaluate expressions in 'reg', return last result System: initData # Init runtime data initCode # Init runtime code initMain # Command in X, arguments in Y, last pointer in Z initLib # Library function pointer in A ======================================================================== Naming conventions: Lisp level functions, which would be all of the form 'doXyzE_E', are written as 'doXyz' for brevity. picolisp-3.1.5.2.orig/doc64/structures0000644000000000000000000002203412265263724016236 0ustar rootroot# 11jun13abu # (c) Software Lab. Alexander Burger ### Primary data types ### cnt xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxS010 big xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxS100 sym xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx1000 pair xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx0000 Bignum | V +-----+-----+ | DIG | | | +-----+--+--+ | V +-----+-----+ | DIG | | | +-----+--+--+ | V +-----+-----+ | DIG | CNT | +-----+-----+ Pair | V +-----+-----+ | CAR | CDR | +-----+-----+ Symbol | V +-----+-----+ +-----+-----+ | | | VAL | |'cba'|'fed'| +--+--+-----+ +-----+-----+ | tail ^ | | V | name +-----+-----+ +-----+-----+ +-----+--+--+ | | | ---+---> | KEY | ---+---> | | | | | +--+--+-----+ +-----+-----+ +--+--+-----+ | | V V +-----+-----+ +-----+-----+ | VAL | KEY | | VAL | KEY | +-----+-----+ +-----+-----+ NIL: / | V +-----+-----+-----+-----+ |'LIN'| / | / | / | +-----+--+--+-----+-----+ Symbol tail Internal/Transient 0010 Short name 0100 Long name 0000 Properties External 1010 Short name 1000 Properties Name final short Internals, Transients 0000.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx0010 60 52 44 36 28 20 12 4 Externals 42 bit Object (4 Tera objects) 16 bit File (64 K files) 2 bit Status Loaded 01........ Dirty 10........ Deleted 11........ 1+2 Bytes: 1 file, 64K objects {177777} 1+3 Bytes: 16 files, 1M objects {O3777777} 1+4 Bytes: 256 files, 16M objects {OO77777777} 1+5 Bytes: 256 files, 4G objects {OO37777777777} 1+6 Bytes: 65536 files, 4G objects {OOOO37777777777} 1+8 Bytes: 65536 files, 4T objects {OOOO77777777777777} (2 + 10 + 8 + 12 + 8 + 20) xx.xxxxxxxxx.xxxxxxx.xxxxxxxxxxx.xxxxxxx.xxxxxxxxxxxxxxxxxxxE010 obj file obj file obj ^6 ^5 ^4 ^3 ^2 ### Heap ### Heaps Avail | | | | +-----------------------+ | | | | V V | V +-----+-----+--+--+-----+-----+-----+-----+-----+--- ---+-----+ | | | | | | / | | ... | | | +-----+-----+-----+-----+-----+-----+-----+-----+--- ---+--+--+ | | +-----> ### Stack ### Saved values: ^ | +---> LINK ----+ | val1 | val2 | ... | valN +---- LINK <-- L Bind frame: ^ [exe] | Bind | +---> LINK ----+ | val1 | sym1 | ... | valN | symN +---- LINK <-- L <-- Bind eswp VarArgs frame: ^ [exe] | Bind | +---> LINK ----+ | val1 | sym1 | ... | valN | symN +---- LINK <---+ <-- Bind eswp | Next | Args | +---> LINK ----+ <-- Next | arg1 | ... | argN <-- Args +---- LINK <-- L Apply args: ^ | +---> LINK ----+ | ... | fun <-- Y | arg1 | ... | argN <-- Z | ... +---- LINK <-- L Apply frame: ^ Apply | +---> LINK ----+ | ... | valN <-+ (gc) | zero | | NIL | (gc) | carN --+ <-+ | ... | | val1 <-+ | (gc) | zero | | | cdr1 --|---+ (gc) | +-> car1 --+ | +-- cdr (gc) | fun <-- exe +---- LINK <-- L <-- Apply Catch frame: ^ X | Y | Z | L | [env] | fin | tag | LINK ----+ <-- Catch I/O frame: ^ put/get | pid | fd | LINK ----+ <-- inFrames, outFrames, errFrames, ctlFrames Coroutine frame: ^ X | Y | Z | L | [env] | seg -----|-----------------+ lim | | LINK ----+ <-- co7 | | | Stack segment: <--------------+ <-I> tag # Tag <-II> stk # Stack pointer --+ [env] # Environment | Stack ... | X | Y | Z | L <-----------------------+ ### Memory ### inFile: --> fd # File descriptor ix # Read index cnt # Buffer count next # Next character line # Line number src # Source line number name # Filename buf # Buffer [BUFSIZ] outFile: --> fd # File descriptor ix # Read index tty # TTY flag buf # Buffer [BUFSIZ] child: --> pid # Process ID hear # Pipe read end tell # Pipe write end ofs # Buffer offset cnt # Buffer count buf # Buffer pointer +--------------------------+ Mic | | +-----------------+ Tell | | | +-----------------> Hear | | | | Spkr <---+ | | | | | | +-----------------+ Tell | | | +-----------------> Hear | +--------------------------+ Mic ### Database file ### +-------------+-+-------------+-+----+ Block 0: | Free 0| Next 0| << | +-------------+-+-------------+-+----+ 0 BLK 2*Blk+1 +-------------+-+ Free: | Link 0| +-------------+-+ 0 +-------------+-+---- ID-Block: | Link 1| Data +-------------+-+---- 0 BLK +-------------+-+---- EXT-Block: | Link n| Data +-------------+-+---- 0 BLK dbFile: # Size VIII (64 bytes) --> fd # File descriptor db # File number sh # Block shift siz # Block size (64 << sh) flgs # Flags: Lock(0), Dirty(1) marks # Mark vector size mark # Mark bit vector fluse # Free list use count ### Assumptions ### - 8 bit per byte - 64 bit per word - Stack grows downwards, aligned to 64 bit - Memory access legal also at 4-byte boundaries picolisp-3.1.5.2.orig/ersatz/0000755000000000000000000000000012265263724014460 5ustar rootrootpicolisp-3.1.5.2.orig/ersatz/Manifest0000644000000000000000000000002512265263724016146 0ustar rootrootMain-Class: PicoLisp picolisp-3.1.5.2.orig/ersatz/README0000644000000000000000000000402512265263724015341 0ustar rootroot08may13abu (c) Software Lab. Alexander Burger Ersatz PicoLisp =============== Ersatz PicoLisp is a version of PicoLisp completely written in Java. It requires a 1.6 Java Runtime Environment. It should be the last resort when there is no other way to run a "real" PicoLisp. Also, it may be used to bootstrap the 64-bit version, which requires a running PicoLisp to build from the sources. Unfortunately, ErsatzLisp lacks everything which makes up "true" PicoLisp: Speed, small memory footprint, and simple internal structures. Performance is rather poor. It is 5 to 10 times slower, allocates a huge amount of memory at startup (600 MB vs. 3 MB), and needs 2.5 to 4 times the space for runtime Lisp data. But efficiency was not a major goal. Instead, performance was often sacrificed in favor of simpler or more modular structures. There is no support for -- raw console input ('key') and line editing -- child processes ('fork') -- interprocess communication ('tell', 'hear', 'ipc', 'udp' etc.) -- databases (external symbols) -- signal handling Invocation ---------- Ersatz PicoLisp can be started - analog to 'pil' - as $ ersatz/pil This includes slightly simplified versions of the standard libraries as loaded by the "real" 'pil' (without database, but with Pilog and XML support). To start it in debug mode, use $ ersatz/pil + On non-Unix systems, you might start 'java' directly, e.g.: java -DPID=42 -cp .;tmp;picolisp.jar PicoLisp lib.l Instead of '42' some other number may be passed. It is used to simulate a "process ID", so it should be different for every running instance of Ersatz PicoLisp. Building the JAR file --------------------- The actual source files are sys.src # The system fun.src # Function definitions The PicoLisp script "mkJar" will read them, generate the Java source file "PicoLisp.java", compile that with 'javac', and pack the result into a JAR (Java Archive) file. "mkJar" expects to be run in the "ersatz/" directory, e.g.: $ (cd ersatz; ./mkJar) picolisp-3.1.5.2.orig/ersatz/fun.src0000644000000000000000000027601612265263724015775 0ustar rootroot# 28aug13abu # (c) Software Lab. Alexander Burger # Ersatz PicoLisp Functions ############ main ############ # (env ['lst] | ['sym 'val] ..) -> lst env (i x y) y = Nil; if (!((ex = ex.Cdr) instanceof Cell)) { for (Bind p = Break? Env.Bind.Link : Env.Bind; p != null; p = p.Link) { if (p.Eswp == 0) { for (i = p.Cnt; --i > 0; --i) { for (x = y; ; x = x.Cdr) { if (!(x instanceof Cell)) { y = new Cell(new Cell(p.Data[i], p.Data[i].Car), y); break; } if (x.Car.Car == p.Data[i]) break; } } } } } else { do { if ((x = ex.Car.eval()) instanceof Cell) { do y = new Cell(x.Car instanceof Cell? new Cell(x.Car.Car, x.Car.Cdr) : new Cell(x.Car, x.Car.Car), y); while ((x = x.Cdr) instanceof Cell); } else if (x != Nil) { ex = ex.Cdr; y = new Cell(new Cell(x, ex.Car.eval()), y); } } while ((ex = ex.Cdr) instanceof Cell); } return y; # (up [cnt] sym ['val]) -> any up (i j k x) if (!((x = (ex = ex.Cdr).Car) instanceof Number)) k = 1; else { k = ((Number)x).Cnt; ex = ex.Cdr; x = ex.Car; } j = 0; Bind q = null; for (Bind p = Break? Env.Bind.Link : Env.Bind; p != null; p = p.Link) { for (i = 0; i < p.Cnt; i += 2) { if (p.Data[i+1] == x) { if (--k == 0) { if ((ex = ex.Cdr) instanceof Cell) return p.Data[i] = ex.Car.eval(); return p.Data[i]; } q = p; } } } if ((ex = ex.Cdr) instanceof Cell) if (q == null) x.Car = ex.Car.eval(); else q.Data[j] = ex.Car.eval(); return q == null? x.Car : q.Data[j]; # (sys 'any) -> sym sys () return mkStr(System.getenv(evString(ex.Cdr))); # (quit ['any ['any]]) quit (str) str = evString(ex = ex.Cdr); return err(null, (ex = ex.Cdr) instanceof Cell? ex.Car.eval() : null, str); # (java 'cls 'T ['any ..]) -> obj # (java 'cls 'msg ['any ..]) -> obj # (java 'obj 'msg ['any ..]) -> obj # (java 'obj ['cnt]) -> any java (num i j k x y z s v o) y = (x = ex.Cdr).Car.eval(); if ((z = (x = x.Cdr).Car.eval()) == Nil || z instanceof Number) { if ((s = (Symbol)y).Obj instanceof Boolean) return ((Boolean)s.Obj).booleanValue()? T : Nil; if (s.Obj instanceof Byte) return new Number(((Byte)s.Obj).byteValue()); if (s.Obj instanceof Character) return new Number(((Character)s.Obj).charValue()); if (s.Obj instanceof Integer) return new Number(((Integer)s.Obj).intValue()); if (s.Obj instanceof Long) return new Number(((Long)s.Obj).longValue()); if (s.Obj instanceof Float) return strToNum(Float.toString(((Float)s.Obj).floatValue()), xInt(z)); if (s.Obj instanceof Double) return strToNum(Double.toString(((Double)s.Obj).doubleValue()), xInt(z)); if (s.Obj instanceof BigInteger) return new Number((BigInteger)s.Obj); if (s.Obj instanceof String) return mkStr((String)s.Obj); x = Nil; if (s.Obj instanceof byte[]) { byte[] a = (byte[])s.Obj; for (i = a.length; --i >= 0;) x = new Cell(new Number(a[i]), x); } else if (s.Obj instanceof char[]) { char[] a = (char[])s.Obj; for (i = a.length; --i >= 0;) x = new Cell(new Number(a[i]), x); } else if (s.Obj instanceof int[]) { int[] a = (int[])s.Obj; for (i = a.length; --i >= 0;) x = new Cell(new Number(a[i]), x); } else if (s.Obj instanceof long[]) { long[] a = (long[])s.Obj; for (i = a.length; --i >= 0;) x = new Cell(new Number(a[i]), x); } else if (s.Obj instanceof float[]) { float[] a = (float[])s.Obj; j = xInt(z); for (i = a.length; --i >= 0;) x = new Cell(strToNum(Float.toString(a[i]), i), x); } else if (s.Obj instanceof double[]) { double[] a = (double[])s.Obj; j = xInt(z); for (i = a.length; --i >= 0;) x = new Cell(strToNum(Double.toString(a[i]), i), x); } return x; } for (v = new Any[6], i = 0; (x = x.Cdr) instanceof Cell;) v = append(v, i++, x.Car.eval()); Object[] arg = new Object[i]; Class[] par = new Class[i]; while (--i >= 0) { if (v[i] == Nil || v[i] == T) { arg[i] = v[i] == T; par[i] = Boolean.TYPE; } else if (v[i] instanceof Number) { if ((num = (Number)v[i]).Big != null) cntError(ex, num); arg[i] = new Integer(num.Cnt); par[i] = Integer.TYPE; } else if (v[i] instanceof Cell) { k = (int)v[i].length(); if (v[i].Car instanceof Number) { arg[i] = new int[k]; for (j = 0; j < k; ++j, v[i] = v[i].Cdr) Array.setInt(arg[i], j, ((Number)v[i].Car).Cnt); } else if (v[i].Car instanceof Cell) argError(ex, v[i]); else if ((s = (Symbol)v[i].Car).Obj == null) { arg[i] = Array.newInstance(s.Name.getClass(), k); for (j = 0; j < k; ++j, v[i] = v[i].Cdr) Array.set(arg[i], j, ((Symbol)v[i].Car).Name); } else { if (s.Obj instanceof Byte) arg[i] = Array.newInstance(Byte.TYPE, k); else if (s.Obj instanceof Character) arg[i] = Array.newInstance(Character.TYPE, k); else if (s.Obj instanceof Integer) arg[i] = Array.newInstance(Integer.TYPE, k); else if (s.Obj instanceof Long) arg[i] = Array.newInstance(Long.TYPE, k); else if (s.Obj instanceof Float) arg[i] = Array.newInstance(Float.TYPE, k); else if (s.Obj instanceof Double) arg[i] = Array.newInstance(Double.TYPE, k); else arg[i] = Array.newInstance(s.Obj.getClass(), k); for (j = 0; j < k; ++j, v[i] = v[i].Cdr) Array.set(arg[i], j, ((Symbol)v[i].Car).Obj); } par[i] = arg[i].getClass(); } else if ((s = (Symbol)v[i]).Obj == null) par[i] = (arg[i] = s.Name).getClass(); else { arg[i] = s.Obj; if (s.Obj instanceof Byte) par[i] = Byte.TYPE; else if (s.Obj instanceof Character) par[i] = Character.TYPE; else if (s.Obj instanceof Integer) par[i] = Integer.TYPE; else if (s.Obj instanceof Long) par[i] = Long.TYPE; else if (s.Obj instanceof Float) par[i] = Float.TYPE; else if (s.Obj instanceof Double) par[i] = Double.TYPE; else par[i] = s.Obj.getClass(); } } try { if (z == T) return new Symbol(javaConstructor(ex, java.lang.Class.forName(y.name()), par).newInstance(arg)); Method m = javaMethod(ex, (s = (Symbol)y).Obj == null? java.lang.Class.forName(s.Name) : s.Obj.getClass(), z.name(), par); o = m.invoke(s.Obj, arg); if (m.getReturnType() == Void.TYPE) return Nil; return o == null? Nil : new Symbol(o); } catch (Exception e) {return err(ex, null, e.toString());} # (public 'obj 'any ['any ..]) -> obj # (public 'cls 'any ['any ..]) -> obj public (x y z s o) y = (x = ex.Cdr).Car.eval(); z = (x = x.Cdr).Car.eval(); try { if ((s = (Symbol)y).Obj != null) o = s.Obj.getClass().getField(z.name()).get(s.Obj); else { java.lang.Class cls = java.lang.Class.forName(s.Name); o = cls.getField(z.name()).get(cls); } while ((x = x.Cdr) instanceof Cell) o = o.getClass().getField(x.Car.eval().name()).get(o); return new Symbol(o); } catch (Exception e) {return err(ex, null, e.toString());} # (interface 'cls|lst 'sym 'fun ..) -> obj interface (i x y) y = (x = ex.Cdr).Car.eval(); Class[] c = new Class[y instanceof Cell? (int)y.length() : 1]; try { if (y instanceof Cell) for (i = 0; i < c.length; ++i, y = y.Cdr) c[i] = java.lang.Class.forName(y.Car.name()); else c[0] = java.lang.Class.forName(y.name()); } catch (Exception e) {err(ex, null, e.toString());} final HashMap act = new HashMap(); while ((x = x.Cdr) instanceof Cell) { y = x.Car.eval(); act.put(y.name(), (x = x.Cdr).Car.eval()); } InvocationHandler h = new InvocationHandler() { public Object invoke(Object o, Method m, Object[] arg) { Any w; if ((w = act.get(m.getName())) == null) err(null, mkStr(m.getName()), "Can't invoke"); if (arg == null) return w.apply(null, false, null, 0); else { Any[] v = new Any[arg.length]; v[0] = new Symbol(o); for (int i = 0; i < arg.length; ++i) v[i] = new Symbol(arg[i]); return w.apply(null, false, v, v.length); } } }; return new Symbol(java.lang.reflect.Proxy.newProxyInstance(ClassLoader.getSystemClassLoader(), c, h)); # (byte: 'num|sym) -> obj byte: (x) x = ex.Cdr.Car.eval(); return new Symbol(new Byte(x instanceof Number? (byte)((Number)x).Cnt : (byte)x.name().charAt(0))); # (char: 'num|sym) -> obj char: (x) x = ex.Cdr.Car.eval(); return new Symbol(new Character(x instanceof Number? (char)((Number)x).Cnt : x.name().charAt(0))); # (int: 'num) -> obj int: () return new Symbol(new Integer(evInt(ex.Cdr))); # (long: 'num) -> obj long: () return new Symbol(new Long(evLong(ex.Cdr))); # (float: 'str 'cnt) -> obj # (float: 'num 'cnt) -> obj float: (x) if ((x = (ex = ex.Cdr).Car.eval()) instanceof Number) return new Symbol(new Float(((Number)x).toString(evInt(ex.Cdr), '.', '\0'))); return new Symbol(new Float(x.name())); # (double: 'str 'cnt) -> obj # (double: 'num 'cnt) -> obj double: (x) if ((x = (ex = ex.Cdr).Car.eval()) instanceof Number) return new Symbol(new Double(((Number)x).toString(evInt(ex.Cdr), '.', '\0'))); return new Symbol(new Double(x.name())); # (big: 'num) -> obj big: (num) num = (Number)(ex.Cdr.Car.eval()); return new Symbol(num.Big == null? big(num.Cnt) : num.Big); # (args) -> flg args T return Env.Next < Env.ArgC? T : Nil; # (next) -> any next () return Env.Next < Env.ArgC? (Env.Arg = Env.Args[Env.Next++]) : Nil; # (arg ['cnt]) -> any arg (i) if (ex.Cdr instanceof Cell) return (i = evInt(ex.Cdr)+Env.Next-1) >= 0 && i < Env.ArgC? Env.Args[i] : Nil; return Env.Arg; # (rest) -> lst rest (i x) for (x = Nil, i = Env.ArgC; --i >= Env.Next;) x = new Cell(Env.Args[i], x); return x; # (date ['T]) -> dat # (date 'dat) -> (y m d) # (date 'y 'm 'd) -> dat | NIL # (date '(y m d)) -> dat | NIL date (i j x z) if (!((x = ex.Cdr) instanceof Cell)) { Cal = new GregorianCalendar(); return date(Cal.get(Calendar.YEAR), Cal.get(Calendar.MONTH)+1, Cal.get(Calendar.DATE)); } if ((z = x.Car.eval()) == T) { Cal = new GregorianCalendar(TimeZone.getTimeZone("GMT")); return date(Cal.get(Calendar.YEAR), Cal.get(Calendar.MONTH)+1, Cal.get(Calendar.DATE)); } if (z == Nil) return Nil; if (z instanceof Cell) return date(xInt(z.Car), xInt(z.Cdr.Car), xInt(z.Cdr.Cdr.Car)); i = xInt(z); if (!((x = x.Cdr) instanceof Cell)) return date(i); j = evInt(x); return date(i, j, evInt(x.Cdr)); # (time ['T]) -> tim # (time 'tim) -> (h m s) # (time 'h 'm ['s]) -> tim | NIL # (time '(h m [s])) -> tim | NIL time (i j x z) if (!((x = ex.Cdr) instanceof Cell)) return time(new GregorianCalendar()); if ((z = x.Car.eval()) == T) return time(Cal); if (z == Nil) return Nil; if (z instanceof Cell) return time(xInt(z.Car), xInt(z.Cdr.Car), z.Cdr.Cdr instanceof Cell? xInt(z.Cdr.Cdr.Car) : 0); i = xInt(z); if (!((x = x.Cdr) instanceof Cell)) return new Cell(new Number(i / 3600), new Cell(new Number(i / 60 % 60), new Cell(new Number(i % 60), Nil))); j = evInt(x); return time(i, j, x.Cdr instanceof Cell? evInt(x.Cdr) : 0); # (usec ['flg]) -> num usec () return new Number(ex.Cdr.Car.eval() == Nil? System.nanoTime()/1000 - USec : Cal.get(Calendar.MILLISECOND) * 1000 ); # (pwd) -> sym pwd T return mkStr(System.getProperty("user.dir")); # (info 'any) -> (cnt|T dat . tim) info () File f = new File(path(evString(ex.Cdr))); if (!f.exists()) return Nil; Calendar c = new GregorianCalendar(TimeZone.getTimeZone("GMT")); c.setTimeInMillis(f.lastModified()); return new Cell( f.isDirectory()? T : new Number(f.length()), new Cell( date(c.get(Calendar.YEAR), c.get(Calendar.MONTH)+1, c.get(Calendar.DATE)), time(c) ) ); # (file) -> (sym1 sym2 . num) | NIL file (i x) if (InFile.Name == null) return Nil; x = new Number(InFile.Src); if ((i = InFile.Name.lastIndexOf('/')) >= 0) return new Cell(mkStr(InFile.Name.substring(0, i+1)), new Cell(mkStr(InFile.Name.substring(i+1)), x)); return new Cell(mkStr("./"), new Cell(mkStr(InFile.Name), x)); # (dir ['any] ['flg]) -> lst dir (i x y str) String[] lst = new File((str = evString(x = ex.Cdr)).length() == 0? "." : path(str)).list(); x = x.Cdr.Car.eval(); if (lst == null) return Nil; for (y = Nil, i = lst.length; --i >= 0;) if (x != Nil || lst[i].charAt(0) != '.') y = new Cell(mkStr(lst[i]), y); return y; # (argv [var ..] [. sym]) -> lst|sym argv (i j x y) i = Argv.length > 0 && Argv[0].equals("-")? 1 : 0; if ((x = ex.Cdr) == Nil) { if (i == Argv.length) return Nil; for (j = Argv.length; --j >= i;) x = new Cell(mkStr(Argv[j]), x); return x; } do { if (!(x instanceof Cell)) { if (i == Argv.length) return x.Car = Nil; for (y = Nil, j = Argv.length; --j >= i;) y = new Cell(mkStr(Argv[j]), y); return x.Car = y; } (y = x.Car).Car = i == Argv.length? Nil : mkStr(Argv[i++]); } while ((x = x.Cdr) != Nil); return y.Car; # (opt) -> sym opt (str) return (str = opt()) == null? Nil : mkStr(str); # (version ['flg]) -> lst version (i x) if (ex.Cdr.Car.eval() == Nil) { for (i = 0; i < 4; ++i) OutFile.Wr.print(Version[i] + (i == 3? " " : ".")); OutFile.Wr.println("JVM"); OutFile.Wr.flush(); } for (x = Nil, i = 4; --i >= 0;) x = new Cell(new Number(Version[i]), x); return x; ############ gc ############ # (gc) -> NIL gc T System.gc(); return Nil; ############ apply ############ # (apply 'fun 'lst ['any ..]) -> any apply (i w x y v) w = (x = ex.Cdr).Car.eval(); y = (x = x.Cdr).Car.eval(); for (v = new Any[6], i = 0; (x = x.Cdr) instanceof Cell;) v = append(v, i++, x.Car.eval()); while (y instanceof Cell) { v = append(v, i++, y.Car); y = y.Cdr; } return w.apply(ex, false, v, i); # (pass 'fun ['any ..]) -> any pass (i j w x v) w = (x = ex.Cdr).Car.eval(); for (v = new Any[6], i = 0; (x = x.Cdr) instanceof Cell;) v = append(v, i++, x.Car.eval()); for (j = Env.Next; j < Env.ArgC; ++j) v = append(v, i++, Env.Args[j]); return w.apply(ex, false, v, i); # (maps 'fun 'sym ['lst ..]) -> any maps (i j k w x y s v) w = (x = ex.Cdr).Car.eval(); if ((y = (x = x.Cdr).Car.eval()) == Nil || (s = (Symbol)y).Prop == null) return Nil; v = new Any[6]; i = 1; append(v, 0, null); while ((x = x.Cdr) instanceof Cell) v = append(v, i++, x.Car.eval()); k = s.Prop.length; do if ((x = s.Prop[--k]) != null) { v[0] = new Cell(x,Nil); x = w.apply(ex, true, v, i); for (j = i; --j > 0;) v[j] = v[j].Cdr; } while (k != 0); return x; # (map 'fun 'lst ..) -> lst map (i j w x v) w = (x = ex.Cdr).Car.eval(); if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { x = w.apply(ex, false, v, i); for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return x; # (mapc 'fun 'lst ..) -> any mapc (i j w x v) w = (x = ex.Cdr).Car.eval(); if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { x = w.apply(ex, true, v, i); for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return x; # (maplist 'fun 'lst ..) -> lst maplist (i j w x z v) w = (x = ex.Cdr).Car.eval(); z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); if (!(v[0] instanceof Cell)) return z; z = x = new Cell(w.apply(ex, false, v, i), Nil); while (v[0].Cdr instanceof Cell) { for (j = i; --j >= 0;) v[j] = v[j].Cdr; x = x.Cdr = new Cell(w.apply(ex, false, v, i), Nil); } } return z; # (mapcar 'fun 'lst ..) -> lst mapcar (i j w x z v) w = (x = ex.Cdr).Car.eval(); z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); if (!(v[0] instanceof Cell)) return z; z = x = new Cell(w.apply(ex, true, v, i), Nil); while (v[0].Cdr instanceof Cell) { for (j = i; --j >= 0;) v[j] = v[j].Cdr; x = x.Cdr = new Cell(w.apply(ex, true, v, i), Nil); } } return z; # (mapcon 'fun 'lst ..) -> lst mapcon (i j w x z v) w = (x = ex.Cdr).Car.eval(); z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); if (!(v[0] instanceof Cell)) return z; while (!((x = w.apply(ex, false, v, i)) instanceof Cell)) { if (!(v[0].Cdr instanceof Cell)) return z; for (j = i; --j >= 0;) v[j] = v[j].Cdr; } z = x; while (v[0].Cdr instanceof Cell) { for (j = i; --j >= 0;) v[j] = v[j].Cdr; while (x.Cdr instanceof Cell) x = x.Cdr; x.Cdr = w.apply(ex, false, v, i); } } return z; # (mapcan 'fun 'lst ..) -> lst mapcan (i j w x z v) w = (x = ex.Cdr).Car.eval(); z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); if (!(v[0] instanceof Cell)) return z; while (!((x = w.apply(ex, true, v, i)) instanceof Cell)) { if (!(v[0].Cdr instanceof Cell)) return z; for (j = i; --j >= 0;) v[j] = v[j].Cdr; } z = x; while (v[0].Cdr instanceof Cell) { for (j = i; --j >= 0;) v[j] = v[j].Cdr; while (x.Cdr instanceof Cell) x = x.Cdr; x.Cdr = w.apply(ex, true, v, i); } } return z; # (filter 'fun 'lst ..) -> lst filter (i j w x z v) w = (x = ex.Cdr).Car.eval(); z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); if (!(v[0] instanceof Cell)) return z; while (w.apply(ex, true, v, i) == Nil) { if (!(v[0].Cdr instanceof Cell)) return z; for (j = i; --j >= 0;) v[j] = v[j].Cdr; } z = x = new Cell(v[0].Car, Nil); while (v[0].Cdr instanceof Cell) { for (j = i; --j >= 0;) v[j] = v[j].Cdr; if (w.apply(ex, true, v, i) != Nil) x = x.Cdr = new Cell(v[0].Car, Nil); } } return z; # (extract 'fun 'lst ..) -> lst extract (i j w x y z v) w = (x = ex.Cdr).Car.eval(); z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); if (!(v[0] instanceof Cell)) return z; while ((y = w.apply(ex, true, v, i)) == Nil) { if (!(v[0].Cdr instanceof Cell)) return z; for (j = i; --j >= 0;) v[j] = v[j].Cdr; } z = x = new Cell(y, Nil); while (v[0].Cdr instanceof Cell) { for (j = i; --j >= 0;) v[j] = v[j].Cdr; if ((y = w.apply(ex, true, v, i)) != Nil) x = x.Cdr = new Cell(y, Nil); } } return z; # (seek 'fun 'lst ..) -> lst seek (i j w x v) w = (x = ex.Cdr).Car.eval(); if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { if (w.apply(ex, false, v, i) != Nil) return v[0]; for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return Nil; # (find 'fun 'lst ..) -> any find (i j w x v) w = (x = ex.Cdr).Car.eval(); if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { if (w.apply(ex, true, v, i) != Nil) return v[0].Car; for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return Nil; # (pick 'fun 'lst ..) -> any pick (i j w x v) w = (x = ex.Cdr).Car.eval(); if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { if ((x = w.apply(ex, true, v, i)) != Nil) return x; for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return Nil; # (cnt 'fun 'lst ..) -> cnt cnt (i j n w x v) w = (x = ex.Cdr).Car.eval(); n = 0; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { if (w.apply(ex, true, v, i) != Nil) ++n; for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return new Number(n); # (sum 'fun 'lst ..) -> num sum (num i j w x y v) w = (x = ex.Cdr).Car.eval(); num = Zero; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { if ((y = w.apply(ex, true, v, i)) instanceof Number) num = num.add((Number)y); for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return num; # (maxi 'fun 'lst ..) -> any maxi (i j w x y z v) w = (x = ex.Cdr).Car.eval(); y = z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { if ((x = w.apply(ex, true, v, i)).compare(y) > 0) { z = v[0].Car; y = x; } for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return z; # (mini 'fun 'lst ..) -> any mini (i j w x y z v) w = (x = ex.Cdr).Car.eval(); y = T; z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); while (v[0] instanceof Cell) { if ((x = w.apply(ex, true, v, i)).compare(y) < 0) { z = v[0].Car; y = x; } for (j = i; --j >= 0;) v[j] = v[j].Cdr; } } return z; # (fish 'fun 'any) -> lst fish (w v) w = ex.Cdr.Car.eval(); (v = new Any[1])[0] = ex.Cdr.Cdr.Car.eval(); return fish(ex, w, v, Nil); # (by 'fun1 'fun2 'lst ..) -> lst by (i j w x y z v) w = (x = ex.Cdr).Car.eval(); y = (x = x.Cdr).Car.eval(); z = Nil; if ((x = x.Cdr) instanceof Cell) { v = new Any[6]; i = 0; do v = append(v, i++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); z = x = new Cell(new Cell(w.apply(ex, true, v, i), v[0].Car), Nil); while (v[0].Cdr instanceof Cell) { for (j = i; --j >= 0;) v[j] = v[j].Cdr; x = x.Cdr = new Cell(new Cell(w.apply(ex, true, v, i), v[0].Car), Nil); } v[0] = z; z = y.apply(ex, false, v, 1); for (x = z; x instanceof Cell; x = x.Cdr) x.Car = x.Car.Cdr; } return z; ############ flow ############ # (as 'any1 . any2) -> any2 | NIL as () return ex.Cdr.Car.eval() == Nil? Nil : ex.Cdr.Cdr; # (lit 'any) -> any lit (x) return (x = ex.Cdr.Car.eval()) instanceof Number || x == Nil || x == T || x instanceof Cell && x.Car instanceof Number? x : new Cell(Quote, x); # (eval 'any ['cnt ['lst]]) -> any eval (y) if ((y = (ex = ex.Cdr).Car.eval()) instanceof Number) return y; if (ex.Cdr == Nil || Env.Bind == null) return y.eval(); return evRun(true, y, evInt(ex.Cdr), ex.Cdr.Cdr.Car.eval()); # (run 'any ['cnt ['lst]]) -> any run (y) if ((y = (ex = ex.Cdr).Car.eval()) instanceof Number) return y; if (ex.Cdr == Nil || Env.Bind == null) return y.run(); return evRun(false, y, evInt(ex.Cdr), ex.Cdr.Cdr.Car.eval()); # (def 'sym 'any) -> sym # (def 'sym 'sym 'any) -> sym def (w x y s) s = (Symbol)(ex = ex.Cdr).Car.eval(); x = (ex = ex.Cdr).Car.eval(); if (ex.Cdr == Nil) { if (s.Car != Nil && s.Car != s && !x.equal(s.Car)) redefMsg(s, null); s.Car = x; putSrc(s, null); } else { y = ex.Cdr.Car.eval(); if ((w = s.get(x)) != Nil && !x.equal(w)) redefMsg(s,x); s.put(x,y); putSrc(s,x); } return s; # (de sym . any) -> sym de () ex = ex.Cdr; redefine((Symbol)ex.Car, ex.Cdr); return ex.Car; # (dm sym . fun|cls2) -> sym # (dm (sym . cls) . fun|cls2) -> sym # (dm (sym sym2 [. cls]) . fun|cls2) -> sym dm (x y s t) if (!((x = ex.Cdr).Car instanceof Cell)) { s = (Symbol)x.Car; t = (Symbol)Class.Car; } else { s = (Symbol)x.Car.Car; t = (Symbol) (!((y = x.Car).Cdr instanceof Cell)? y.Cdr : (y.Cdr.Cdr == Nil? Class.Car : y.Cdr.Cdr).get(y.Cdr.Car) ); } if (s != T) redefine(s, Meth.Car); if (x.Cdr instanceof Symbol) { y = x.Cdr.Car; for (;;) { if (!(y instanceof Cell) || !(y.Car instanceof Cell)) err(ex, s, "Bad message"); if (y.Car.Car == s) { x = y.Car; break; } y = y.Cdr; } } for (y = t.Car; y instanceof Cell && y.Car instanceof Cell; y = y.Cdr) if (y.Car.Car == s) { if (!x.Cdr.equal(y.Cdr.Car)) redefMsg(s, t); y.Car.Cdr = x.Cdr; putSrc(t, s); return s; } t.Car = x.Car instanceof Cell? new Cell(new Cell(s, x.Cdr), t.Car) : new Cell(x, t.Car); putSrc(t, s); return s; # (box 'any) -> sym box () return mkSymbol(ex.Cdr.Car.eval()); # (new ['typ ['any ..]]) -> obj new (x s) s = mkSymbol((ex = ex.Cdr).Car.eval()); TheKey = T; TheCls = null; if ((x = method(s)) != null) evMethod(s, x, ex.Cdr); else { while ((ex = ex.Cdr) != Nil) { x = ex.Car.eval(); s.put(x, (ex = ex.Cdr).Car.eval()); } } return s; # (type 'any) -> lst type (x y z) if ((x = ex.Cdr.Car.eval()) instanceof Symbol) { z = x = x.Car; while (x instanceof Cell) { if (!(x.Car instanceof Cell)) { y = x; while (x.Car instanceof Symbol) { if (!((x = x.Cdr) instanceof Cell)) return x == Nil? y : Nil; if (z == x) return Nil; } return Nil; } if (z == (x = x.Cdr)) return Nil; } } return Nil; # (isa 'cls|typ 'any) -> obj | NIL isa (x y) x = (ex = ex.Cdr).Car.eval(); if ((y = ex.Cdr.Car.eval()) instanceof Symbol) { if (x instanceof Symbol) return isa(x,y)? y : Nil; while (x instanceof Cell) { if (!isa(x.Car, y)) return Nil; x = x.Cdr; } return y; } return Nil; # (method 'msg 'obj) -> fun method (x y) x = (ex = ex.Cdr).Car.eval(); y = ex.Cdr.Car.eval(); TheKey = x; return (x = method(y)) == null? Nil : x; # (send 'msg 'obj ['any ..]) -> any send (x y z) y = (x = ex.Cdr).Car.eval(); z = (x = x.Cdr).Car.eval(); TheKey = y; TheCls = null; if ((y = method(z)) == null) err(ex, TheKey, "Bad message"); return evMethod(z, y, x.Cdr); # (try 'msg 'obj ['any ..]) -> any try (x y) x = (ex = ex.Cdr).Car.eval(); if ((y = (ex = ex.Cdr).Car.eval()) instanceof Symbol) { TheKey = x; TheCls = null; if ((x = method(y)) != null) return evMethod(y, x, ex.Cdr); } return Nil; # (super ['any ..]) -> any super (w x y z) TheKey = Env.Key; x = Env.Cls == null? This.Car : Env.Cls.Car.Car; while (x.Car instanceof Cell) x = x.Cdr; for (;;) { if (!(x instanceof Cell)) err(ex, TheKey, "Bad super"); if ((y = method((TheCls = x).Car)) != null) { z = Env.Cls; Env.Cls = TheCls; w = Env.Key; Env.Key = TheKey; x = y.func(ex); Env.Key = w; Env.Cls = z; return x; } x = x.Cdr; } # (extra ['any ..]) -> any extra (x y z) TheKey = Env.Key; if ((x = extra(This.Car)) == null || x == T) err(ex, TheKey, "Bad extra"); y = Env.Cls; Env.Cls = TheCls; z = Env.Key; Env.Key = TheKey; x = x.func(ex); Env.Key = z; Env.Cls = y; return x; # (with 'sym . prg) -> any with (x bnd) if ((x = ex.Cdr.Car.eval()) != Nil) { (bnd = new Bind()).add(This.Car); bnd.add(This); This.Car = x; Env.Bind = bnd; x = ex.Cdr.Cdr.prog(); This.Car = bnd.Data[0]; } return x; # (bind 'sym|lst . prg) -> any bind (i x y z bnd) if ((y = (x = ex.Cdr).Car.eval()) == Nil) return x.Cdr.prog(); bnd = new Bind(); if (y instanceof Symbol) { bnd.add(y.Car); bnd.add(y); } else { do { if (y.Car instanceof Symbol) { bnd.add(y.Car.Car); bnd.add(y.Car); } else { z = y.Car.Car; bnd.add(z.Car); bnd.add(z); z.Car = y.Car.Cdr; } } while ((y = y.Cdr) instanceof Cell); } Env.Bind = bnd; x = x.Cdr.prog(); for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; return x; # (job 'lst . prg) -> any job (i w x y z bnd) bnd = new Bind(); for (z = y = (x = ex.Cdr).Car.eval(); y instanceof Cell; y = y.Cdr) { w = y.Car.Car; bnd.add(w.Car); bnd.add(w); w.Car = y.Car.Cdr; } Env.Bind = bnd; x = x.Cdr.prog(); for (i = 0; z instanceof Cell; i += 2, z = z.Cdr) { w = z.Car.Car; z.Car.Cdr = w.Car; w.Car = bnd.Data[i]; } Env.Bind = bnd.Link; return x; # (let sym 'any . prg) -> any # (let (sym 'any ..) . prg) -> any let (i x y z bnd) bnd = new Bind(); if ((y = (x = ex.Cdr).Car) instanceof Symbol) { bnd.add(y.Car); bnd.add(y); y.Car = (x = x.Cdr).Car.eval(); } else { do { z = y.Car; bnd.add(z.Car); bnd.add(z); z.Car = (y = y.Cdr).Car.eval(); } while ((y = y.Cdr) instanceof Cell); } Env.Bind = bnd; x = x.Cdr.prog(); for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; return x; # (let? sym 'any . prg) -> any let? (x y z bnd) z = (x = ex.Cdr).Car; if ((y = (x = x.Cdr).Car.eval()) != Nil) { (bnd = new Bind()).add(z.Car); bnd.add(z); z.Car = y; Env.Bind = bnd; y = x.Cdr.prog(); z.Car = bnd.Data[0]; } return y; # (use sym . prg) -> any # (use (sym ..) . prg) -> any use (i x y bnd) bnd = new Bind(); if ((y = (x = ex.Cdr).Car) instanceof Symbol) { bnd.add(y.Car); bnd.add(y); } else { do { bnd.add(y.Car.Car); bnd.add(y.Car); } while ((y = y.Cdr) instanceof Cell); } Env.Bind = bnd; x = x.Cdr.prog(); for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; return x; # (and 'any ..) -> any and (w) ex = ex.Cdr; do { if ((w = ex.Car.eval()) == Nil) return Nil; At.Car = w; } while ((ex = ex.Cdr) instanceof Cell); return w; # (or 'any ..) -> any or (w) ex = ex.Cdr; do if ((w = ex.Car.eval()) != Nil) return At.Car = w; while ((ex = ex.Cdr) instanceof Cell); return Nil; # (nand 'any ..) -> flg nand (w) ex = ex.Cdr; do { if ((w = ex.Car.eval()) == Nil) return T; At.Car = w; } while ((ex = ex.Cdr) instanceof Cell); return Nil; # (nor 'any ..) -> flg nor (w) ex = ex.Cdr; do if ((w = ex.Car.eval()) != Nil) { At.Car = w; return Nil; } while ((ex = ex.Cdr) instanceof Cell); return T; # (xor 'any 'any) -> flg xor (x y) y = (x = ex.Cdr).Car.eval(); x = x.Cdr.Car.eval(); return y == Nil ^ x == Nil? T : Nil; # (bool 'any) -> flg bool T return ex.Cdr.Car.eval() == Nil? Nil : T; # (not 'any) -> flg not (w) if ((w = ex.Cdr.Car.eval()) == Nil) return T; At.Car = w; return Nil; # (nil . prg) -> NIL nil () ex.Cdr.prog(); return Nil; # (t . prg) -> T t () ex.Cdr.prog(); return T; # (prog . prg) -> any prog T return ex.Cdr.prog(); # (prog1 'any1 . prg) -> any1 prog1 (w) w = At.Car = ex.Cdr.Car.eval(); ex.Cdr.Cdr.prog(); return w; # (prog2 'any1 'any2 . prg) -> any2 prog2 (w) (ex = ex.Cdr).Car.eval(); w = At.Car = (ex = ex.Cdr).Car.eval(); ex.Cdr.prog(); return w; # (if 'any1 'any2 . prg) -> any if (w) if ((w = (ex = ex.Cdr).Car.eval()) == Nil) return ex.Cdr.Cdr.prog(); At.Car = w; return ex.Cdr.Car.eval(); # (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any if2 (w) if ((w = (ex = ex.Cdr).Car.eval()) == Nil) { if ((w = (ex = ex.Cdr).Car.eval()) == Nil) return ex.Cdr.Cdr.Cdr.Cdr.prog(); At.Car = w; return ex.Cdr.Cdr.Cdr.Car.eval(); } At.Car = w; if ((w = (ex = ex.Cdr).Car.eval()) == Nil) return ex.Cdr.Cdr.Car.eval(); At.Car = w; return ex.Cdr.Car.eval(); # (ifn 'any1 'any2 . prg) -> any ifn (w) if ((w = (ex = ex.Cdr).Car.eval()) != Nil) { At.Car = w; return ex.Cdr.Cdr.prog(); } return ex.Cdr.Car.eval(); # (when 'any . prg) -> any when (w) if ((w = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; At.Car = w; return ex.Cdr.prog(); # (unless 'any . prg) -> any unless (w) if ((w = (ex = ex.Cdr).Car.eval()) != Nil) return Nil; At.Car = w; return ex.Cdr.prog(); # (cond ('any1 . prg1) ('any2 . prg2) ..) -> any cond (w) while ((ex = ex.Cdr) instanceof Cell) if ((w = ex.Car.Car.eval()) != Nil) { At.Car = w; return ex.Car.Cdr.prog(); } return Nil; # (nond ('any1 . prg1) ('any2 . prg2) ..) -> any nond (w) while ((ex = ex.Cdr) instanceof Cell) { if ((w = ex.Car.Car.eval()) == Nil) return ex.Car.Cdr.prog(); At.Car = w; } return Nil; # (case 'any (any1 . prg1) (any2 . prg2) ..) -> any case (x y) At.Car = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr) instanceof Cell) { x = ex.Car; y = x.Car; if (y == T || At.Car.equal(y)) return x.Cdr.prog(); if (y instanceof Cell) { do if (At.Car.equal(y.Car)) return x.Cdr.prog(); while ((y = y.Cdr) instanceof Cell); } } return Nil; # (casq 'any (any1 . prg1) (any2 . prg2) ..) -> any casq (x y) At.Car = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr) instanceof Cell) { x = ex.Car; y = x.Car; if (y == T || y == At.Car) return x.Cdr.prog(); if (y instanceof Cell) { do if (y.Car == At.Car) return x.Cdr.prog(); while ((y = y.Cdr) instanceof Cell); } } return Nil; # (state 'var (sym|lst exe [. prg]) ..) -> any state (w x y z) z = (x = ex.Cdr).Car.eval(); while ((x = x.Cdr) instanceof Cell) { y = x.Car; if (y.Car == T || memq(z.Car, y.Car) != null) { y = y.Cdr; if ((w = y.Car.eval()) != Nil) { At.Car = z.Car = w; return y.Cdr.prog(); } } } return Nil; # (while 'any . prg) -> any while (w x y) x = (ex = ex.Cdr).Car; ex = ex.Cdr; y = Nil; while ((w = x.eval()) != Nil) { At.Car = w; y = ex.prog(); } return y; # (until 'any . prg) -> any until (w x y) x = (ex = ex.Cdr).Car; ex = ex.Cdr; y = Nil; while ((w = x.eval()) == Nil) y = ex.prog(); At.Car = w; return y; # (do 'flg|cnt ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any do (n w x y) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; if (!(x instanceof Number)) return loop(ex.Cdr); for (ex = ex.Cdr, y = Nil, n = ((Number)x).longValue(); --n >= 0;) { x = ex; do { if (!((y = x.Car) instanceof Cell)) y = y.eval(); else if (y.Car == Nil) { if ((w = (y = y.Cdr).Car.eval()) == Nil) return y.Cdr.prog(); At.Car = w; y = Nil; } else if (y.Car == T) { if ((w = (y = y.Cdr).Car.eval()) != Nil) { At.Car = w; return y.Cdr.prog(); } y = Nil; } else y = y.eval(); } while ((x = x.Cdr) instanceof Cell); } return y; # (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any loop T return loop(ex.Cdr); # (at '(cnt1 . cnt2|NIL) . prg) -> any at (num x) x = (ex = ex.Cdr).Car.eval(); if (x.Cdr == Nil) return Nil; if ((num = ((Number)x.Car).add(One)).compare((Number)x.Cdr) < 0) { x.Car = num; return Nil; } x.Car = Zero; return ex.Cdr.prog(); # (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any # (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any # (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any for (i w x y z bnd) bnd = new Bind(); if (!((y = (ex = ex.Cdr).Car) instanceof Cell) || !(y.Cdr instanceof Cell)) { if (!(y instanceof Cell)) { bnd.add(y.Car); bnd.add(y); } else { bnd.add(y.Cdr.Car); bnd.add(y.Cdr); bnd.add((z = y.Car).Car); bnd.add(z); z.Car = Zero; } Env.Bind = bnd; if ((z = (ex = ex.Cdr).Car.eval()) instanceof Number) bnd.Data[1].Car = Zero; for1: for (y = Nil;;) { if (z instanceof Number) { if (((Number)(bnd.Data[1].Car = ((Number)bnd.Data[1].Car).add(One))).compare((Number)z) > 0) break; } else { if (!(z instanceof Cell)) break; bnd.Data[1].Car = z.Car; if (!((z = z.Cdr) instanceof Cell)) z = Nil; } if (bnd.Cnt == 4) bnd.Data[3].Car = ((Number)bnd.Data[3].Car).add(One); x = ex.Cdr; do { if (!((y = x.Car) instanceof Cell)) y = y.eval(); else if (y.Car == Nil) { if ((w = (y = y.Cdr).Car.eval()) == Nil) { y = y.Cdr.prog(); break for1; } At.Car = w; y = Nil; } else if (y.Car == T) { if ((w = (y = y.Cdr).Car.eval()) != Nil) { At.Car = w; y = y.Cdr.prog(); break for1; } y = Nil; } else y = y.eval(); } while ((x = x.Cdr) instanceof Cell); } } else { if (!((z = y.Car) instanceof Cell)) { bnd.add(z.Car); bnd.add(z); } else { bnd.add(z.Cdr.Car); bnd.add(z.Cdr); bnd.add((z = z.Car).Car); bnd.add(z); z.Car = Zero; } Env.Bind = bnd; bnd.Data[1].Car = (y = y.Cdr).Car.eval(); z = y.Cdr; for2: for (y = Nil;;) { if (bnd.Cnt == 4) bnd.Data[3].Car = ((Number)bnd.Data[3].Car).add(One); if ((w = z.Car.eval()) == Nil) break; At.Car = w; x = ex.Cdr; do { if (!((y = x.Car) instanceof Cell)) y = y.eval(); else if (y.Car == Nil) { if ((w = (y = y.Cdr).Car.eval()) == Nil) { y = y.Cdr.prog(); break for2; } At.Car = w; y = Nil; } else if (y.Car == T) { if ((w = (y = y.Cdr).Car.eval()) != Nil) { At.Car = w; y = y.Cdr.prog(); break for2; } y = Nil; } else y = y.eval(); } while ((x = x.Cdr) instanceof Cell); if (z.Cdr instanceof Cell) bnd.Data[1].Car = z.Cdr.prog(); } } for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; return y; # (catch 'any . prg) -> any catch (x y) new Catch(y = (x = ex.Cdr).Car.eval(), Zero, Env); try { x = x.Cdr.prog(); Catch = Catch.Link; return x; } catch (Control e) { if (y == e.Tag) return e.Val; throw e; } catch (RuntimeException e) { if (y instanceof Cell && e.toString().indexOf(y.Car.name()) >= 0) return y.Car; throw e; } # (throw 'sym 'any) throw (x y) y = (x = ex.Cdr).Car.eval(); throw new Control(ex, y, x.Cdr.Car.eval()); # (finally exe . prg) -> any finally (x y) new Catch(null, y = (x = ex.Cdr).Car, Env); x = x.Cdr.prog(); y.eval(); Catch = Catch.Link; return x; # (! . exe) -> any ! (x) x = ex.Cdr; if (Dbg.Car != Nil) x = brkLoad(x); return x.eval(); # (e . prg) -> any e (w x y z) if (!Break) err(ex, null, "No Break"); w = Dbg.Car; Dbg.Car = Nil; x = At.Car; At.Car = Brk.Data[4]; y = Run.Car; Run.Car = Brk.Data[2]; InFrame in = Env.InFrames; Env.popInFiles(); OutFrame out = Env.OutFrames; Env.popOutFiles(); z = ex.Cdr instanceof Cell? ex.Cdr.prog() : Up.Car.eval(); OutFile.Wr.flush(); Env.pushOutFile(out); Env.pushInFile(in); Dbg.Car = w; At.Car = x; Run.Car = y; return z; # ($ sym|lst lst . prg) -> any $ (i x) ex = ex.Cdr; if (Dbg.Car == Nil) return ex.Cdr.Cdr.prog(); trace(++Env.Trace, ex.Car, " :"); for (x = ex.Cdr.Car; x instanceof Cell; x = x.Cdr) { StdErr.space(); StdErr.print(x.Car.Car); } if (x != Nil) { if (x != At) { StdErr.space(); StdErr.print(x.Car); } else for (i = Env.Next; i < Env.ArgC; ++i) { StdErr.space(); StdErr.print(Env.Args[i]); } } StdErr.newline(); x = ex.Cdr.Cdr.prog(); trace(Env.Trace--, ex.Car, " = "); StdErr.print(x); StdErr.newline(); return x; # (call 'any ..) -> flg call (x) ArrayList cmd = new ArrayList(); for (x = ex.Cdr; x instanceof Cell; x = x.Cdr) cmd.add(x.Car.eval().name()); try { ProcessBuilder pb = new ProcessBuilder(cmd); pb.redirectErrorStream(true); Process p = pb.start(); BufferedReader in = new BufferedReader(new InputStreamReader(p.getInputStream())); String line; while ((line = in.readLine()) != null) System.out.println(line); return p.waitFor() == 0? T : Nil; } catch (IOException e) {System.err.println(cmd.get(0) + ": Can't exec");} catch (InterruptedException e) {} //#! sighandler() return Nil; # (ipid) -> pid | NIL ipid () return Env.InFrames != null && Env.InFrames.Pid > 1? new Number(Env.InFrames.Pid) : Nil; # (opid) -> pid | NIL opid () return Env.OutFrames != null && Env.OutFrames.Pid > 1? new Number(Env.OutFrames.Pid) : Nil; # (kill 'pid ['cnt]) -> flg kill (i) if (Pids[i = evInt(ex = ex.Cdr)] == null) return Nil; if ((ex = ex.Cdr) instanceof Cell && evInt(ex) == 0) return T; Pids[i].destroy(); return T; # (bye 'cnt|NIL) bye (x) x = ex.Cdr.Car.eval(); return bye(x == Nil? 0 : ((Number)x).Cnt); ############ sym ############ # (name 'sym ['sym2]) -> sym name (x y s) y = (x = ex.Cdr).Car.eval(); if (!((x = x.Cdr) instanceof Cell)) return mkStr(y.name()); if ((s = ((Symbol)y)).Name != null && Env.intern().get(s.Name) == s) err(ex, s, "Can't rename"); if (Transient.get(((Symbol)y).Name) == y) Transient.remove(((Symbol)y).Name); s.Name = ((Symbol)(x = x.Car.eval())).Name; return s; # (sp? 'any) -> flg sp? () return isBlank(ex.Cdr.Car.eval())? T : Nil; # (pat? 'any) -> sym | NIL pat? (x) return ((x = ex.Cdr.Car.eval()) instanceof Symbol) && firstChar(x) == '@'? x : Nil; # (fun? 'any) -> any fun? () return funq(ex.Cdr.Car.eval()); # (getd 'any) -> fun | NIL getd (x) if (!((x = ex.Cdr.Car.eval()) instanceof Symbol)) return Nil; return funq(x.Car) != Nil? x.Car : Nil; // ... reflection # (all ['T]) -> lst all () return all(ex.Cdr.Car.eval() == Nil? Env.intern() : Transient); # (symbols) -> sym # (symbols 'sym1) -> sym2 # (symbols 'sym1 'sym ..) -> sym2 symbols (x s t) if (ex.Cdr instanceof Cell) { s = (Symbol)ex.Cdr.Car.eval(); if ((x = ex.Cdr.Cdr) instanceof Cell) { s.Car = new Symbol(new Namespace()); do { t = (Symbol)x.Car.eval(); if (!(t.Car instanceof Symbol) || !(((Symbol)t.Car).Obj instanceof Namespace)) symNsError(ex, t); ((Namespace)(((Symbol)t.Car).Obj)).copy((Namespace)(((Symbol)s.Car).Obj)); } while ((x = x.Cdr) instanceof Cell); } else if (!(s.Car instanceof Symbol) || !(((Symbol)s.Car).Obj instanceof Namespace)) symNsError(ex, s); t = Env.Intern; Env.Intern = s; return t; } return Env.Intern; # (intern 'sym) -> sym intern (s t str) s = (Symbol)ex.Cdr.Car.eval(); if ((str = s.name()).length() == 0 || str.equals("NIL")) return Nil; if ((t = Env.intern().get(str)) != null) return t; Env.intern().put(str, s); return s; # (==== ['sym ..]) -> NIL ==== (x y) Transient.clear(); for (x = ex.Cdr; x instanceof Cell; x = x.Cdr) { y = x.Car.eval(); Transient.put(((Symbol)y).Name, (Symbol)y); } return Nil; # (box? 'any) -> sym | NIL box? (x) return ((x = ex.Cdr.Car.eval()) instanceof Symbol) && x.name().length() == 0? x : Nil; # (str? 'any) -> sym | NIL str? (x) return ((x = ex.Cdr.Car.eval()) instanceof Symbol) && Env.intern().get(x.name()) != x? x : Nil; # (ext? 'any) -> sym | NIL ext? T return Nil; # (zap 'sym) -> sym zap (s) s = (Symbol)ex.Cdr.Car.eval(); if (Env.intern().get(s.Name) == s) Env.intern().remove(s.Name); return s; # (chop 'any) -> lst chop (x y str) x = ex.Cdr.Car.eval(); if (!(x instanceof Cell)) { str = x.name(); if (str.length() == 0) return Nil; y = x = new Cell(mkChar(str.charAt(0)), Nil); for (int i = 1; i < str.length(); ++i) y = y.Cdr = new Cell(mkChar(str.charAt(i)), Nil); } return x; # (pack 'any ..) -> sym pack (sb) sb = new StringBuilder(); for (ex = ex.Cdr; ex instanceof Cell; ex = ex.Cdr) sb.append(evString(ex)); return mkStr(sb); # (glue 'any 'lst) -> sym glue (x y sb) x = ex.Cdr.Car.eval(); if (!((y = ex.Cdr.Cdr.Car.eval()) instanceof Cell)) return y; for (sb = new StringBuilder(), sb.append(y.Car.name()); (y = y.Cdr) instanceof Cell;) { sb.append(x.name()); sb.append(y.Car.name()); } return mkStr(sb); # (text 'any1 'any ..) -> sym text (i j k c str sb v) str = evString(ex = ex.Cdr); v = new Any[6]; i = 0; while ((ex = ex.Cdr) instanceof Cell) v = append(v, i++, ex.Car.eval()); sb = new StringBuilder(); k = str.length(); for (j = 0; j < k; ++j) if ((c = str.charAt(j)) != '@') sb.append(c); else if (++j == k) break; else if ((c = str.charAt(j)) == '@') sb.append('@'); else if (c >= '1') { if ((c -= '1') > 8) c -= 7; if (i > c) sb.append(v[c].name()); } return mkStr(sb); # (pre? 'any1 'any2) -> any2 | NIL pre? (x str) str = evString(ex = ex.Cdr); return (x = ex.Cdr.Car.eval()).name().startsWith(str)? x : Nil; # (sub? 'any1 'any2) -> any2 | NIL sub? (x str) str = evString(ex = ex.Cdr); return (x = ex.Cdr.Car.eval()).name().indexOf(str) >= 0? x : Nil; # (val 'var) -> any val T return ex.Cdr.Car.eval().Car; # (set 'var 'any ..) -> any set (x y) x = ex.Cdr; do { y = x.Car.eval(); needVar(ex, y); y.Car = (x = x.Cdr).Car.eval(); } while ((x = x.Cdr) instanceof Cell); return y.Car; # (setq var 'any ..) -> any setq (x y) x = ex.Cdr; do { y = x.Car; needVar(ex, y); y.Car = (x = x.Cdr).Car.eval(); } while ((x = x.Cdr) instanceof Cell); return y.Car; # (swap 'var 'any) -> any swap (x y) needVar(ex, x = ex.Cdr.Car.eval()); y = x.Car; x.Car = ex.Cdr.Cdr.Car.eval(); return y; # (xchg 'var 'var ..) -> any xchg (w x y z) x = ex.Cdr; do { needVar(ex, y = x.Car.eval()); needVar(ex, z = (x = x.Cdr).Car.eval()); w = y.Car; y.Car = z.Car; z.Car = w; } while ((x = x.Cdr) instanceof Cell); return w; # (on var ..) -> T on (x) x = ex.Cdr; do x.Car.Car = T; while ((x = x.Cdr) instanceof Cell); return T; # (off var ..) -> NIL off (x) x = ex.Cdr; do x.Car.Car = Nil; while ((x = x.Cdr) instanceof Cell); return Nil; # (onOff var ..) -> flg onOff (x y) x = ex.Cdr; do y = x.Car.Car = x.Car.Car == Nil? T : Nil; while ((x = x.Cdr) instanceof Cell); return y; # (zero var ..) -> 0 zero (x) x = ex.Cdr; do x.Car.Car = Zero; while ((x = x.Cdr) instanceof Cell); return Zero; # (one var ..) -> 1 one (x) x = ex.Cdr; do x.Car.Car = One; while ((x = x.Cdr) instanceof Cell); return One; # (default var 'any ..) -> any default (x y) x = ex.Cdr; do { y = x.Car; x = x.Cdr; needVar(ex, y); if (y.Car == Nil) y.Car = x.Car.eval(); } while ((x = x.Cdr) instanceof Cell); return y.Car; # (push 'var 'any ..) -> any push (x y z) needVar(ex, y = (x = ex.Cdr).Car.eval()); do y.Car = new Cell(z = (x = x.Cdr).Car.eval(), y.Car); while (x.Cdr instanceof Cell); return z; # (push1 'var 'any ..) -> any push1 (x y z) needVar(ex, y = (x = ex.Cdr).Car.eval()); do if (member(z = (x = x.Cdr).Car.eval(), y.Car) == null) y.Car = new Cell(z, y.Car); while (x.Cdr instanceof Cell); return z; # (pop 'var) -> any pop (x y) needVar(ex, x = ex.Cdr.Car.eval()); if ((y = x.Car) instanceof Cell) { x.Car = x.Car.Cdr; y = y.Car; } return y; # (cut 'cnt 'var) -> lst cut (n x y z) if ((n = evLong(ex.Cdr)) <= 0) return Nil; needVar(ex, x = ex.Cdr.Cdr.Car.eval()); if (x.Car instanceof Cell) { z = y = new Cell(x.Car.Car, Nil); while ((x.Car = x.Car.Cdr) instanceof Cell && --n != 0) y = y.Cdr = new Cell(x.Car.Car, Nil); return z; } return x.Car; # (del 'any 'var) -> lst del (w lst x y z) w = ex.Cdr.Car.eval(); needVar(ex, x = ex.Cdr.Cdr.Car.eval()); if ((lst = x.Car) instanceof Cell) { if (w.equal(lst.Car)) return x.Car = lst.Cdr; for (z = y = new Cell(lst.Car, Nil); (lst = lst.Cdr) instanceof Cell; y = y.Cdr = new Cell(lst.Car, Nil)) if (w.equal(lst.Car)) { y.Cdr = lst.Cdr; return x.Car = z; } } return x.Car; # (queue 'var 'any) -> any queue (x y) needVar(ex, x = ex.Cdr.Car.eval()); y = ex.Cdr.Cdr.Car.eval(); if (!(x.Car instanceof Cell)) x.Car = new Cell(y, Nil); else { for (x = x.Car; x.Cdr instanceof Cell; x = x.Cdr); x.Cdr = new Cell(y, Nil); } return y; # (fifo 'var ['any ..]) -> any fifo (x y z lst) needVar(ex, y = (x = ex.Cdr).Car.eval()); if ((x = x.Cdr) instanceof Cell) { z = x.Car.eval(); if ((lst = y.Car) instanceof Cell) y.Car = lst = lst.Cdr = new Cell(z, lst.Cdr); else { lst = y.Car = new Cell(z, Nil); lst.Cdr = lst; } while ((x = x.Cdr) instanceof Cell) y.Car = lst = lst.Cdr = new Cell(z = x.Car.eval(), lst.Cdr); return z; } if (!((lst = y.Car) instanceof Cell)) return Nil; if (lst == lst.Cdr) { z = lst.Car; y.Car = Nil; } else { z = lst.Cdr.Car; lst.Cdr = lst.Cdr.Cdr; } return z; # (idx 'var 'any 'flg) -> lst # (idx 'var 'any) -> lst # (idx 'var) -> lst idx (x y) needVar(ex, x = (ex = ex.Cdr).Car.eval()); if (!((ex = ex.Cdr) instanceof Cell)) return idx(x, null, 0); y = ex.Car.eval(); return idx(x, y, ex.Cdr instanceof Cell? (ex.Cdr.Car.eval() == Nil? -1 : +1) : 0); # (lup 'lst 'any) -> lst # (lup 'lst 'any 'any2) -> lst lup (i x y z) x = (ex = ex.Cdr).Car.eval(); y = (ex = ex.Cdr).Car.eval(); if ((z = ex.Cdr.Car.eval()) != Nil) return consLup(x, Nil, y, z); while (x instanceof Cell) { if (x.Car == T) x = x.Cdr.Car; else if (!(x.Car instanceof Cell)) x = x.Cdr.Cdr; else if ((i = y.compare(x.Car.Car)) == 0) return x.Car; else x = i < 0? x.Cdr.Car : x.Cdr.Cdr; } return Nil; # (put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any put (x y) x = (ex = ex.Cdr).Car.eval(); for (;;) { y = (ex = ex.Cdr).Car.eval(); if (!(ex.Cdr.Cdr instanceof Cell)) return x.put(y, ex.Cdr.Car.eval()); x = x.get(y); } # (get 'sym1|lst ['sym2|cnt ..]) -> any get (x) x = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr) instanceof Cell) x = x.get(ex.Car.eval()); return x; # (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var prop (x) x = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr).Cdr instanceof Cell) x = x.get(ex.Car.eval()); return x.prop(ex.Car.eval()); # (; 'sym1|lst [sym2|cnt ..]) -> any ; (x) x = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr) instanceof Cell) x = x.get(ex.Car); return x; # (=: sym|0 [sym1|cnt .. sym2|0] 'any) -> any =: (x y) for (x = This.Car;;) { y = (ex = ex.Cdr).Car; if (!(ex.Cdr.Cdr instanceof Cell)) return x.put(y, ex.Cdr.Car.eval()); x = x.get(y); } # (: sym|0 [sym1|cnt ..]) -> any : (x) x = This.Car; do x = x.get((ex = ex.Cdr).Car); while (ex.Cdr instanceof Cell); return x; # (:: sym|0 [sym1|cnt .. sym2]) -> var :: (x) x = This.Car; while ((ex = ex.Cdr).Cdr instanceof Cell) x = x.get(ex.Car); return x.prop(ex.Car); # (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst putl (x) x = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr).Cdr instanceof Cell) x = x.get(ex.Car.eval()); return x.putl(ex.Car.eval()); # (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst getl (x) x = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr) instanceof Cell) x = x.get(ex.Car.eval()); return x.getl(); # (wipe 'sym|lst) -> sym wipe (x y) if ((x = ex.Cdr.Car.eval()) != Nil) if (!(x instanceof Cell)) ((Symbol)x).wipe(); else { y = x; do ((Symbol)y.Car).wipe(); while ((y = y.Cdr) instanceof Cell); } return x; # (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any meta (x) if ((x = (ex = ex.Cdr).Car.eval()) instanceof Symbol) x = x.Car; for (x = meta(x, (ex = ex.Cdr).Car.eval()); (ex = ex.Cdr) instanceof Cell;) x = x.get(ex.Car.eval()); return x; # (low? 'any) -> sym | NIL low? (x) return (x = ex.Cdr.Car.eval()) instanceof Symbol && Character.isLowerCase(firstChar(x))? x : Nil; # (upp? 'any) -> sym | NIL upp? (x) return (x = ex.Cdr.Car.eval()) instanceof Symbol && Character.isUpperCase(firstChar(x))? x : Nil; # (lowc 'any) -> any lowc (i j x str sb) if (!((x = ex.Cdr.Car.eval()) instanceof Symbol) || (j = (str = x.name()).length()) == 0) return x; sb = new StringBuilder(); for (i = 0; i < j; ++i) sb.append(Character.toLowerCase(str.charAt(i))); return mkStr(sb); # (uppc 'any) -> any uppc (i j x str sb) if (!((x = ex.Cdr.Car.eval()) instanceof Symbol) || (j = (str = x.name()).length()) == 0) return x; sb = new StringBuilder(); for (i = 0; i < j; ++i) sb.append(Character.toUpperCase(str.charAt(i))); return mkStr(sb); # (fold 'any ['cnt]) -> sym fold (i j k x str c sb) if (!((x = (ex = ex.Cdr).Car.eval()) instanceof Symbol) || (j = (str = x.name()).length()) == 0) return x; for (i = 0; !Character.isLetterOrDigit(c = str.charAt(i));) if (++i == j) return Nil; k = (ex = ex.Cdr) instanceof Cell? evInt(ex) : 0; sb = new StringBuilder(); sb.append(Character.toLowerCase(c)); while (++i < j) if (Character.isLetterOrDigit(c = str.charAt(i))) { if (--k == 0) break; sb.append(Character.toLowerCase(c)); } return mkStr(sb); ############ subr ############ # (Car -> any car T return ex.Cdr.Car.eval().Car; # (cdr 'lst) -> any cdr T return ex.Cdr.Car.eval().Cdr; caar T return ex.Cdr.Car.eval().Car.Car; cadr T return ex.Cdr.Car.eval().Cdr.Car; cdar T return ex.Cdr.Car.eval().Car.Cdr; cddr T return ex.Cdr.Car.eval().Cdr.Cdr; caaar () return ex.Cdr.Car.eval().Car.Car.Car; caadr () return ex.Cdr.Car.eval().Cdr.Car.Car; cadar () return ex.Cdr.Car.eval().Car.Cdr.Car; caddr () return ex.Cdr.Car.eval().Cdr.Cdr.Car; cdaar () return ex.Cdr.Car.eval().Car.Car.Cdr; cdadr () return ex.Cdr.Car.eval().Cdr.Car.Cdr; cddar () return ex.Cdr.Car.eval().Car.Cdr.Cdr; cdddr () return ex.Cdr.Car.eval().Cdr.Cdr.Cdr; caaaar () return ex.Cdr.Car.eval().Car.Car.Car.Car; caaadr () return ex.Cdr.Car.eval().Cdr.Car.Car.Car; caadar () return ex.Cdr.Car.eval().Car.Cdr.Car.Car; caaddr () return ex.Cdr.Car.eval().Cdr.Cdr.Car.Car; cadaar () return ex.Cdr.Car.eval().Car.Car.Cdr.Car; cadadr () return ex.Cdr.Car.eval().Cdr.Car.Cdr.Car; caddar () return ex.Cdr.Car.eval().Car.Cdr.Cdr.Car; cadddr () return ex.Cdr.Car.eval().Cdr.Cdr.Cdr.Car; cdaaar () return ex.Cdr.Car.eval().Car.Car.Car.Cdr; cdaadr () return ex.Cdr.Car.eval().Cdr.Car.Car.Cdr; cdadar () return ex.Cdr.Car.eval().Car.Cdr.Car.Cdr; cdaddr () return ex.Cdr.Car.eval().Cdr.Cdr.Car.Cdr; cddaar () return ex.Cdr.Car.eval().Car.Car.Cdr.Cdr; cddadr () return ex.Cdr.Car.eval().Cdr.Car.Cdr.Cdr; cdddar () return ex.Cdr.Car.eval().Car.Cdr.Cdr.Cdr; cddddr () return ex.Cdr.Car.eval().Cdr.Cdr.Cdr.Cdr; # (nth 'lst 'cnt ..) -> lst nth (x) x = (ex = ex.Cdr).Car.eval(); for (;;) { if (!(x instanceof Cell)) return x; x = nth(evInt(ex = ex.Cdr), x); if (ex.Cdr == Nil) return x; x = x.Car; } # (con 'lst 'any) -> any con (x) x = ex.Cdr.Car.eval(); return x.Cdr = ex.Cdr.Cdr.Car.eval(); # (cons 'any ['any ..]) -> lst cons (x y) y = x = new Cell((ex = ex.Cdr).Car.eval(), Nil); while ((ex = ex.Cdr).Cdr instanceof Cell) x = x.Cdr = new Cell(ex.Car.eval(), Nil); x.Cdr = ex.Car.eval(); return y; # (conc 'lst ..) -> lst conc (x y z) z = x = (ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr) instanceof Cell) { if (!(x instanceof Cell)) z = x = ex.Car.eval(); else { while ((y = x.Cdr) instanceof Cell) x = y; x.Cdr = ex.Car.eval(); } } return z; # (circ 'any ..) -> lst circ (x y) y = x = new Cell((ex = ex.Cdr).Car.eval(), Nil); while ((ex = ex.Cdr) instanceof Cell) x = x.Cdr = new Cell(ex.Car.eval(), Nil); x.Cdr = y; return y; # (rot 'lst ['cnt]) -> lst rot (i w x y z) w = y = (ex = ex.Cdr).Car.eval(); if (w instanceof Cell) { i = ex.Cdr == Nil? 0 : evInt(ex.Cdr); x = y.Car; while (--i != 0 && (y = y.Cdr) instanceof Cell && y != w) { z = y.Car; y.Car = x; x = z; } w.Car = x; } return w; # (list 'any ['any ..]) -> lst list (x y) x = y = new Cell((ex = ex.Cdr).Car.eval(), Nil); while ((ex = ex.Cdr) instanceof Cell) x = x.Cdr = new Cell(ex.Car.eval(), Nil); return y; # (need 'cnt ['lst ['any]]) -> lst # (need 'cnt ['num|sym]) -> lst need (n x y z) n = evLong(ex = ex.Cdr); if ((z = (ex = ex.Cdr).Car.eval()) instanceof Cell || z == Nil) y = ex.Cdr.Car.eval(); else { y = z; z = Nil; } x = z; if (n > 0) for (n -= x.length(); n > 0; --n) z = new Cell(y,z); else if (n != 0) { if (!(x instanceof Cell)) z = x = new Cell(y,Nil); else while (x.Cdr instanceof Cell) { ++n; x = x.Cdr; } while (++n < 0) x = x.Cdr = new Cell(y,Nil); } return z; # (range 'num1 'num2 ['num3]) -> lst range (num x y) num = (Number)(y = (x = ex.Cdr).Car.eval()); Number end = (Number)(x = x.Cdr).Car.eval(); Number inc = (x = x.Cdr.Car.eval()) == Nil? One : (Number)x; x = y = new Cell(y, Nil); if (end.compare(num) >= 0) while (end.compare(num = num.add(inc)) >= 0) x = x.Cdr = new Cell(num, Nil); else while (end.compare(num = num.sub(inc)) <= 0) x = x.Cdr = new Cell(num, Nil); return y; # (full 'any) -> bool full (x) for (x = ex.Cdr.Car.eval(); x instanceof Cell; x = x.Cdr) if (x.Car == Nil) return Nil; return T; # (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any make (x y z) x = Env.Make; Env.Make = Nil; y = Env.Yoke; Env.Yoke = Nil; ex.Cdr.prog(); z = Env.Yoke; Env.Yoke = y; Env.Make = x; return z; # (made ['lst1 ['lst2]]) -> lst made (x y) if ((x = ex.Cdr) instanceof Cell) { Env.Yoke = x.Car.eval(); x = x.Cdr; if (!((x = x.Car.eval()) instanceof Cell)) for (x = Env.Yoke; (y = x.Cdr) instanceof Cell; x = y); Env.Make = x; } return Env.Yoke; # (chain 'lst ..) -> lst chain (x y) ex = ex.Cdr; do { x = ex.Car.eval(); if (Env.Make != Nil) Env.Make = Env.Make.Cdr = x; else Env.Yoke = Env.Make = x; while ((y = Env.Make.Cdr) instanceof Cell) Env.Make = y; } while ((ex = ex.Cdr) instanceof Cell); return x; # (link 'any ..) -> any link (x) ex = ex.Cdr; do { x = ex.Car.eval(); if (Env.Make != Nil) Env.Make = Env.Make.Cdr = new Cell(x, Nil); else Env.Yoke = Env.Make = new Cell(x, Nil); } while ((ex = ex.Cdr) instanceof Cell); return x; # (yoke 'any ..) -> any yoke (x) ex = ex.Cdr; do { x = ex.Car.eval(); Env.Yoke = new Cell(x, Env.Yoke); if (Env.Make == Nil) Env.Make = Env.Yoke; } while ((ex = ex.Cdr) instanceof Cell); return x; # (copy 'any) -> any copy (w x y z) if (!((x = ex.Cdr.Car.eval()) instanceof Cell)) return x; for (w = y = new Cell(x.Car, (z = x).Cdr); (x = y.Cdr) instanceof Cell; y = y.Cdr = new Cell(x.Car, x.Cdr)) if (x == z) { y.Cdr = w; break; } return w; # (mix 'lst cnt|'any ..) -> lst mix (x y z) if (!((y = (ex = ex.Cdr).Car.eval()) instanceof Cell) && y != Nil) return y; if (!((ex = ex.Cdr) instanceof Cell)) return Nil; z = x = new Cell(ex.Car instanceof Number? nth(xInt(ex.Car), y).Car : ex.Car.eval(), Nil); while ((ex = ex.Cdr) instanceof Cell) x = x.Cdr = new Cell(ex.Car instanceof Number? nth(xInt(ex.Car), y).Car : ex.Car.eval(), Nil); return z; # (append 'lst ..) -> lst append (x y z) for (ex = ex.Cdr; (z = ex.Cdr) instanceof Cell; ex = z) { if ((x = ex.Car.eval()) instanceof Cell) { z = y = new Cell(x.Car, x.Cdr); while ((x = y.Cdr) instanceof Cell) y = y.Cdr = new Cell(x.Car, x.Cdr); while ((ex = ex.Cdr).Cdr instanceof Cell) { for (x = ex.Car.eval(); x instanceof Cell; x = y.Cdr) y = y.Cdr = new Cell(x.Car, x.Cdr); y.Cdr = x; } y.Cdr = ex.Car.eval(); return z; } } return ex.Car.eval(); # (delete 'any 'lst) -> lst delete (w x y z) y = (x = ex.Cdr).Car.eval(); if (!((x = x.Cdr.Car.eval()) instanceof Cell)) return x; if (y.equal(x.Car)) return x.Cdr; w = z = new Cell(x.Car, Nil); while ((x = x.Cdr) instanceof Cell) { if (y.equal(x.Car)) { z.Cdr = x.Cdr; return w; } z = z.Cdr = new Cell(x.Car, Nil); } z.Cdr = x; return w; # (delq 'any 'lst) -> lst delq (w x y z) y = (x = ex.Cdr).Car.eval(); if (!((x = x.Cdr.Car.eval()) instanceof Cell)) return x; if (y == x.Car) return x.Cdr; w = z = new Cell(x.Car, Nil); while ((x = x.Cdr) instanceof Cell) { if (y == x.Car) { z.Cdr = x.Cdr; return w; } z = z.Cdr = new Cell(x.Car, Nil); } z.Cdr = x; return w; # (replace 'lst 'any1 'any2 ..) -> lst replace (i j w x y z v) if (!((y = (x = ex.Cdr).Car.eval()) instanceof Cell)) return y; for (v = new Any[6], i = 0; (x = x.Cdr) instanceof Cell; ++i) { v = append(v, i, x.Car.eval()); v = append(v, ++i, (x = x.Cdr).Car.eval()); } for (x = y.Car, j = 0; j < i; j += 2) if (x.equal(v[j])) { x = v[j+1]; break; } for (w = z = new Cell(x, Nil); (y = y.Cdr) instanceof Cell; z = z.Cdr = new Cell(x, Nil)) for (x = y.Car, j = 0; j < i; j += 2) if (x.equal(v[j])) { x = v[j+1]; break; } z.Cdr = y; return w; # (strip 'any) -> any strip (x) for (x = ex.Cdr.Car.eval(); x instanceof Cell && x.Car == Quote && x != x.Cdr; x = x.Cdr); return x; # (split 'lst 'any ..) -> lst split (i j x y z v) if (!((z = (x = ex.Cdr).Car.eval()) instanceof Cell)) return z; for (v = new Any[6], i = 0; (x = x.Cdr) instanceof Cell; ++i) v = append(v, i, x.Car.eval()); Any res = x = Nil; Any sub = y = Nil; spl: do { for (j = 0; j < i; ++j) { if (z.Car.equal(v[j])) { if (x == Nil) x = res = new Cell(sub, Nil); else x = x.Cdr = new Cell(sub, Nil); y = sub = Nil; continue spl; } } if (y == Nil) y = sub = new Cell(z.Car, Nil); else y = y.Cdr = new Cell(z.Car, Nil); } while ((z = z.Cdr) instanceof Cell); y = new Cell(sub, Nil); if (x == Nil) return y; x.Cdr = y; return res; # (reverse 'lst) -> lst reverse (x y) x = ex.Cdr.Car.eval(); for (y = Nil; x instanceof Cell; x = x.Cdr) y = new Cell(x.Car, y); return y; # (flip 'lst ['cnt])) -> lst flip (i x y z) if (!((y = (ex = ex.Cdr).Car.eval()) instanceof Cell) || !((z = y.Cdr) instanceof Cell)) return y; if (ex.Cdr == Nil) { y.Cdr = Nil; for (;;) { x = z.Cdr; z.Cdr = y; if (!(x instanceof Cell)) return z; y = z; z = x; } } if ((i = evInt(ex.Cdr) - 1) <= 0) return y; y.Cdr = z.Cdr; z.Cdr = y; while (--i != 0 && (x = y.Cdr) instanceof Cell) { y.Cdr = x.Cdr; x.Cdr = z; z = x; } return z; # (trim 'lst) -> lst trim () return trim(ex.Cdr.Car.eval()); # (clip 'lst) -> lst clip (x) for (x = ex.Cdr.Car.eval(); x instanceof Cell && isBlank(x.Car); x = x.Cdr); return trim(x); # (head 'cnt|lst 'lst) -> lst head (i x y z) if ((z = (x = ex.Cdr).Car.eval()) == Nil) return Nil; x = x.Cdr.Car.eval(); if (z instanceof Cell) { if (x instanceof Cell) { for (y = z; y.Car.equal(x.Car); x = x.Cdr) if (!((y = y.Cdr) instanceof Cell)) return z; } return Nil; } if ((i = xInt(z)) == 0) return Nil; if (!(x instanceof Cell)) return x; if (i < 0 && (i += x.length()) <= 0) return Nil; z = y = new Cell(x.Car, Nil); while (--i != 0 && (x = x.Cdr) instanceof Cell) y = y.Cdr = new Cell(x.Car, Nil); return z; # (tail 'cnt|lst 'lst) -> lst tail (i x y z) if ((z = (x = ex.Cdr).Car.eval()) == Nil) return Nil; x = x.Cdr.Car.eval(); if (z instanceof Cell) { if (x instanceof Cell) { do if (x.equal(z)) return z; while ((x = x.Cdr) instanceof Cell); } return Nil; } if ((i = xInt(z)) == 0) return Nil; if (!(x instanceof Cell)) return x; if (i < 0) return nth(1 - i, x); for (y = x.Cdr; --i != 0; y = y.Cdr) if (!(y instanceof Cell)) return x; while (y instanceof Cell) { x = x.Cdr; y = y.Cdr; } return x; # (stem 'lst 'any ..) -> lst stem (i j x y v) y = (x = ex.Cdr).Car.eval(); for (v = new Any[6], i = 0; (x = x.Cdr) instanceof Cell; ++i) v = append(v, i, x.Car.eval()); for (x = y; x instanceof Cell; x = x.Cdr) for (j = 0; j < i; ++j) if (x.Car.equal(v[j])) { y = x.Cdr; break; } return y; # (fin 'any) -> num|sym fin (x) for (x = ex.Cdr.Car.eval(); x instanceof Cell; x = x.Cdr); return x; # (last 'lst) -> any last (x) if (!((x = ex.Cdr.Car.eval()) instanceof Cell)) return x; while (x.Cdr instanceof Cell) x = x.Cdr; return x.Car; # (== 'any ..) -> flg == (x y) y = (x = ex.Cdr).Car.eval(); while ((x = x.Cdr) instanceof Cell) if (y != x.Car.eval()) return Nil; return T; # (n== 'any ..) -> flg n== (x y) y = (x = ex.Cdr).Car.eval(); while ((x = x.Cdr) instanceof Cell) if (y != x.Car.eval()) return T; return Nil; # (= 'any ..) -> flg = (x y) y = (x = ex.Cdr).Car.eval(); while ((x = x.Cdr) instanceof Cell) if (!y.equal(x.Car.eval())) return Nil; return T; # (<> 'any ..) -> flg <> (x y) y = (x = ex.Cdr).Car.eval(); while ((x = x.Cdr) instanceof Cell) if (!y.equal(x.Car.eval())) return T; return Nil; # (=0 'any) -> 0 | NIL =0 () return ex.Cdr.Car.eval().equal(Zero)? Zero : Nil; # (=T 'any) -> flg =T () return T == ex.Cdr.Car.eval()? T : Nil; # (n0 'any) -> flg n0 () return ex.Cdr.Car.eval().equal(Zero)? Nil : T; # (nT 'any) -> flg nT () return T == ex.Cdr.Car.eval()? Nil : T; # (< 'any ..) -> flg < (x y z) y = (x = ex.Cdr).Car.eval(); while ((x = x.Cdr) instanceof Cell) { z = x.Car.eval(); if (y.compare(z) >= 0) return Nil; y = z; } return T; # (<= 'any ..) -> flg <= (x y z) y = (x = ex.Cdr).Car.eval(); while ((x = x.Cdr) instanceof Cell) { z = x.Car.eval(); if (y.compare(z) > 0) return Nil; y = z; } return T; # (> 'any ..) -> flg > (x y) x = (ex = ex.Cdr).Car.eval(); while (ex.Cdr instanceof Cell) { y = (ex = ex.Cdr).Car.eval(); if (x.compare(y) <= 0) return Nil; x = y; } return T; # (>= 'any ..) -> flg >= (x y z) y = (x = ex.Cdr).Car.eval(); while ((x = x.Cdr) instanceof Cell) { z = x.Car.eval(); if (y.compare(z) < 0) return Nil; y = z; } return T; # (max 'any ..) -> any max (x y) for (y = (ex = ex.Cdr).Car.eval(); (ex = ex.Cdr) instanceof Cell;) if ((x = ex.Car.eval()).compare(y) > 0) y = x; return y; # (min 'any ..) -> any min (x y) for (y = (ex = ex.Cdr).Car.eval(); (ex = ex.Cdr) instanceof Cell;) if ((x = ex.Car.eval()).compare(y) < 0) y = x; return y; # (atom 'any) -> flg atom () return ex.Cdr.Car.eval() instanceof Cell? Nil : T; # (pair 'any) -> any pair (x) return (x = ex.Cdr.Car.eval()) instanceof Cell? x : Nil; # (circ? 'any) -> any circ? (x) return (x = ex.Cdr.Car.eval()) instanceof Cell && (x = circ(x)) != null? x : Nil; # (lst? 'any) -> flg lst? (x) return (x = ex.Cdr.Car.eval()) instanceof Cell || x == Nil? T : Nil; # (num? 'any) -> num | NIL num? (x) return (x = ex.Cdr.Car.eval()) instanceof Number? x : Nil; # (sym? 'any) -> flg sym? (x) return (x = ex.Cdr.Car.eval()) instanceof Symbol || x == Nil? T : Nil; # (flg? 'any) -> flg flg? (x) return (x = ex.Cdr.Car.eval()) == Nil || x == T? T : Nil; # (member 'any 'lst) -> any member (x) x = (ex = ex.Cdr).Car.eval(); return (x = member(x, ex.Cdr.Car.eval())) == null? Nil : x; # (memq 'any 'lst) -> any memq (x) x = (ex = ex.Cdr).Car.eval(); return (x = memq(x, ex.Cdr.Car.eval())) == null? Nil : x; # (mmeq 'lst 'lst) -> any mmeq (x y z) x = (ex = ex.Cdr).Car.eval(); for (y = (ex = ex.Cdr).Car.eval(); x instanceof Cell; x = x.Cdr) if ((z = memq(x.Car, y)) != null) return z; return Nil; # (sect 'lst 'lst) -> lst sect (w x y z) y = (x = ex.Cdr).Car.eval(); z = x.Cdr.Car.eval(); w = x = Nil; while (y instanceof Cell) { if (member(y.Car, z) != null) if (x == Nil) x = w = new Cell(y.Car, Nil); else x = x.Cdr = new Cell(y.Car, Nil); y = y.Cdr; } return w; # (diff 'lst 'lst) -> lst diff (w x y z) y = (x = ex.Cdr).Car.eval(); z = x.Cdr.Car.eval(); w = x = Nil; while (y instanceof Cell) { if (member(y.Car, z) == null) if (x == Nil) x = w = new Cell(y.Car, Nil); else x = x.Cdr = new Cell(y.Car, Nil); y = y.Cdr; } return w; # (index 'any 'lst) -> cnt | NIL index (i x y) y = (x = ex.Cdr).Car.eval(); return (i = indx(y, x.Cdr.Car.eval())) == 0? Nil : new Number(i); # (offset 'lst1 'lst2) -> cnt | NIL offset (i x y) y = (x = ex.Cdr).Car.eval(); x = x.Cdr.Car.eval(); for (i = 1; x instanceof Cell; ++i, x = x.Cdr) if (x.equal(y)) return new Number(i); return Nil; # (prior 'lst1 'lst2) -> lst | NIL prior (x y) y = (x = ex.Cdr).Car.eval(); x = x.Cdr.Car.eval(); if (x != y) while (x instanceof Cell) { if (y == x.Cdr) return x; x = x.Cdr; } return Nil; # (length 'any) -> cnt | T length (n) return (n = ex.Cdr.Car.eval().length()) >= 0? new Number(n) : T; # (size 'any) -> cnt size () return new Number(ex.Cdr.Car.eval().size()); # (assoc 'any 'lst) -> lst assoc (x y z) y = (x = ex.Cdr).Car.eval(); x = x.Cdr.Car.eval(); for (; x instanceof Cell; x = x.Cdr) if ((z = x.Car) instanceof Cell && y.equal(z.Car)) return z; return Nil; # (asoq 'any 'lst) -> lst asoq (x y z) y = (x = ex.Cdr).Car.eval(); x = x.Cdr.Car.eval(); for (; x instanceof Cell; x = x.Cdr) if ((z = x.Car) instanceof Cell && y == z.Car) return z; return Nil; # (rank 'any 'lst ['flg]) -> lst rank (w x y z) w = (x = ex.Cdr).Car.eval(); y = (x = x.Cdr).Car.eval(); z = Nil; if (x.Cdr.Car.eval() == Nil) for (; y instanceof Cell; y = y.Cdr) { if ((x = y.Car) instanceof Cell && x.Car.compare(w) > 0) break; z = y; } else for (; y instanceof Cell; y = y.Cdr) { if ((x = y.Car) instanceof Cell && w.compare(x.Car) > 0) break; z = y; } return z.Car; # (match 'lst1 'lst2) -> flg match (x y) y = (x = ex.Cdr).Car.eval(); return match(y, x.Cdr.Car.eval())? T : Nil; # (fill 'any ['sym|lst]) -> any fill (x y) y = (x = ex.Cdr).Car.eval(); return (x = fill(y, x.Cdr.Car.eval())) == null? y : x; # (prove 'lst ['lst]) -> lst prove (i x y) if (!((y = (ex = ex.Cdr).Car.eval()) instanceof Cell)) return Nil; Any dbg = ex.Cdr.Car.eval(), at = At.Car, envSave = Penv, nlSave = Pnl; Penv = y.Car.Car; y.Car = y.Car.Cdr; Any n = Penv.Car; Penv = Penv.Cdr; Pnl = Penv.Car; Penv = Penv.Cdr; Any alt = Penv.Car; Penv = Penv.Cdr; Any tp1 = Penv.Car; Penv = Penv.Cdr; Any tp2 = Penv.Car; Penv = Penv.Cdr; Any e = Nil; while (tp1 instanceof Cell || tp2 instanceof Cell) { if (alt instanceof Cell) { e = Penv; if (!unify((Number)Pnl.Car, tp1.Car.Cdr, (Number)n, alt.Car.Car)) { if (!((alt = alt.Cdr) instanceof Cell)) { Penv = y.Car.Car; y.Car = y.Car.Cdr; n = Penv.Car; Penv = Penv.Cdr; Pnl = Penv.Car; Penv = Penv.Cdr; alt = Penv.Car; Penv = Penv.Cdr; tp1 = Penv.Car; Penv = Penv.Cdr; tp2 = Penv.Car; Penv = Penv.Cdr; } } else { if (dbg != Nil && memq(tp1.Car.Car, dbg) != null) { OutFile.Wr.print(indx(alt.Car, tp1.Car.Car.get(T))); OutFile.space(); OutFile.print(uniFill(tp1.Car)); OutFile.newline(); } if (alt.Cdr instanceof Cell) y.Car = new Cell( new Cell(n, new Cell(Pnl, new Cell(alt.Cdr, new Cell(tp1, new Cell(tp2, e)) ) ) ), y.Car ); Pnl = new Cell(n, Pnl); n = ((Number)n).add(One); tp2 = new Cell(tp1.Cdr, tp2); tp1 = alt.Car.Cdr; alt = Nil; } } else if (!((x = tp1) instanceof Cell)) { tp1 = tp2.Car; tp2 = tp2.Cdr; Pnl = Pnl.Cdr; } else if (x.Car == T) { while (y.Car instanceof Cell && ((Number)y.Car.Car.Car).Cnt >= ((Number)Pnl.Car).Cnt) y.Car = y.Car.Cdr; tp1 = x.Cdr; } else if (x.Car.Car instanceof Number) { e = x.Car.Cdr.prog(); for (i = ((Number)x.Car.Car).Cnt, x = Pnl; --i > 0;) x = x.Cdr; Pnl = new Cell(x.Car, Pnl); tp2 = new Cell(tp1.Cdr, tp2); tp1 = e; } else if (x.Car.Car == Up) { if ((e = x.Car.Cdr.Cdr.prog()) != Nil && unify((Number)Pnl.Car, x.Car.Cdr.Car, (Number)Pnl.Car, e)) tp1 = x.Cdr; else { Penv = y.Car.Car; y.Car = y.Car.Cdr; n = Penv.Car; Penv = Penv.Cdr; Pnl = Penv.Car; Penv = Penv.Cdr; alt = Penv.Car; Penv = Penv.Cdr; tp1 = Penv.Car; Penv = Penv.Cdr; tp2 = Penv.Car; Penv = Penv.Cdr; } } else if (!((alt = x.Car.Car.get(T)) instanceof Cell)) { Penv = y.Car.Car; y.Car = y.Car.Cdr; n = Penv.Car; Penv = Penv.Cdr; Pnl = Penv.Car; Penv = Penv.Cdr; alt = Penv.Car; Penv = Penv.Cdr; tp1 = Penv.Car; Penv = Penv.Cdr; tp2 = Penv.Car; Penv = Penv.Cdr; } } for (e = Nil, x = Penv; x.Cdr instanceof Cell; x = x.Cdr) if (x.Car.Car.Car.equal(Zero)) e = new Cell(new Cell(x.Car.Car.Cdr, lookup(Zero, x.Car.Car.Cdr)), e); At.Car = at; x = e instanceof Cell? e : Penv instanceof Cell? T : Nil; Penv = envSave; Pnl = nlSave; return x; # (-> any [num]) -> any -> (i x) if (!(ex.Cdr.Cdr.Car instanceof Number)) return lookup((Number)Pnl.Car, ex.Cdr.Car); for (i = ((Number)ex.Cdr.Cdr.Car).Cnt, x = Pnl; --i > 0;) x = x.Cdr; return lookup((Number)x.Car, ex.Cdr.Car); # (unify 'any) -> lst unify (x) x = ex.Cdr.Car.eval(); return unify((Number)Pnl.Cdr.Car, x, (Number)Pnl.Car, x)? Penv : Nil; # (sort 'lst ['fun]) -> lst sort (x) return (x = ex.Cdr.Car.eval()) instanceof Cell && x.Cdr instanceof Cell? sort(ex, x, ex.Cdr.Cdr.Car.eval()) : x; ############ big ############ # (format 'num ['cnt ['sym1 ['sym2]]]) -> sym # (format 'sym|lst ['cnt ['sym1 ['sym2]]]) -> num format (i x y) x = (ex = ex.Cdr).Car.eval(); i = (y = (ex = ex.Cdr).Car.eval()) == Nil? 0 : ((Number)y).Cnt; return format(x, i, ex.Cdr); # (+ 'num ..) -> num + (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; for (num = (Number)x; ex.Cdr instanceof Cell; num = num.add((Number)x)) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; return num; # (- 'num ..) -> num - (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; num = (Number)x; if (!(ex.Cdr instanceof Cell)) return num.neg(); do { if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; num = num.sub((Number)x); } while (ex.Cdr instanceof Cell); return num; # (inc 'num) -> num # (inc 'var ['num]) -> num inc (x y) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; if (x instanceof Number) return ((Number)x).add(One); if (!(ex.Cdr instanceof Cell)) { if (x.Car == Nil) return Nil; x.Car = y = ((Number)x.Car).add(One); } else { y = ex.Cdr.Car.eval(); if (x.Car == Nil || y == Nil) return Nil; x.Car = y = ((Number)x.Car).add((Number)y); } return y; # (dec 'num) -> num # (dec 'var ['num]) -> num dec (x y) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; if (x instanceof Number) return ((Number)x).sub(One); if (!(ex.Cdr instanceof Cell)) { if (x.Car == Nil) return Nil; x.Car = y = ((Number)x.Car).sub(One); } else { y = ex.Cdr.Car.eval(); if (x.Car == Nil || y == Nil) return Nil; x.Car = y = ((Number)x.Car).sub((Number)y); } return y; # (* 'num ..) -> num * (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; for (num = (Number)x; ex.Cdr instanceof Cell; num = num.mul((Number)x)) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; return num; # (*/ 'num1 ['num2 ..] 'num3) -> num */ (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; for (num = (Number)x; ; num = num.mul((Number)x)) { if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; if (!((ex.Cdr) instanceof Cell)) return num.add(((Number)x).div(Two)).div(((Number)x)); } # (/ 'num ..) -> num / (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; for (num = (Number)x; ex.Cdr instanceof Cell; num = num.div((Number)x)) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; return num; # (% 'num ..) -> num % (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; for (num = (Number)x; ex.Cdr instanceof Cell; num = num.rem((Number)x)) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; return num; # (>> 'cnt 'num) -> num >> (i x) i = evInt(ex = ex.Cdr); if ((x = ex.Cdr.Car.eval()) == Nil) return Nil; return ((Number)x).shift(i); # (lt0 'any) -> num | NIL lt0 (x) return (x = ex.Cdr.Car.eval()) instanceof Number && x.compare(Zero) < 0? x : Nil; # (le0 'any) -> num | NIL le0 (x) return (x = ex.Cdr.Car.eval()) instanceof Number && x.compare(Zero) <= 0? x : Nil; # (ge0 'any) -> num | NIL ge0 (x) return (x = ex.Cdr.Car.eval()) instanceof Number && x.compare(Zero) >= 0? x : Nil; # (gt0 'any) -> num | NIL gt0 (x) return (x = ex.Cdr.Car.eval()) instanceof Number && x.compare(Zero) > 0? x : Nil; # (abs 'num) -> num abs () return ((Number)ex.Cdr.Car.eval()).abs(); # (bit? 'num ..) -> num | NIL bit? (num x) num = (Number)(ex = ex.Cdr).Car.eval(); while ((ex = ex.Cdr) instanceof Cell) if ((x = ex.Car.eval()) == Nil || !num.tst((Number)x)) return Nil; return num; # (& 'num ..) -> num & (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; for (num = (Number)x; ex.Cdr instanceof Cell; num = num.and((Number)x)) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; return num; # (| 'num ..) -> num | (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; for (num = (Number)x; ex.Cdr instanceof Cell; num = num.or((Number)x)) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; return num; # (x| 'num ..) -> num x| (num x) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; for (num = (Number)x; ex.Cdr instanceof Cell; num = num.xor((Number)x)) if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return Nil; return num; # (seed 'any) -> cnt seed (n) n = initSeed(ex.Cdr.Car.eval()) * 6364136223846793005L; return new Number(Seed = n); # (hash 'any) -> cnt hash (i j n) n = initSeed(ex.Cdr.Car.eval()); i = 64; j = 0; do { if ((((int)n ^ j) & 1) != 0) j ^= 0x14002; /* CRC Polynom x**16 + x**15 + x**2 + 1 */ n >>>= 1; j >>= 1; } while (--i != 0); return new Number(j + 1); # (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg rand (x) Seed = Seed * 6364136223846793005L + 1; if ((x = (ex = ex.Cdr).Car.eval()) == Nil) return new Number(Seed); if (x == T) return (Seed & 0x100000000L) == 0? Nil : T; return new Number(((Number)x).Cnt + (int)(Seed >>> 33) % (evInt(ex.Cdr) + 1 - ((Number)x).Cnt)); ############ io ############ # (path 'any) -> sym path () return mkStr(path(evString(ex.Cdr))); # (read ['sym1 ['sym2]]) -> any read (x y) if (!((x = ex.Cdr) instanceof Cell)) x = InFile.read('\0'); else { y = x.Car.eval(); if ((x = InFile.token(y, (x = x.Cdr.Car.eval()) == Nil? '\0' : firstChar(x))) == null) x = Nil; } if (InFile.Name == null && InFile.Chr == '\n') InFile.Chr = 0; return x; # (wait ['cnt] . prg) -> any wait (i x y) i = (y = (x = ex.Cdr).Car.eval()) == Nil? -1 : xInt(y); for (x = x.Cdr; (y = x.prog()) == Nil;) if ((i = waitFd(ex, -1, i)) == 0) return x.prog(); return y; # (poll 'cnt) -> cnt | NIL poll (i x) if ((i = xInt(x = ex.Cdr.Car.eval())) < 0 || i >= InFiles.length) badFd(ex,x); if (InFiles[i] == null) return Nil; try { Selector sel = Selector.open(); if (InFiles[i].ready(sel)) return x; InFiles[i].register(sel); sel.selectNow(); if (InFiles[i].ready(sel)) return x; } catch (IOException e) {giveup(e);} return Nil; # (peek) -> sym peek () if (InFile.Chr == 0) InFile.get(); return InFile.Chr<0? Nil : mkChar(InFile.Chr); # (char) -> sym # (char 'cnt) -> sym # (char T) -> sym # (char 'sym) -> cnt char (x) if (!((ex = ex.Cdr) instanceof Cell)) { if (InFile.Chr == 0) InFile.get(); x = InFile.Chr < 0? Nil : mkChar(InFile.Chr); InFile.get(); return x; } if ((x = ex.Car.eval()) instanceof Number) return x.equal(Zero)? Nil : mkChar(((Number)x).Cnt); return x == T? mkChar(0x10000) : new Number(firstChar(x)); # (skip ['any]) -> sym skip () return InFile.skipc(firstChar(ex.Cdr.Car.eval())) < 0? Nil : mkChar(InFile.Chr); # (eol) -> flg eol () return InFile.Chr=='\n' || InFile.Chr<=0? T : Nil; # (eof ['flg]) -> flg eof () if (ex.Cdr.Car.eval() != Nil) { InFile.Chr = -1; return T; } if (InFile.Chr == 0) InFile.get(); return InFile.Chr < 0? T : Nil; # (from 'any ..) -> sym from (i j k x v) if ((k = (int)(x = ex.Cdr).length()) == 0) return Nil; int[] p = new int[k]; String[] av = new String[k]; for (v = new Any[k], i = 0; i < k; ++i, x = x.Cdr) av[i] = (v[i] = x.Car.eval()).name(); if (InFile.Chr == 0) InFile.get(); while (InFile.Chr >= 0) { for (i = 0; i < k; ++i) { for (;;) { if (av[i].charAt(p[i]) == (char)InFile.Chr) { if (++p[i] != av[i].length()) break; InFile.get(); return v[i]; } if (p[i] == 0) break; for (j = 1; --p[i] != 0; ++j) if (av[i].substring(0, p[i]).equals(av[i].substring(j, j + p[i]))) break; } } InFile.get(); } return Nil; # (till 'any ['flg]) -> lst|sym till (x y str sb) str = evString(x = ex.Cdr); if (InFile.Chr == 0) InFile.get(); if (InFile.Chr < 0 || str.indexOf((char)InFile.Chr) >= 0) return Nil; if (x.Cdr.Car.eval() == Nil) { y = x = new Cell(mkChar(InFile.Chr), Nil); while (InFile.get() > 0 && str.indexOf((char)InFile.Chr) < 0) x = x.Cdr = new Cell(mkChar(InFile.Chr), Nil); return y; } sb = new StringBuilder(); do sb.append((char)InFile.Chr); while (InFile.get() > 0 && str.indexOf((char)InFile.Chr) < 0); return mkStr(sb); # (line 'flg) -> lst|sym line (x y sb) if (InFile.Chr == 0) InFile.get(); if (InFile.eol()) return Nil; if (ex.Cdr.Car.eval() != Nil) { sb = new StringBuilder(); do { sb.append((char)InFile.Chr); InFile.get(); } while (!InFile.eol()); return mkStr(sb); } for (x = y = new Cell(mkChar(InFile.Chr), Nil);;) { InFile.get(); if (InFile.eol()) return x; y = y.Cdr = new Cell(mkChar(InFile.Chr), Nil); } # (any 'sym) -> any any (x) if ((x = ex.Cdr.Car.eval()) == Nil) return Nil; PicoLispReader rd = new PicoLispReader(x.name(), ' ', '\0'); rd.get(); return rd.read0(true); # (sym 'any) -> sym sym () StringWriter sw = new StringWriter(); PrintWriter wr = new PrintWriter(sw); wr.print(ex.Cdr.Car.eval().toString()); return mkStr(sw.toString()); # (str 'sym ['sym1]) -> lst # (str 'lst) -> sym str (x y) if ((y = (x = ex.Cdr).Car.eval()) == Nil) return Nil; if (y instanceof Number) argError(ex, y); if (y instanceof Symbol) return ((Symbol)y).parse(false, (x = x.Cdr) instanceof Cell? x.Car.eval() : null); StringWriter sw = new StringWriter(); PrintWriter wr = new PrintWriter(sw); for (;;) { wr.print(y.Car.toString()); if (!((y = y.Cdr) instanceof Cell)) break; wr.print(' '); } return mkStr(sw.toString()); # (load 'any ..) -> any load (x y) x = ex.Cdr; do { if ((y = x.Car.eval()) != T) y = load(ex, '>', y); else y = loadAll(ex); } while ((x = x.Cdr) instanceof Cell); return y; # (in 'any . prg) -> any in (x) Env.pushInFile((x = ex.Cdr).Car.eval().rdOpen(ex)); x = x.Cdr.prog(); Env.popInFiles(); return x; # (out 'any . prg) -> any out (x) Env.pushOutFile((x = ex.Cdr).Car.eval().wrOpen(ex)); x = x.Cdr.prog(); Env.popOutFiles(); return x; # (open 'any) -> cnt | NIL open (str) str = evString(ex.Cdr); try {return new Number(new PicoLispReader(new FileReader(str), str, allocFd(), null, 0).Fd);} catch (IOException e) {} return Nil; # (close 'cnt) -> cnt | NIL close (i x) if ((i = xInt(x = ex.Cdr.Car.eval())) >= 0 && i < InFiles.length) { if (InFiles[i] != null) { InFiles[i].close(); if (OutFiles[i] != null) OutFiles[i].close(); return x; } if (OutFiles[i] != null) { OutFiles[i].close(); return x; } } return Nil; # (echo ['cnt ['cnt]] | ['sym ..]) -> sym echo (i j k n x y v) y = (x = ex.Cdr).Car.eval(); if (InFile.Chr == 0) InFile.get(); if (y == Nil && !(x.Cdr instanceof Cell)) { while (InFile.Chr >= 0) { OutFile.Wr.print((char)InFile.Chr); InFile.get(); } return T; } if (y instanceof Symbol) { k = (int)x.length(); int[] p = new int[k]; String[] av = new String[k]; for (v = new Any[k], i = 0; i < k; ++i, y = (x = x.Cdr).Car.eval()) av[i] = (v[i] = y).name(); int m = -1, d, om, op = 0; /* Brain-dead Java: 'op' _is_ initialized */ while (InFile.Chr >= 0) { if ((om = m) >= 0) op = p[m]; for (i = 0; i < k; ++i) { for (;;) { if (av[i].charAt(p[i]) == (char)InFile.Chr) { if (++p[i] != av[i].length()) { if (m < 0 || p[i] > p[m]) m = i; break; } if (om >= 0) for (j = 0, d = op-p[i]; j <= d; ++j) OutFile.Wr.print(av[om].charAt(j)); InFile.Chr = 0; return v[i]; } if (p[i] == 0) break; for (j = 1; --p[i] != 0; ++j) if (av[i].substring(0, p[i]).equals(av[i].substring(j, j + p[i]))) break; if (m == i) for (m = -1, j = 0; j < k; ++j) if (p[j] != 0 && (m < 0 || p[j] > p[m])) m = j; } } if (m < 0) { if (om >= 0) for (i = 0; i < op; ++i) OutFile.Wr.print(av[om].charAt(i)); OutFile.Wr.print((char)InFile.Chr); } else if (om >= 0) for (i = 0, d = op-p[m]; i <= d; ++i) OutFile.Wr.print(av[om].charAt(i)); InFile.get(); } return Nil; } if ((x = x.Cdr) instanceof Cell) { for (n = xLong(y), y = x.Car.eval(); --n >= 0; InFile.get()) if (InFile.Chr < 0) return Nil; } if ((n = xLong(y)) > 0) { for (;;) { if (InFile.Chr < 0) return Nil; OutFile.Wr.print((char)InFile.Chr); if (--n == 0) break; InFile.get(); } } InFile.Chr = 0; return T; # (prin 'any ..) -> any prin (x) for (x = Nil; (ex = ex.Cdr) instanceof Cell; OutFile.Wr.print((x = ex.Car.eval()).name())); return x; # (prinl 'any ..) -> any prinl (x) for (x = Nil; (ex = ex.Cdr) instanceof Cell; OutFile.Wr.print((x = ex.Car.eval()).name())); OutFile.newline(); return x; # (space ['cnt]) -> cnt space (i x) if ((x = ex.Cdr.Car.eval()) == Nil) { OutFile.space(); return One; } for (i = xInt(x); i > 0; --i) OutFile.space(); return x; # (print 'any ..) -> any print (x y) OutFile.print(y = (x = ex.Cdr).Car.eval()); while ((x = x.Cdr) instanceof Cell) { OutFile.space(); OutFile.print(y = x.Car.eval()); } return y; # (printsp 'any ..) -> any printsp (x y) x = ex.Cdr; do { OutFile.print(y = x.Car.eval()); OutFile.space(); } while ((x = x.Cdr) instanceof Cell); return y; # (println 'any ..) -> any println (x y) OutFile.print(y = (x = ex.Cdr).Car.eval()); while ((x = x.Cdr) instanceof Cell) { OutFile.space(); OutFile.print(y = x.Car.eval()); } OutFile.newline(); return y; # (flush) -> flg flush () return OutFile.Wr.checkError()? Nil : T; ############ net ############ # (port 'cnt) -> cnt port () try { ServerSocketChannel chan = ServerSocketChannel.open();; chan.socket().bind(new InetSocketAddress(evInt(ex.Cdr))); return new Number(new PicoLispReader(null, allocFd(), chan, SelectionKey.OP_ACCEPT).Fd); } catch (IOException e) {err(ex, null, e.toString());} return Nil; # (accept 'cnt) -> cnt | NIL accept (i x) if ((i = xInt(x = ex.Cdr.Car.eval())) < 0 || i >= InFiles.length || InFiles[i] == null || InFiles[i].Chan == null) err(ex, x, "Bad socket"); return (x = accept(ex, i)) == null? Nil : x; # (listen 'cnt1 ['cnt2]) -> cnt | NIL listen (i j x y) if ((i = xInt(y = (x = ex.Cdr).Car.eval())) < 0 || i >= InFiles.length || InFiles[i] == null || InFiles[i].Chan == null) err(ex, y, "Bad socket"); j = (y = x.Cdr.Car.eval()) == Nil? -1 : xInt(y); for (;;) { if (waitFd(ex, i, j) == 0) return Nil; if ((y = accept(ex, i)) != null) return y; } # (connect 'any 'cnt) -> cnt | NIL connect () try { SocketChannel chan = SocketChannel.open(); if (chan.connect(new InetSocketAddress(evString(ex.Cdr), evInt(ex.Cdr.Cdr)))) return mkSocket(chan); } catch (IOException e) {} return Nil; # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/ersatz/lib.l0000644000000000000000000014411012265263724015404 0ustar rootroot# 29nov13abu # (c) Software Lab. Alexander Burger (setq *OS (java (java "java.lang.System" "getProperty" "os.name"))) ############ lib.l ############ (de task (Key . Prg) (nond (Prg (del (assoc Key *Run) '*Run)) ((num? Key) (quit "Bad Key" Key)) ((assoc Key *Run) (push '*Run (conc (make (when (lt0 (link Key)) (link (+ (eval (pop 'Prg) 1))) ) ) (ifn (sym? (car Prg)) Prg (cons (cons 'job (cons (lit (make (while (atom (car Prg)) (link (cons (pop 'Prg) (eval (pop 'Prg) 1)) ) ) ) ) Prg ) ) ) ) ) ) ) (NIL (quit "Key conflict" Key)) ) ) (de timeout (N) (if2 N (assoc -1 *Run) (set (cdr @) (+ N)) (push '*Run (list -1 (+ N) '(bye))) (del @ '*Run) ) ) (de macro "Prg" (run (fill "Prg")) ) (de recur recurse (run (cdr recurse)) ) (de curry "Z" (let ("X" (pop '"Z") "Y" (pop '"Z") "P" (filter pat? "X")) (if2 "P" (diff "X" "P") (list "Y" (cons 'job (lit (env @)) (fill "Z" "P"))) (cons "Y" (fill "Z" "P")) (list "Y" (cons 'job (lit (env @)) "Z")) (cons "Y" "Z") ) ) ) (====) ### Definitions ### (de expr ("F") (set "F" (list '@ (list 'pass (box (getd "F")))) ) ) (de subr ("F") (set "F" (getd (cadr (cadr (getd "F")))) ) ) (de undef ("X" "C") (when (pair "X") (setq "C" (cdr "X") "X" (car "X")) ) (ifn "C" (prog1 (val "X") (set "X")) (prog1 (cdr (asoq "X" (val "C"))) (set "C" (delq (asoq "X" (val "C")) (val "C")) ) ) ) ) (de redef "Lst" (let ("Old" (car "Lst") "New" (name "Old")) (set "New" (getd "Old") "Old" "New" "Old" (fill (cdr "Lst") "Old") ) "New" ) ) (de daemon ("X" . Prg) (prog1 (nond ((pair "X") (or (pair (getd "X")) (expr "X")) ) ((pair (cdr "X")) (method (car "X") (cdr "X")) ) (NIL (method (car "X") (get (or (cddr "X") *Class) (cadr "X"))) ) ) (con @ (append Prg (cdr @))) ) ) (de patch ("Lst" "Pat" . "Prg") (bind (fish pat? "Pat") (recur ("Lst") (loop (cond ((match "Pat" (car "Lst")) (set "Lst" (run "Prg")) ) ((pair (car "Lst")) (recurse @) ) ) (NIL (cdr "Lst")) (T (atom (cdr "Lst")) (when (match "Pat" (cdr "Lst")) (con "Lst" (run "Prg")) ) ) (setq "Lst" (cdr "Lst")) ) ) ) ) (====) (de cache ("Var" "Str" . Prg) (nond ((setq "Var" (car (idx "Var" "Str" T))) (set "Str" "Str" "Str" (run Prg 1)) ) ((n== "Var" (val "Var")) (set "Var" (run Prg 1)) ) (NIL (val "Var")) ) ) (====) ### I/O ### (de tab (Lst . @) (for N Lst (let V (next) (and (gt0 N) (space (- N (length V)))) (prin V) (and (lt0 N) (args) (space (- 0 N (length V)))) ) ) (prinl) ) (de beep () (prin "^G") ) (de msg (X . @) (out 2 (print X) (pass prinl) (flush) ) X ) (de script (File . @) (load File) ) (de once Prg (unless (idx '*Once (file) T) (run Prg 1) ) ) (de pil @ (when (== "Pil" '"Pil") (call 'mkdir "-p" (setq "Pil" `(pack (sys "HOME") "/.pil/"))) ) (pass pack "Pil") ) # Temporary Files (de tmp @ (unless *Tmp (push '*Bye '(call 'rm "-r" *Tmp)) (call 'mkdir "-p" (setq *Tmp (pil "tmp/" *Pid "/"))) ) (pass pack *Tmp) ) ### List ### (de insert (N Lst X) (conc (cut (dec N) 'Lst) (cons X) Lst ) ) (de remove (N Lst) (conc (cut (dec N) 'Lst) (cdr Lst) ) ) (de place (N Lst X) (conc (cut (dec N) 'Lst) (cons X) (cdr Lst) ) ) (de uniq (Lst) (let R NIL (filter '((X) (not (idx 'R X T))) Lst ) ) ) (de group (Lst) (make (for X Lst (if (assoc (car X) (made)) (conc @ (cons (cdr X))) (link (list (car X) (cdr X))) ) ) ) ) ### Symbol ### (de qsym "Sym" (cons (val "Sym") (getl "Sym")) ) (de loc (S X) (if (and (str? X) (= S X)) X (and (pair X) (or (loc S (car X)) (loc S (cdr X)) ) ) ) ) (de local Lst (mapc zap Lst) ) (de import Lst (for Sym Lst (unless (== Sym (intern Sym)) (quit "Import conflict" Sym) ) ) ) ### OOP ### (de class Lst (let L (val (setq *Class (car Lst))) (def *Class (recur (L) (if (atom (car L)) (cdr Lst) (cons (car L) (recurse (cdr L))) ) ) ) ) ) (de object ("Sym" "Val" . @) (putl "Sym") (def "Sym" "Val") (while (args) (put "Sym" (next) (next)) ) "Sym" ) (de extend X (setq *Class (car X)) ) # Class variables (de var X (if (pair (car X)) (put (cdar X) (caar X) (cdr X)) (put *Class (car X) (cdr X)) ) ) (de var: X (apply meta X This) ) ### Math ### (de scl ("N" . "Prg") (if "Prg" (let *Scl "N" (run "Prg")) (setq *Scl "N") ) ) (de sqrt (N F) (cond ((lt0 N) (quit "Bad argument" N)) (N (and (num? F) (setq N (* N @))) (let (M 1 R 0) (while (>= N M) (setq M (>> -2 M)) ) (loop (if (> (inc 'R M) N) (dec 'R M) (dec 'N R) (inc 'R M) ) (setq R (>> 1 R) M (>> 2 M)) (T (=0 M)) ) (and F (> N R) (inc 'R)) R ) ) ) ) # (Knuth Vol.2, p.442) (de ** (X N) # N th power of X (if (ge0 N) (let Y 1 (loop (when (bit? 1 N) (setq Y (* Y X)) ) (T (=0 (setq N (>> 1 N))) Y ) (setq X (* X X)) ) ) 0 ) ) (de accu (Var Key Val) (when Val (if (assoc Key (val Var)) (con @ (+ Val (cdr @))) (push Var (cons Key Val)) ) ) ) ### Pretty Printing ### (de *PP T NIL if ifn when unless while until do case casq state for with catch finally ! setq default push bind job use let let? prog1 recur redef =: in out tab new ) (de *PP1 let let? for redef) (de *PP2 setq default) (de *PP3 if2) (de pretty (X N . @) (setq N (abs (space (or N 0)))) (while (args) (printsp (next)) ) (if (or (atom X) (>= 12 (size X))) (print X) (while (== 'quote (car X)) (prin "'") (pop 'X) ) (let Z X (prin "(") (cond ((and (pair (car X)) (> (size @) 12)) (pretty (pop 'X) (- -3 N)) ) ((memq (print (pop 'X)) *PP) (cond ((memq (car Z) *PP1) (if (and (pair (car X)) (pair (cdar X))) (when (>= 12 (size (car X))) (space) (print (pop 'X)) ) (space) (print (pop 'X)) (when (or (atom (car X)) (>= 12 (size (car X)))) (space) (print (pop 'X)) ) ) ) ((memq (car Z) *PP2) (inc 'N 3) (loop (prinl) (pretty (cadr X) N (car X)) (NIL (setq X (cddr X)) (space)) ) ) ((or (atom (car X)) (>= 12 (size (car X)))) (space) (print (pop 'X)) ) ) ) ((and (memq (car Z) *PP3) (>= 12 (size (head 2 X)))) (space) (print (pop 'X) (pop 'X)) ) ) (when X (loop (T (== Z X) (prin " .")) (T (atom X) (prin " . ") (print X)) (prinl) (pretty (pop 'X) (+ 3 N)) (NIL X) ) (space) ) (prin ")") ) ) ) (de pp ("X" C) (let *Dbg NIL (and (pair "X") (setq C (cdr "X"))) (prin "(") (printsp (if C 'dm 'de)) (prog1 (printsp "X") (setq "X" (if C (method (if (pair "X") (car "X") "X") C) (val "X") ) ) (cond ((atom "X") (prin ". ") (print "X")) ((atom (cdr "X")) (ifn (cdr "X") (print (car "X")) (print (car "X")) (prin " . ") (print @) ) ) (T (let Z "X" (print (pop '"X")) (loop (T (== Z "X") (prin " .")) (NIL "X") (T (atom "X") (prin " . ") (print "X") ) (prinl) (pretty (pop '"X") 3) ) (space) ) ) ) (prinl ")") ) ) ) (de show ("X" . @) (let *Dbg NIL (setq "X" (pass get "X")) (when (sym? "X") (print "X" (val "X")) (prinl) (maps '((X) (space 3) (if (atom X) (println X) (println (cdr X) (car X)) ) ) "X" ) ) "X" ) ) (de view (X Y) (let *Dbg NIL (if (=T Y) (let N 0 (recur (N X) (when X (recurse (+ 3 N) (cddr X)) (space N) (println (car X)) (recurse (+ 3 N) (cadr X)) ) ) ) (let Z X (loop (T (atom X) (println X)) (if (atom (car X)) (println '+-- (pop 'X)) (print '+---) (view (pop 'X) (append Y (cons (if X "| " " "))) ) ) (NIL X) (mapc prin Y) (T (== Z X) (println '*)) (println '|) (mapc prin Y) ) ) ) ) ) ### Assertions ### (de assert Prg (when *Dbg (cons (list 'unless (if (cdr Prg) (cons 'and Prg) (car Prg)) (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) ############ lib/misc.l ############ # *Allow *Tmp (de *Day . (Mon Tue Wed Thu Fri Sat Sun .)) (de *Mon . (Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec .)) (de *mon . (jan feb mar apr may jun jul aug sep oct nov dec .)) ### Locale ### (de *Ctry) (de *Lang) (de *Sep0 . ".") (de *Sep3 . ",") (de *CtryCode) (de *DateFmt @Y "-" @M "-" @D) (de *DayFmt "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") (de *MonFmt "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") (de locale (Ctry Lang . @) # "DE" "de" ["app/loc/" ..] (load (if (setq *Ctry Ctry) (pack "@loc/" @ ".l") "@loc/NIL.l")) (ifn (setq *Lang Lang) (for S (idx '*Uni) (set S S) ) (let L (sort (make ("loc" (pack "@loc/" Lang)) (while (args) ("loc" (pack (next) Lang)) ) ) ) (balance '*Uni L T) (for S L (set (car (idx '*Uni S)) (val S)) ) ) ) ) (de "loc" (F) (in F (use X (while (setq X (read)) (if (=T X) ("loc" (read)) (set (link @) (name (read))) ) ) ) ) ) ### String ### (de align (X . @) (pack (if (pair X) (mapcar '((X) (need X (chop (next)) " ")) X ) (need X (chop (next)) " ") ) ) ) (de center (X . @) (pack (if (pair X) (let R 0 (mapcar '((X) (let (S (chop (next)) N (>> 1 (+ X (length S)))) (prog1 (need (+ N R) S " ") (setq R (- X N)) ) ) ) X ) ) (let S (chop (next)) (need (>> 1 (+ X (length S))) S " ") ) ) ) ) (de wrap (Max Lst) (setq Lst (split Lst " " "^J")) (pack (make (while Lst (if (>= (length (car Lst)) Max) (link (pop 'Lst) "^J") (chain (make (link (pop 'Lst)) (loop (NIL Lst) (T (>= (+ (length (car Lst)) (sum length (made))) Max) (link "^J") ) (link " " (pop 'Lst)) ) ) ) ) ) ) ) ) ### Number ### (de pad (N Val) (pack (need N (chop Val) "0")) ) (de money (N Cur) (if Cur (pack (format N 2 *Sep0 *Sep3) " " Cur) (format N 2 *Sep0 *Sep3) ) ) (de round (N D) (if (> *Scl (default D 3)) (format (*/ N (** 10 (- *Scl D))) D *Sep0 *Sep3) (format N *Scl *Sep0 *Sep3) ) ) # Binary notation (de bin (X I) (cond ((num? X) (let (S (and (lt0 X) '-) L (& 1 X) A (cons 0 I)) (until (=0 (setq X (>> 1 X))) (at A (push 'L " ")) (push 'L (& 1 X)) ) (pack S L) ) ) ((setq X (filter '((C) (not (sp? C))) (chop X))) (let (S (and (= '- (car X)) (pop 'X)) N 0) (for C X (setq N (| (format C) (>> -1 N))) ) (if S (- N) N) ) ) ) ) # Octal notation (de oct (X I) (cond ((num? X) (let (S (and (lt0 X) '-) L (& 7 X) A (cons 0 I)) (until (=0 (setq X (>> 3 X))) (at A (push 'L " ")) (push 'L (& 7 X)) ) (pack S L) ) ) ((setq X (filter '((C) (not (sp? C))) (chop X))) (let (S (and (= '- (car X)) (pop 'X)) N 0) (for C X (setq N (| (format C) (>> -3 N))) ) (if S (- N) N) ) ) ) ) # Hexadecimal notation (de hex (X I) (cond ((num? X) (let (S (and (lt0 X) '-) L (hex1 X) A (cons 0 I)) (until (=0 (setq X (>> 4 X))) (at A (push 'L " ")) (push 'L (hex1 X)) ) (pack S L) ) ) ((setq X (filter '((C) (not (sp? C))) (chop X))) (let (S (and (= '- (car X)) (pop 'X)) N 0) (for C X (setq C (- (char C) `(char "0"))) (and (> C 9) (dec 'C 7)) (and (> C 22) (dec 'C 32)) (setq N (| C (>> -4 N))) ) (if S (- N) N) ) ) ) ) (de hex1 (N) (let C (& 15 N) (and (> C 9) (inc 'C 7)) (char (+ C `(char "0"))) ) ) ### Tree ### (de balance ("Var" "Lst" "Flg") (unless "Flg" (set "Var")) (let "Len" (length "Lst") (recur ("Lst" "Len") (unless (=0 "Len") (let ("N" (>> 1 (inc "Len")) "L" (nth "Lst" "N")) (idx "Var" (car "L") T) (recurse "Lst" (dec "N")) (recurse (cdr "L") (- "Len" "N")) ) ) ) ) ) (de depth (Idx) #> (max . average) (let (C 0 D 0 N 0) (cons (recur (Idx N) (ifn Idx 0 (inc 'C) (inc 'D (inc 'N)) (inc (max (recurse (cadr Idx) N) (recurse (cddr Idx) N) ) ) ) ) (or (=0 C) (*/ D C)) ) ) ) ### Allow ### (de allowed Lst (setq *Allow (cons NIL (car Lst))) (balance *Allow (sort (cdr Lst))) ) (de allow (X Flg) (nond (*Allow) (Flg (idx *Allow X T)) ((member X (cdr *Allow)) (queue '*Allow X)) ) X ) ### Telephone ### (de telStr (S) (cond ((not S)) ((and *CtryCode (pre? (pack *CtryCode " ") S)) (pack 0 (cdddr (chop S))) ) (T (pack "+" S)) ) ) (de expTel (S) (setq S (make (for (L (chop S) L) (ifn (sub? (car L) " -") (link (pop 'L)) (let F NIL (loop (and (= '- (pop 'L)) (on F)) (NIL L) (NIL (sub? (car L) " -") (link (if F '- " ")) ) ) ) ) ) ) ) (cond ((= "+" (car S)) (pack (cdr S))) ((head '("0" "0") S) (pack (cddr S)) ) ((and *CtryCode (= "0" (car S))) (pack *CtryCode " " (cdr S)) ) ) ) ### Date ### # ISO date (de dat$ (Dat C) (when (date Dat) (pack (car @) C (pad 2 (cadr @)) C (pad 2 (caddr @))) ) ) (de $dat (S C) (if C (and (= 3 (length (setq S (split (chop S) C))) ) (date (format (car S)) # Year (or (format (cadr S)) 0) # Month (or (format (caddr S)) 0) ) ) # Day (and (format S) (date (/ @ 10000) # Year (% (/ @ 100) 100) # Month (% @ 100) ) ) ) ) (de datSym (Dat) (when (date Dat) (pack (pad 2 (caddr @)) (get *mon (cadr @)) (pad 2 (% (car @) 100)) ) ) ) # Localized (de datStr (D F) (when (setq D (date D)) (let (@Y (if F (pad 2 (% (car D) 100)) (pad 4 (car D))) @M (pad 2 (cadr D)) @D (pad 2 (caddr D)) ) (pack (fill *DateFmt)) ) ) ) (de strDat (S) (use (@Y @M @D) (and (match *DateFmt (chop S)) (date (format @Y) (or (format @M) 0) (or (format @D) 0) ) ) ) ) (de expDat (S) (use (@Y @M @D X) (unless (match *DateFmt (setq S (chop S))) (if (or (cdr (setq S (split S "."))) (>= 2 (length (car S))) ) (setq @D (car S) @M (cadr S) @Y (caddr S) ) (setq @D (head 2 (car S)) @M (head 2 (nth (car S) 3)) @Y (nth (car S) 5) ) ) ) (and (setq @D (format @D)) (date (nond (@Y (car (date (date)))) ((setq X (format @Y))) ((>= X 100) (+ X (* 100 (/ (car (date (date))) 100)) ) ) (NIL X) ) (nond (@M (cadr (date (date)))) ((setq X (format @M)) 0) ((n0 X) (cadr (date (date)))) (NIL X) ) @D ) ) ) ) # Day of the week (de day (Dat Lst) (get (or Lst *DayFmt) (inc (% (inc Dat) 7)) ) ) # Week of the year (de week (Dat) (let W (- (_week Dat) (_week (date (car (date Dat)) 1 4)) -1 ) (if (=0 W) 53 W) ) ) (de _week (Dat) (/ (- Dat (% (inc Dat) 7)) 7) ) # Last day of month (de ultimo (Y M) (dec (if (= 12 M) (date (inc Y) 1 1) (date Y (inc M) 1) ) ) ) ### Time ### (de tim$ (Tim F) (when Tim (setq Tim (time Tim)) (pack (pad 2 (car Tim)) ":" (pad 2 (cadr Tim)) (and F ":") (and F (pad 2 (caddr Tim))) ) ) ) (de $tim (S) (setq S (split (chop S) ":")) (unless (or (cdr S) (>= 2 (length (car S)))) (setq S (list (head 2 (car S)) (head 2 (nth (car S) 3)) (nth (car S) 5) ) ) ) (when (format (car S)) (time @ (or (format (cadr S)) 0) (or (format (caddr S)) 0) ) ) ) (de stamp (Dat Tim) (and (=T Dat) (setq Dat (date T))) (default Dat (date) Tim (time T)) (pack (dat$ Dat "-") " " (tim$ Tim T)) ) (de dirname (F) (pack (flip (member '/ (flip (chop F))))) ) (de basename (F) (pack (stem (chop F) '/)) ) # Print or eval (de prEval (Prg Ofs) (default Ofs 1) (for X Prg (if (atom X) (prinl (eval X Ofs)) (eval X Ofs) ) ) ) # Echo here-documents (de here (S) (line) (echo S) ) # Unit tests (de test (Pat . Prg) (bind (fish pat? Pat) (unless (match Pat (run Prg 1)) (msg Prg) (quit "'test' failed" Pat) ) ) ) ############ lib/pilog.l ############ # *Rule (de be CL (clause CL) ) (de clause (CL) (with (car CL) (if (== *Rule This) (queue (:: T) (cdr CL)) (=: T (cons (cdr CL))) (setq *Rule This) ) This ) ) (de repeat () (conc (get *Rule T) (get *Rule T)) ) (de asserta (CL) (push (prop CL 1 T) (cdr CL)) ) (de assertz (CL) (queue (prop CL 1 T) (cdr CL)) ) (de retract (X) (if (sym? X) (put X T) (put (car X) T (delete (cdr X) (get (car X) T)) ) ) ) (de rules @ (while (args) (let S (next) (for ((N . L) (get S T) L) (prin N " (be ") (print S) (for X (pop 'L) (space) (print X) ) (prinl ")") (T (== L (get S T)) (println '(repeat)) ) ) S ) ) ) ### Pilog Interpreter ### (de goal ("CL" . @) (let "Env" '(T) (while (args) (push '"Env" (cons (cons 0 (next)) 1 (next)) ) ) (while (and "CL" (pat? (car "CL"))) (push '"Env" (cons (cons 0 (pop '"CL")) (cons 1 (eval (pop '"CL"))) ) ) ) (cons (cons (conc (list 1 (0) NIL "CL" NIL) "Env") ) ) ) ) (de fail () (goal '((NIL))) ) (de pilog ("CL" . "Prg") (for ("Q" (goal "CL") (prove "Q")) (bind @ (run "Prg")) ) ) (de solve ("CL" . "Prg") (make (if "Prg" (for ("Q" (goal "CL") (prove "Q")) (link (bind @ (run "Prg"))) ) (for ("Q" (goal "CL") (prove "Q")) (link @) ) ) ) ) (de query ("Q" "Dbg") (use "R" (loop (NIL (prove "Q" "Dbg")) (T (=T (setq "R" @)) T) (for X "R" (space) (print (car X)) (print '=) (print (cdr X)) (flush) ) (T (line)) ) ) ) (de ? "CL" (let "L" (make (while (nor (pat? (car "CL")) (lst? (car "CL"))) (link (pop '"CL")) ) ) (query (goal "CL") "L") ) ) ### Basic Rules ### (be repeat) (repeat) (be true) (be not @P (1 (-> @P)) T (fail)) (be not @P) (be call @P (2 (cons (-> @P))) ) (be or @L (^ @C (box (-> @L))) (_or @C)) (be _or (@C) (3 (pop (-> @C)))) (be _or (@C) (^ @ (not (val (-> @C)))) T (fail)) (repeat) (be nil (@X) (^ @ (not (-> @X)))) (be equal (@X @X)) (be different (@X @X) T (fail)) (be different (@ @)) (be append (NIL @X @X)) (be append ((@A . @X) @Y (@A . @Z)) (append @X @Y @Z)) (be member (@X (@X . @))) (be member (@X (@ . @Y)) (member @X @Y)) (be delete (@A (@A . @Z) @Z)) (be delete (@A (@X . @Y) (@X . @Z)) (delete @A @Y @Z) ) (be permute ((@X) (@X))) (be permute (@L (@X . @Y)) (delete @X @L @D) (permute @D @Y) ) (be uniq (@B @X) (^ @ (not (idx (-> @B) (-> @X) T))) ) (be asserta (@C) (^ @ (asserta (-> @C)))) (be assertz (@C) (^ @ (assertz (-> @C)))) (be retract (@C) (2 (cons (-> @C))) (^ @ (retract (list (car (-> @C)) (cdr (-> @C))))) ) (be clause ("@H" "@B") (^ "@A" (get (-> "@H") T)) (member "@B" "@A") ) (be show (@X) (^ @ (show (-> @X)))) (be for (@N @End) (for @N 1 @End 1)) (be for (@N @Beg @End) (for @N @Beg @End 1)) (be for (@N @Beg @End @Step) (equal @N @Beg)) (be for (@N @Beg @End @Step) (^ @I (box (-> @Beg))) (_for @N @I @End @Step) ) (be _for (@N @I @End @Step) (^ @ (if (>= (-> @End) (val (-> @I))) (> (inc (-> @I) (-> @Step)) (-> @End)) (> (-> @End) (dec (-> @I) (-> @Step))) ) ) T (fail) ) (be _for (@N @I @End @Step) (^ @N (val (-> @I))) ) (repeat) (be val (@V . @L) (^ @V (apply get (-> @L))) T ) (be lst (@V . @L) (^ @Lst (box (apply get (-> @L)))) (_lst @V @Lst) ) (be _lst (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) (be _lst (@Val @Lst) (^ @Val (pop (-> @Lst)))) (repeat) (be map (@V . @L) (^ @Lst (box (apply get (-> @L)))) (_map @V @Lst) ) (be _map (@Val @Lst) (^ @ (not (val (-> @Lst)))) T (fail)) (be _map (@Val @Lst) (^ @Val (prog1 (val (-> @Lst)) (pop (-> @Lst))))) (repeat) (be isa (@Typ . @L) (^ @ (or (not (-> @Typ)) (isa (-> @Typ) (apply get (-> @L))) ) ) ) (be same (@V . @L) (^ @ (let V (-> @V) (or (not V) (let L (-> @L) ("same" (car L) (cdr L)) ) ) ) ) ) (de "same" (X L) (cond ((not L) (if (atom X) (= V X) (member V X) ) ) ((atom X) ("same" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("same" (get Y (car L)) (cdr L))) X ) ) (T ("same" (apply get (car L) X) (cdr L))) ) ) (be bool (@F . @L) (^ @ (or (not (-> @F)) (apply get (-> @L)) ) ) ) (be range (@N . @L) (^ @ (let N (-> @N) (or (not N) (let L (-> @L) ("range" (car L) (cdr L)) ) ) ) ) ) (de "range" (X L) (cond ((not L) (if (atom X) (or (<= (car N) X (cdr N)) (>= (car N) X (cdr N)) ) (find '((Y) (or (<= (car N) Y (cdr N)) (>= (car N) Y (cdr N)) ) ) X ) ) ) ((atom X) ("range" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("range" (get Y (car L)) (cdr L))) X ) ) (T ("range" (apply get (car L) X) (cdr L))) ) ) (be head (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) ("head" (car L) (cdr L)) ) ) ) ) ) (de "head" (X L) (cond ((not L) (if (atom X) (pre? S X) (find '((Y) (pre? S Y)) X) ) ) ((atom X) ("head" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("head" (get Y (car L)) (cdr L))) X ) ) (T ("head" (apply get (car L) X) (cdr L))) ) ) (be fold (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) ("fold" (car L) (cdr L)) ) ) ) ) ) (de "fold" (X L) (cond ((not L) (let P (fold S) (if (atom X) (pre? P (fold X)) (find '((Y) (pre? P (fold Y))) X) ) ) ) ((atom X) ("fold" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("fold" (get Y (car L)) (cdr L))) X ) ) (T ("fold" (apply get (car L) X) (cdr L))) ) ) (be part (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) ("part" (car L) (cdr L)) ) ) ) ) ) (de "part" (X L) (cond ((not L) (let P (fold S) (if (atom X) (sub? P (fold X)) (find '((Y) (sub? P (fold Y))) X) ) ) ) ((atom X) ("part" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("part" (get Y (car L)) (cdr L))) X ) ) (T ("part" (apply get (car L) X) (cdr L))) ) ) (be tolr (@S . @L) (^ @ (let S (-> @S) (or (not S) (let L (-> @L) ("tolr" (car L) (cdr L)) ) ) ) ) ) (de "tolr" (X L) (cond ((not L) (if (atom X) (or (sub? S X) (pre? (ext:Snx S) (ext:Snx X))) (let P (ext:Snx S) (find '((Y) (or (sub? S Y) (pre? P (ext:Snx Y))) ) X ) ) ) ) ((atom X) ("tolr" (get X (car L)) (cdr L)) ) ((atom (car L)) (pick '((Y) ("tolr" (get Y (car L)) (cdr L))) X ) ) (T ("tolr" (apply get (car L) X) (cdr L))) ) ) (be _remote ((@Obj . @)) (^ @ (not (val (-> @Sockets 2)))) T (fail) ) (be _remote ((@Obj . @)) (^ @Obj (let (Box (-> @Sockets 2) Lst (val Box)) (rot Lst) (loop (T ((cdar Lst)) @) (NIL (set Box (setq Lst (cdr Lst)))) ) ) ) ) (repeat) ############ lib/xm.l ############ # Check or write header (de xml? (Flg) (if Flg (prinl "") (skip) (prog1 (head '("<" "?" "x" "m" "l") (till ">")) (char) ) ) ) # Generate/Parse XML data (de xml (Lst N) (if Lst (let Tag (pop 'Lst) (space (default N 0)) (prin "<" Tag) (for X (pop 'Lst) (prin " " (car X) "=\"") (escXml (cdr X)) (prin "\"") ) (nond (Lst (prinl "/>")) ((or (cdr Lst) (pair (car Lst))) (prin ">") (escXml (car Lst)) (prinl "") ) (NIL (prinl ">") (for X Lst (if (pair X) (xml X (+ 3 N)) (space (+ 3 N)) (escXml X) (prinl) ) ) (space N) (prinl "") ) ) ) (skip) (unless (= "<" (char)) (quit "Bad XML") ) (_xml (till " /<>" T)) ) ) (de _xml (Tok) (use X (make (link (intern Tok)) (let L (make (loop (NIL (skip) (quit "XML parse error")) (T (member @ '`(chop "/>"))) (NIL (setq X (intern (till "=" T)))) (char) (unless (= "\"" (char)) (quit "XML parse error" X) ) (link (cons X (pack (xmlEsc (till "\""))))) (char) ) ) (if (= "/" (char)) (prog (char) (and L (link L))) (link L) (loop (NIL (skip) (quit "XML parse error" Tok)) (T (and (= "<" (setq X (char))) (= "/" (peek))) (char) (unless (= Tok (till " /<>" T)) (quit "Unbalanced XML" Tok) ) (char) ) (if (= "<" X) (and (_xml (till " /<>" T)) (link @)) (link (pack (xmlEsc (trim (cons X (till "^J<"))))) ) ) ) ) ) ) ) ) (de xmlEsc (L) (use (@X @Z) (make (while L (ifn (match '("&" @X ";" @Z) L) (link (pop 'L)) (link (cond ((= @X '`(chop "quot")) "\"") ((= @X '`(chop "amp")) "&") ((= @X '`(chop "lt")) "<") ((= @X '`(chop "gt")) ">") ((= @X '`(chop "apos")) "'") ((= "#" (car @X)) (char (if (= "x" (cadr @X)) (hex (cddr @X)) (format (cdr @X)) ) ) ) (T @X) ) ) (setq L @Z) ) ) ) ) ) (de escXml (X) (for C (chop X) (if (member C '`(chop "\"&<")) (prin "&#" (char C) ";") (prin C) ) ) ) # Access functions (de body (Lst . @) (while (and (setq Lst (cddr Lst)) (args)) (setq Lst (assoc (next) Lst)) ) Lst ) (de attr (Lst Key . @) (while (args) (setq Lst (assoc Key (cddr Lst)) Key (next) ) ) (cdr (assoc Key (cadr Lst))) ) ############ lib/xmlrpc.l ############ # (xmlrpc "localhost" 8080 "foo.bar" 'int 41 'string "abc" ..) (de xmlrpc (Host Port Meth . @) (let? Sock (connect Host Port) (let Xml (tmp 'xmlrpc) (out Xml (xml? T) (xml (list 'methodCall NIL (list 'methodName NIL Meth) (make (link 'params NIL) (while (args) (link (list 'param NIL (list 'value NIL (list (next) NIL (next))) ) ) ) ) ) ) ) (prog1 (out Sock (prinl "POST /RPC2 HTTP/1.0^M") (prinl "Host: " Host "^M") (prinl "User-Agent: PicoLisp^M") (prinl "Content-Type: text/xml^M") (prinl "Accept-Charset: utf-8^M") (prinl "Content-Length: " (car (info Xml)) "^M") (prinl "^M") (in Xml (echo)) (flush) (in Sock (while (line)) (let? L (and (xml?) (xml)) (when (== 'methodResponse (car L)) (xmlrpcValue (car (body L 'params 'param 'value)) ) ) ) ) ) (close Sock) ) ) ) ) (de xmlrpcKey (Str) (or (format Str) (intern Str)) ) (de xmlrpcValue (Lst) (let X (caddr Lst) (casq (car Lst) (string X) ((i4 int) (format X)) (boolean (= "1" X)) (double (format X *Scl)) (array (when (== 'data (car X)) (mapcar '((L) (and (== 'value (car L)) (xmlrpcValue (caddr L))) ) (cddr X) ) ) ) (struct (extract '((L) (when (== 'member (car L)) (cons (xmlrpcKey (caddr (assoc 'name L))) (xmlrpcValue (caddr (assoc 'value L))) ) ) ) (cddr Lst) ) ) ) ) ) ############ lib/http.l ############ ### HTTP-Client ### (de client (Host Port How . Prg) (let? Sock (connect Host Port) (prog1 (out Sock (if (atom How) (prinl "GET /" How " HTTP/1.0^M") (prinl "POST /" (car How) " HTTP/1.0^M") (prinl "Content-Length: " (size (cdr How)) "^M") ) (prinl "User-Agent: PicoLisp^M") (prinl "Host: " Host "^M") (prinl "Accept-Charset: utf-8^M") (prinl "^M") (and (pair How) (prin (cdr @))) (flush) (in Sock (run Prg 1)) ) (close Sock) ) ) ) ############ Native Java ############ (de javac (Cls Ext Impl . @) (let (J (pack "tmp/" Cls ".java") C (pack "tmp/" Cls ".class")) (call 'mkdir "-p" "tmp/") (out J (while (args) (prinl "import " (next) ";") ) (prinl "public class " Cls (and Ext (pack " extends " @)) (and Impl (pack " implements " (glue ", " Impl))) " {" ) (here "/**/") (prinl "}") ) (call "javac" "-O" "-g:none" J) (push1 '*Bye (list 'call "rm" J C)) ) ) ### Debug ### `*Dbg ############ lib/debug.l ############ # Prompt (de *Prompt (unless (== (symbols) 'pico) (symbols)) ) # Browsing (de doc (Sym Browser) (call (or Browser (sys "BROWSER") 'w3m) (pack "file:" (and (= `(char '/) (char (path "@"))) "//") (path "@doc/ref") (if Sym (let (L (chop Sym) C (car L)) (and (member C '("*" "+")) (cadr L) (setq C @) ) (cond ((>= "Z" C "A")) ((>= "z" C "a") (setq C (uppc C))) (T (setq C "_")) ) (pack C ".html#" Sym) ) ".html" ) ) ) ) (de more ("M" "Fun") (let *Dbg NIL (if (pair "M") ((default "Fun" print) (pop '"M")) (println (type "M")) (setq "Fun" (list '(X) (list 'pp 'X (lit "M"))) "M" (mapcar car (filter pair (val "M"))) ) ) (loop (flush) (T (atom "M") (prinl)) (T (line) T) ("Fun" (pop '"M")) ) ) ) (de what (S) (let *Dbg NIL (setq S (chop S)) (filter '(("X") (match S (chop "X"))) (all) ) ) ) (de who ("X" . "*Prg") (let (*Dbg NIL "Who" '("Who" @ @@ @@@)) (make (mapc "who" (all))) ) ) (de "who" ("Y") (unless (or (ext? "Y") (memq "Y" "Who")) (push '"Who" "Y") (ifn (= `(char "+") (char "Y")) (and (pair (val "Y")) ("nest" @) (link "Y")) (for "Z" (pair (val "Y")) (if (atom "Z") (and ("match" "Z") (link "Y")) (when ("nest" (cdr "Z")) (link (cons (car "Z") "Y")) ) ) ) (maps '(("Z") (if (atom "Z") (and ("match" "Z") (link "Y")) (when ("nest" (car "Z")) (link (cons (cdr "Z") "Y")) ) ) ) "Y" ) ) ) ) (de "nest" ("Y") ("nst1" "Y") ("nst2" "Y") ) (de "nst1" ("Y") (let "Z" (setq "Y" (strip "Y")) (loop (T (atom "Y") (and (sym? "Y") ("who" "Y"))) (and (sym? (car "Y")) ("who" (car "Y"))) (and (pair (car "Y")) ("nst1" @)) (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) (de "nst2" ("Y") (let "Z" (setq "Y" (strip "Y")) (loop (T (atom "Y") ("match" "Y")) (T (or ("match" (car "Y")) ("nst2" (car "Y"))) T ) (T (== "Z" (setq "Y" (cdr "Y")))) ) ) ) (de "match" ("D") (and (cond ((str? "X") (and (str? "D") (= "X" "D"))) ((sym? "X") (== "X" "D")) (T (match "X" "D")) ) (or (not "*Prg") (let *Dbg (up 2 *Dbg) (run "*Prg")) ) ) ) (de can (X) (let *Dbg NIL (extract '(("Y") (and (= `(char "+") (char "Y")) (asoq X (val "Y")) (cons X "Y") ) ) (all) ) ) ) # Class dependencies (de dep ("C") (let *Dbg NIL (dep1 0 "C") (dep2 3 "C") "C" ) ) (de dep1 (N "C") (for "X" (type "C") (dep1 (+ 3 N) "X") ) (space N) (println "C") ) (de dep2 (N "C") (for "X" (all) (when (and (= `(char "+") (char "X")) (memq "C" (type "X")) ) (space N) (println "X") (dep2 (+ 3 N) "X") ) ) ) # Inherited methods (de methods (Obj) (make (let Mark NIL (recur (Obj) (for X (val Obj) (nond ((pair X) (recurse X)) ((memq (car X) Mark) (link (cons (car X) Obj)) (push 'Mark (car X)) ) ) ) ) ) ) ) # Single-Stepping (de _dbg (Lst) (or (atom (car Lst)) (num? (caar Lst)) (flg? (caar Lst)) (== '! (caar Lst)) (set Lst (cons '! (car Lst))) ) ) (de _dbg2 (Lst) (map '((L) (if (and (pair (car L)) (flg? (caar L))) (map _dbg (cdar L)) (_dbg L) ) ) Lst ) ) (de dbg (Lst) (when (pair Lst) (casq (pop 'Lst) ((case casq state) (_dbg Lst) (for L (cdr Lst) (map _dbg (cdr L)) ) ) ((cond nond) (for L Lst (map _dbg L) ) ) (quote (when (fun? Lst) (map _dbg (cdr Lst)) ) ) ((job use let let? recur) (map _dbg (cdr Lst)) ) (loop (_dbg2 Lst) ) ((bind do) (_dbg Lst) (_dbg2 (cdr Lst)) ) (for (and (pair (car Lst)) (map _dbg (cdar Lst))) (_dbg2 (cdr Lst)) ) (T (map _dbg Lst)) ) T ) ) (de d () (let *Dbg NIL (dbg ^))) (de debug ("X" C) (ifn (traced? "X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (or (dbg (if C (method "X" C) (getd "X"))) (quit "Can't debug" "X") ) ) (untrace "X" C) (debug "X" C) (trace "X" C) ) ) (de ubg (Lst) (when (pair Lst) (map '((L) (when (pair (car L)) (when (== '! (caar L)) (set L (cdar L)) ) (ubg (car L)) ) ) Lst ) T ) ) (de u () (let *Dbg NIL (ubg ^))) (de unbug ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (or (ubg (if C (method "X" C) (getd "X"))) (quit "Can't unbug" "X") ) ) ) # Tracing (de traced? ("X" C) (setq "X" (if C (method "X" C) (getd "X") ) ) (and (pair "X") (pair (cadr "X")) (== '$ (caadr "X")) ) ) # Convert ((X Y) A B) --> ((X Y) ($ foo (X Y) A B)) (de trace ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (if C (unless (traced? "X" C) (or (method "X" C) (quit "Can't trace" "X")) (con @ (cons (conc (list '$ (cons "X" C) (car @)) (cdr @) ) ) ) ) (unless (traced? "X") (and (sym? (getd "X")) (quit "Can't trace" "X")) (and (num? (getd "X")) (expr "X")) (set "X" (list (car (getd "X")) (conc (list '$ "X") (getd "X")) ) ) ) ) "X" ) ) # Convert ((X Y) ($ foo (X Y) A B)) --> ((X Y) A B) (de untrace ("X" C) (let *Dbg NIL (when (pair "X") (setq C (cdr "X") "X" (car "X")) ) (if C (when (traced? "X" C) (con (method "X" C) (cdddr (cadr (method "X" C))) ) ) (when (traced? "X") (let X (set "X" (cddr (cadr (getd "X")))) (and (== '@ (pop 'X)) (= 1 (length X)) (= 2 (length (car X))) (== 'pass (caar X)) (sym? (cdadr X)) (subr "X") ) ) ) ) "X" ) ) (de *NoTrace @ @@ @@@ pp show more what who can dep d e debug u unbug trace untrace ) (de traceAll (Excl) (let *Dbg NIL (for "X" (all) (or (memq "X" Excl) (memq "X" *NoTrace) (= `(char "*") (char "X")) (cond ((= `(char "+") (char "X")) (mapc trace (extract '(("Y") (and (pair "Y") (fun? (cdr "Y")) (cons (car "Y") "X") ) ) (val "X") ) ) ) ((pair (getd "X")) (trace "X") ) ) ) ) ) ) # Process Listing (de proc @ (apply call (make (while (args) (link "-C" (next)))) 'ps "-H" "-o" "pid,ppid,start,size,pcpu,wchan,cmd" ) ) # Benchmarking (de bench Prg (let U (usec) (prog1 (run Prg 1) (out 2 (prinl (format (*/ (- (usec) U) 1000) 3) " sec" ) ) ) ) ) ############ lib/lint.l ############ (de noLint (X V) (if V (push1 '*NoLint (cons X V)) (or (memq X *NoLint) (push '*NoLint X)) ) ) (de global? (S) (or (memq S '(NIL ^ @ @@ @@@ This T)) (member (char S) '(`(char '*) `(char '+))) ) ) (de local? (S) (or (str? S) (member (char S) '(`(char '*) `(char '_))) ) ) (de dlsym? (S) (and (car (setq S (split (chop S) ':))) (cadr S) (low? (caar S)) ) ) (de lint1 ("X") (cond ((atom "X") (when (sym? "X") (cond ((memq "X" "*L") (setq "*Use" (delq "X" "*Use"))) ((local? "X") (lint2 (val "X"))) (T (or (getd "X") (global? "X") (member (cons "*X" "X") *NoLint) (memq "X" "*Bnd") (push '"*Bnd" "X") ) ) ) ) ) ((num? (car "X"))) (T (casq (car "X") ((: ::)) (; (lint1 (cadr "X"))) (quote (let F (fun? (cdr "X")) (if (or (and (pair F) (not (fin @))) (== '@ F)) (use "*L" (lintFun (cdr "X"))) (lint2 (cdr "X")) ) ) ) ((de dm) (let "*X" (cadr "X") (lintFun (cddr "X")) ) ) (recur (let recurse (cdr "X") (lintFun recurse) ) ) (task (lint1 (cadr "X")) (let "Y" (cddr "X") (use "*L" (while (num? (car "Y")) (pop '"Y") ) (while (and (car "Y") (sym? @)) (lintVar (pop '"Y")) (pop '"Y") ) (mapc lint1 "Y") ) ) ) (let? (use "*L" (lintVar (cadr "X")) (mapc lint1 (cddr "X")) ) ) (let (use "*L" (if (atom (cadr "X")) (lintVar (cadr "X")) (for (L (cadr "X") L (cddr L)) (lintDup (car L) (extract '((X F) (and F X)) (cddr L) '(T NIL .) ) ) (lintVar (car L)) (lint1 (cadr L)) ) ) (mapc lint1 (cddr "X")) ) ) (use (use "*L" (if (atom (cadr "X")) (lintVar (cadr "X")) (mapc lintVar (cadr "X")) ) (mapc lint1 (cddr "X")) ) ) (for (use "*L" (let "Y" (cadr "X") (cond ((atom "Y") # (for X (1 2 ..) ..) (lint1 (caddr "X")) (lintVar "Y") (lintLoop (cdddr "X")) ) ((atom (cdr "Y")) # (for (I . X) (1 2 ..) ..) (lintVar (car "Y")) (lint1 (caddr "X")) (lintVar (cdr "Y")) (lintLoop (cdddr "X")) ) ((atom (car "Y")) # (for (X (1 2 ..) ..) ..) (lint1 (cadr "Y")) (lintVar (car "Y")) (mapc lint1 (cddr "Y")) (lintLoop (cddr "X")) ) (T # (for ((I . L) (1 2 ..) ..) ..) (lintVar (caar "Y")) (lint1 (cadr "Y")) (lintVar (cdar "Y")) (mapc lint1 (cddr "Y")) (lintLoop (cddr "X")) ) ) ) ) ) ((case casq state) (lint1 (cadr "X")) (for "X" (cddr "X") (mapc lint1 (cdr "X")) ) ) ((cond nond) (for "X" (cdr "X") (mapc lint1 "X") ) ) (loop (lintLoop (cdr "X")) ) (do (lint1 (cadr "X")) (lintLoop (cddr "X")) ) (=: (lint1 (last (cddr "X"))) ) ((dec inc pop push push1 queue fifo val idx accu) (_lintq '(T)) ) ((cut port) (_lintq '(NIL T)) ) (set (_lintq '(T NIL .)) ) (xchg (_lintq '(T T .)) ) (T (cond ((pair (car "X")) (lint1 @) (mapc lint2 (cdr "X")) ) ((memq (car "X") "*L") (setq "*Use" (delq (car "X") "*Use")) (mapc lint2 (cdr "X")) ) ((fun? (val (car "X"))) (if (num? @) (mapc lint1 (cdr "X")) (when (local? (car "X")) (lint2 (val (car "X"))) ) (let "Y" (car (getd (pop '"X"))) (while (and (pair "X") (pair "Y")) (lint1 (pop '"X")) (pop '"Y") ) (if (or (== '@ "Y") (= "Prg" "Y") (= "*Prg" "Y")) (mapc lint1 "X") (lint2 "X") ) ) ) ) (T (or (str? (car "X")) (dlsym? (car "X")) (== '@ (car "X")) (memq (car "X") *NoLint) (memq (car "X") "*Def") (push '"*Def" (car "X")) ) (mapc lint1 (cdr "X")) ) ) ) ) ) ) ) (de lint2 (X Mark) (cond ((memq X Mark)) ((atom X) (and (memq X "*L") (setq "*Use" (delq X "*Use"))) ) (T (lint2 (car X)) (lint2 (cdr X) (cons X Mark)) ) ) ) (de lintVar (X Flg) (cond ((or (not (sym? X)) (memq X '(NIL ^ meth quote T))) (push '"*Var" X) ) ((not (global? X)) (or Flg (member (cons "*X" X) *NoLint) (memq X "*Use") (push '"*Use" X) ) (push '"*L" X) ) ) ) (de lintDup (X Lst) (and (memq X Lst) (not (member (cons "*X" X) *NoLint)) (push '"*Dup" X) ) ) (de lintLoop ("Lst") (for "Y" "Lst" (if (and (pair "Y") (or (=T (car "Y")) (not (car "Y")))) (mapc lint1 (cdr "Y")) (lint1 "Y") ) ) ) (de _lintq (Lst) (mapc '((X Flg) (lint1 (if Flg (strip X) X)) ) (cdr "X") Lst ) ) (de lintFun ("Lst") (let "A" (and (pair "Lst") (car "Lst")) (while (pair "A") (lintDup (car "A") (cdr "A")) (lintVar (pop '"A") T) ) (when "A" (lintVar "A") ) (mapc lint1 (cdr "Lst")) ) ) (de lint ("X" "C") (let ("*L" NIL "*Var" NIL "*Dup" NIL "*Def" NIL "*Bnd" NIL "*Use" NIL) (when (pair "X") (setq "C" (cdr "X") "X" (car "X")) ) (cond ("C" # Method (let "*X" (cons "X" "C") (lintFun (method "X" "C")) ) ) ((pair (val "X")) # Function (let "*X" "X" (lintFun (val "X")) ) ) ((info "X") # File name (let "*X" "X" (in "X" (while (read) (lint1 @))) ) ) (T (quit "Can't lint" "X")) ) (when (or "*Var" "*Dup" "*Def" "*Bnd" "*Use") (make # Bad variables (and "*Var" (link (cons 'var "*Var"))) # Duplicate parameters (and "*Dup" (link (cons 'dup "*Dup"))) # Undefined functions (and "*Def" (link (cons 'def "*Def"))) # Unbound variables (and "*Bnd" (<> `(char '_) (char "X")) (link (cons 'bnd "*Bnd"))) # Unused variables (and "*Use" (link (cons 'use "*Use"))) ) ) ) ) (de lintAll @ (let *Dbg NIL (make (for "X" (all) (cond ((= `(char "+") (char "X")) (for "Y" (val "X") (and (pair "Y") (fun? (cdr "Y")) (lint (car "Y") "X") (link (cons (cons (car "Y") "X") @)) ) ) ) ((and (not (global? "X")) (pair (getd "X")) (lint "X")) (link (cons "X" @)) ) ) ) (while (args) (and (lint (next)) (link (cons (arg) @))) ) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/ersatz/mkJar0000755000000000000000000000574412265263724015464 0ustar rootroot#!./pil # 17jul12abu # (c) Software Lab. Alexander Burger (load "../src64/version.l") # Build Ersatz PicoLisp (de declLocal (Vars Typ Lst) (when (filter '((S) (memq S Lst)) Vars) (prinl " " Typ " " (glue ", " @) ";") ) ) (out "PicoLisp.java" (in "sys.src" (echo "") (prin (glue "," *Version)) (echo "") (let Cnt (read) (in "fun.src" (skip "#") (loop (let Name (till " " T) (prinl "mkSymbol(new Number(\"" (inc 'Cnt) "\"), \"" Name "\", Pico);" ) ) (while (line)) (prin " ") (NIL (skip "#")) ) ) (prinl "MaxFun = " Cnt ";") (prin " ") ) (skip) (echo "") (let Cnt (read) (in "fun.src" (skip "#") (loop (let (Name (till " " T) Vars (read)) (line) (prinl "case " (inc 'Cnt) ": // " Name ) (if (=T Vars) (while (line) (prinl " " @) ) (prinl " " "return do" Cnt "(ex);") (while (line)) ) ) (prin " ") (NIL (skip "#")) ) ) ) (skip) (echo "") (let Cnt (read) (in "fun.src" (skip "#") (loop (inc 'Cnt) (let (Name (till " " T) Vars (read)) (line) (if (=T Vars) (while (line)) (prinl "final static Any do" Cnt "(Any ex) { // " Name ) (declLocal Vars "int" '(i j k)) (declLocal Vars "char" '(c)) (declLocal Vars "long" '(n)) (declLocal Vars "Any" '(w x y z lst)) (declLocal Vars "Symbol" '(s t)) (declLocal Vars "Number" '(num)) (declLocal Vars "String" '(str txt)) (declLocal Vars "StringBuilder" '(sb)) (declLocal Vars "Any[]" '(v)) (declLocal Vars "Bind" '(bnd)) (declLocal Vars "Object" '(o)) (while (line) (prinl " " @) ) (prinl " }") (prinl) (prin " ") ) ) (NIL (skip "#")) ) ) ) (skip) (echo) ) ) (when (call "javac" "-O" "-g:none" "PicoLisp.java") (let Lst (filter '((F) (tail '`(chop ".class") (chop F))) (dir)) (apply call Lst "jar" "cmf" "Manifest" "picolisp.jar") (apply call Lst "rm") ) ) (bye) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/ersatz/picolisp.jar0000644000000000000000000020163212265263724017004 0ustar rootrootPKpJ$D META-INF/PKPKpJ$DMETA-INF/MANIFEST.MFMLK-. K-*ϳR03r.JM,IMu +h)f&W+x%ir&f:$[)d&drrPK^P]]PKpJ$DPicoLisp$OutFrame.classuQMO@}CmqE/@0^5^&$$ps,b1mi$&(Iưɼ&f9бmӀ*Tvz9G ;n@(vj8ਫ਼h./O%ɁB'X i}5"PT R}#WC #H #5% $iMջÐPZҏ5zrތG\83! F.ίq;D M-5_z6G>cŮ̑yK e ,Lי-PK9#6PKpJ$DPicoLisp$Number.class̽|U>>3wfB^BRnAP4(k $&6 ] "(]qWWײڻe=g-v_s3s{>iZy"cXijNa҄y Czy0/%KCe+D p55n p3ۂD\h;;w17̍~ll ݃x x0Gm4_< ; x 6>|ǀO>C/_Bx-;? 3vvBdi``l8 "N@g@.        ( ŀ`8``$` (L&& 0?` `*4t3C3 8P 8 p4 Հ`!``1p` P4N4̀eU'N[ X 8 p6.\p1YylgYylgYylgYyluv:z@  gY0| g gYgY`,? ς`,? ς`,? ς`,? ς`,? ς`,? ς`,? ς`WxX 5a;zo;E{a} a}4B'O sD8s 57";NXdZr֏"`$1](,2r&7";sVʝbX9; lSؖma a; ;$0%#$lhKA\Ek~ cv7Dt'Vm2k=  Kܠh";G>!M!{`Pl l:/;d MNzŝveBp{DiU;&&`1jL I Ra{f~R9s!{lCTNeM | {=^9*yHzhи سsz.RؕG!}}} &K]ᓝ$gaW;vB"4b4Y KV KVz5P:hBk5u9r@f@uC FQ^LdI "Bx @O4!zr L 80 0p ] Lk5OSjZWXZռx̨kN,J4N5{RM]Mf6 N,)j]56AóE 6]EV-1nh4/ֵ`m}ݢ9U˨@ 烽(eTut-2.8)Ѥke3kԗ45 oR_ƢQWdfCc}e͵Q&r 2%WT@:zYPUЄg9͋)Uu}7iq4Ʊ4}`! HD)D9fxaW]?jFI/.鍖鍓xq=.eh/2w|'I'.'P'_J$IDrQ"(tJJO)DJ$3%3%ђhIe2ZR-TFK*%1Ie2FR#TH*cƑ$4F+ JBc%XIh$4V3VR+TI*$q8Ie2NR'e2xo7^/󍗥'd Ie2AR LkGѴ%/Qh!CGFMU8 @<b+_9J f_3J3Jf_0JxJ=*ɸ"W$d\+RqE :ξWtJDT(:%NS(:ъъhEo7ZVF+z1Eo7FQ(zc1Eo7VU*zc8?NŏSxU8U8UxUxUxUxEo7^W+z Eo7AћMP&(z q #G)?VU8WTJSWWWW+zJJJJJJJ%XEo7VS)zUW#G\q?UW#G\q?UzT$'0^W$zI\KJT/)QDKJ0@tUc?N㕯HR:J(%R:J(%R:J(%pGjhY戴⼣RgdLĉ0>kbA҆DX۵EM5'QІ$ŌUK)h'* +e>e*㠎30 e܉\s|ֵ3N͚(P5fvŲ?WHT4Zd$Ți|¥j1ѭYYvb)iqf<#k&,c#z31b|.Pl+$1>5>∈+ԵIQ7Ri+$k(}1hGc"=:r]y~C{ޱ8!*㓈X #"!GH5 P(bF;5ﲦDF!j"$"jH`8RccQ^,0I}L 80 0p Cer@PLaGT 8p XqUj@G{@$PKjP4N4̀eUPg;p 73gV 8p)2+W\ p-` :7n p+6u;pn={6lll<xQcO#I6S? x /g xEK^ Ukox]{>|c'O>|k7oOO~ N`j``l8 `L+3el0[&̖  `L:s΄3aLX;΄3aLX4̈́E3aLX432GF`L0Cf0d8x kfšf& kfšf& Cfa&l f†a&l f†a&l f|0_ll f†a&l f†a&l f†a&l &N4v؛f/n_};]F©u͍4 1ƈhM,ѵifD,#'` RS,M45U-"ҝ/"V"8 Jc4=5"NGbYc|3j3%36QUgu-9s1~"4Sȩ=RY}"KNj ą$,qQD\l.Kĥ$dꗑ#2q9]:ߦp'RQSS3еWR:Ăx?4"DĵbMD5vDL; q#q5"nG:>bowDĝwBqw{ĽBGq_Dl qpIl5b[\!/kqPU򪆈h4Lo = ăU<$x4"# "bԵ9blO>?Ag%ؘXTXSU7UT?sD_ij4;|E_(/"j]S?bz Ȗ^gGHUD׷]x]ӇGć⣈PXD|,(hB|_i4SVC-)>ETPK@M#&M $~̓""kD bG$` L #b':fC!41(qlGDLM0 M'%&V67VĔLMxė8@;u?SLZ4اvrr#yN)Nk&tG"kioE)%''N~Cs:"N< @@g3q`` (8{;C#N" t{ԣPN 1`n/aܿjUj+({$3u,8N, wFZW,[0ј>ھԕDHiL`qwDbK94ΙL8<yI@#PCS T̠ x(:o3zsX9ܙqf>;G gn9ҩ0 ` 0Hy{. 89>TuCZz2'u[qN'pWԂR$; 蝤#X 8NSi+#2gy\i ߠpyZ\3"[ 8 W tVW"I)[{sz9C*Lgu99;8y0tY)b4T56%f;2RǦUK56 zLgO[LS/7+h"oE4WgS}ҦUQS+DZUSK)diદfb%Ij4h6ҵ1̭K虷dHh4kq\VWXXS%[k} g/NX%b+p%'U]3yGkjye)s laQ9ijG]_̹S=,P-':[d\$/9̃ %B dWh!VɠPY0WrpgLwz3eRy,q@V54$0QQ& +$C`Z+gNCG4L΂fy{f(LwMfAςFYEY;yYMhmO.bF]SsU#)T&1,pפ {AW,o|ٍ%p9 I Izxʧg ]!hR1}w@׆duʤ{i!f!S8{V+YTny,i]:h^X7{UC"eaN}MT5ZzA]9Ĭz(M%fLӤ\V/ݨrLK fv'4Kݍ}n~FSt2=PgPc/:堪Z>iRkyfyn*<Sy’XN,Q< 7[KҝKMeΌ7 M yu 9eHtW)&&dj8֥ lKh>~Fj~60i4TaZg'Vҗj.YXG&Yu55 \t@M#ai]huF*- 3hVcNi&5(1#ֽ {I|sX.Zx9ަ 4ୠRJɨbn.c.A,+sM'[[Vʡد˚pd=S^hO'$˩QLe5%Ǎv=?PM˛H?l@?52]5y2VCSr{=3䊡iSO<6g/F'vZ! 6_KKO lpʍ(&x ή5k&jN]'*b~n\JnzQ&вl57Hc@)”\uXe݅Ǫ#YH@ꕻe˨oؗ_Q9El $~EqjUSBqU$S9З3QI4mOLnʫ0+ybk0d^Wv\ y.B+Δ3ZVWgO Ksvm}4̈ݑͬqS=,Fe*$kg%0s4s;L˔LBSCETK僧iz%Ok~U5|箟kEz"=]\"dNVtD&_ 4@/'`Դ} LDzfSb̌ݚ!$iW3K[`ZFl ۲Q&WĽ2h"Iq3lMrZ8`2Cٸ<(Tٵ"#)y[5ŸvO #_N~C&ި{; ]3B1U2M=nΑ#K_؅ɉꨬ]5̍Eu؏ ;w VpyEj͐ë1p+^|WX;⬣1e5|]ڮY^4O3\=f+E|hf'7l5MGO_h%,ܢ5>84WkA-@~3NFu ZE,ܪ\!2?w^6;`n/~pC.9I'olւF7&ՌvfS<~x<jj9f¢Lj04}Lq_JQa"\ɢ-Z#"Zg"D;+?h0~h'MoMZ)-LqV ^[w{Yy5w&8oXs^'Aʽss[svon\\3QP~*lrr2Hy]G/ZO6mqV֬]h{+Geqs vG?O!} $7"r#ɍ!WJn?rA,rG;|rՒ;.!w%5n$wȑJZ䶒{ܓ&{ܻ>"GY~!Slvu"G'9&m&m&m&m&m&m&m&m>rr';æzTaS=lM Gko$CwxwxI63'r5MP \\.zOn0a䆓+!7drLPrU;r-%HnSȝNlrU֒$wɵ#䶑{^&:wQAP:8TPCup:8TP}ȑ^9+#w9"w<Փk&oɝI\r5'G*Ο䈯 $W _A+H| $W _A+H| $W _A+H| $W _A+H|-֓=9u$(?#~ϑ{ܫ">}A[r$/|O"G云Gnr1rqrM"?!7 !BǑ&WC\~C r4`.$w]GfrȑCDr?{܋^!&Gr?\;hAr9互E/ %WLn&#އIäa0}>Lz&އIäa0}>Lz&އIäa0}>Lz& ?L rO 9=aaaᏊ6iyh  z}}7lڤ b|ܨ iCaB@xC^MަH(@P MhL&& 0?` `*4t3C3 8P 8 p4 Հ&ma*ݛ:ы58a/:@=p"h,,$۴r 7N8pLjY8pBE.\pW\ p-` `ODp=7n p;``=pNp^}-6[Ng0=Kڏ<x?l<πxீ/^e^xM[xCG>|s/_|{ W;; 0B0 tP:l:l:l:l љt`6X au` :,KX;:;:;:;:;:;:; go(/~\FsfyU6^h%6n_fb$jj>/=+lnZþo=eo`>{3oe1nnwlr?a[GivB&9w]&z}'b~(f?&Fc'&?ILeq3D9pg)fQ|Eb 2?Yib5g?_\% ײFVo-!bnqE+[V,o#O?xx[-g ⟂AKp;8Xrvpvp9Nn'p;8ng3iOwfPg:?©ds,9 دv_,eidYJ\Υ_\ZsnbfnqXC_a9:o;_ jAW +9 v +/  AW0dyAWp\dyӃ,!AWpf<" Y^ +Xdy,`S\dydyY^ ,eAW +x]9x;w=M6>#'C)d J {G3?~71 w !`9 ap!E fLx}/>|@}xF}"><+>|d}000pm}00algއ_f{2>&>|c}0all[lco ?3ῲ|=<_~'o0O< v[iu"AM>;ҳ. P~=ީS.o?okk-j R-֪er劗Jzx\F߯kӏ,ߦu΄~̆BJU?fsejgeةuɵk{i&ޟk!7H⮓˝&>豍ޒC׏[]Q?~\z&}~ e\jFmډQs`vIcXP[*ȏ+xߢ/h[-Z["z-w#j~~ivq\e9F;ԋYtџQ Z`6Nr^s$EӾ2zN9K͟] ۵<͢]c  v$z U Rpi`8ڽ׮uI `uPq^zM^O((3Y'geI*fh=cM/ r(5V*aGmQIQVm:DyR%[ڪm؆؆VD_lcjlcmNmn՗mї+hŮV}e*j'')NI8UM۴ }M-nӨ?̧dekq*t+ GÏN# P]&ZU3ϠNg&Ie]ʾ:}5u}ڟ|5>*YG!}҈"$k?ikREl(jT"QsC~Ni00d7h0G^[X?4Lx~iiOS8|'4d6^I}/Ц_0+ߨ_8O|4ȊV:6-TuzceB-2%"55xj/=w_E˩SdThկۦ_% ҶTC 3 :yʰQIh&VEHvmq86٫e1-١eZQ2:UU* ˨ YGB;eײ9=i,f4ϸJJ5{wR2Z 6)N&83)뒵k)2YsxTuLfm/Zm H~c4ܪߴEyCϘ?p(M\BQ!-8o- E;mo>:hK;Hǩ=O_gjߞfW—y6]΃Er],rҗ8wvm۸1vC>t5'[t; NZ*"Cg &?#8P3 #<;I0#߯8Z({pFBLFxoكV\rUa C3$s*S |Vmh̏!=FhBFoyoUmxezĦ  q$% :ެt+-1GWukNZ䦣_Y5 }uSrI[XPi1Y~qtH3vhaXDȳ&?x@l"{#GVQȖ=jO=m+&OӇ#SW6-v5jm99^"׼)MfI$-!F"'OL  zeQ<"nJ %q=bO"'jȧ>(O;DBp:N[j |[f-w-nIRCJ\?x['Cz*aڵ mޠf<;M ,-Ю&v9D!/?)bYKP`viӟiF$R.O3"`*d' 7&:+uҦqL-ed[+5Eˋ)毭==ns xXxtb U(&Q1= |FHTp PiFyꆊڨIS.*9eҍr;U;SM[Wڴ0zÈ꪿79vhed1&+r6VZF@rڤ&#vMS'w?$7j1cbNܴ;4ar'Do2b+ͻK0_}+ ԴyTў%R[ܨu'/謹ݪFmMF#ͪzjOkjqlCm*W`6k N?ԟi(59}L(:r$^ۈ&q~!O"N.L{@"8ӵ s,}IڵnvDg@w tҫQj8ڦ[Y"uH!ٍhvZS?Lzٟ#D9+FSq6f&4|Q(UG}34cIo[OZO[Hr-9ꟷ_VKBimkuM5pX bc}mljxlbȀ :uۡYX?n7˝(MԔV 9zQKw˙j᭯Tܹ^qa"[௻ HzޫxO9֩K7ʼnwh>īL&G lAmn,X_j>>)/EOqG$+ܨwϤDmwked5sR \7յu}Éeo il`V,4Ugp#?wUߵE,.D;>[vݰܠHKFZLu=ӔmJSjJT&&SS|)גZ[\{JAVt]GQȓSLh?ːL}Ǧk4sEm:E;۲9N])+fSibk5Z6Q?씐S"w;^%k%7l1a(g~u'zb{PEtçӶO6x_?g'[w'Cxm¤`d ü.TNP")+_d9slD/̖#С~gKIx?SSsw*}v(7REʳ Ns2𗷮yi]RHeENւHEfm^N B AS D7Hk5 "dwTؾ _JX氓hS͑)uϪRfO8Bu҅cDu(W.Zlp@&&T/ թP&TýI"ODxmf*e+yfeZln5ͫTEAFyEu{>ӽjx.j?KxAy2)5-C:4(ߠ$S& hr;8WP UMIhW90eu*YL҂i x UӋҌM'M`:Gm\ת[j~1~Mk2=C3,f׼ni2kPQ=F@.}r1q"ݍZBVuX4C4Lݘv|q'_J#C1oO c!_ۤV "/,~w{\u DK׺dJ='S%H1t0DN7vI˝OQ{@TȠ>zGMfn/3d׀ͬҎ_]O5:I~5n׸OK_!)G= !?Ij{'o:[KK{ W~(J9CQTP`Yڡ^iժ\6 ȏ)Ҝ"J,R)Jۦ? ǚ+3&P(b35cJ Y5]|`쾳H2^[_m׆P6K0C6[tT~-PNS_n&牅"0E@g҈# 3KJ iG{,f_ćpl[z1s[bB~zqmdؘ!n*ZV! E+*ϔfwqW$y;< 1p}&7ƝuKq_/rp)_/¿jr*u^t_ej3˥Eu-*n35Ive5{jQvYKGũ{ޙݯ]!RY6+YbM$oS!vT_Gt3uvW Aj̷`I}5t=.xg^f\[.$+<SWvt*0v3oy<}k5j/2OQwlZS*s<(MME}yei']`vGEqwJmK'iIsYi Tܪ8jUת؎뚥2u_̼pOX`;ѓW^QX*%صZG-){1M5c5X`d6ћ}Q?l5 Vc(Q$(w;P /t"piZ;zw\_6w5u,oQjФO:GJBJՂ $^+uJɽ1Óܕ+w#;ЧL2o@@p|uP;g]9y/ꖭH)q:+F랏m5J*+b4?3Rs1r1s [-Di'U۰|ߖ/d="R7ŁVcci'][Bʦ1$Ƙ8N,. EZwai /K K2{@1O%7Oz[,0Lmc]A.A)4k{4WI6++''t%jN!Ŭuw(0 Wxz+S|o3Ruh:HHݤNNrp1~3Fhb~6*0(v!|(X׺*Ɗ ۬_/;R ~A7|%zl??4&n':cgP){.홹o{H\l)raPq\;<6-cK:ܫA] k<Ui"@(o3OLȬ%2ץo< & RS+~&]ŘEvif@zii$c ~JϘEf0f171[9IlETQ,NX CVsع =Yޚ;R_Eå}?)${)8U?MըH;ʷiVFh oI_2~$(pCen8vSGL%dςǥQZ^SN ]^_Q_ 7yf(zEzI0U㐢u${s-HJ3S3 ~{nȮ#,Y?Mq\e ?f.c&J*)$Zڤ>^Adg@gm(y4UB5s$,E4v _9cڝF=m3VqO(*",f~Ht)\ޕD Ms&j6w\Tjy7}}Ce/yWߖvJD_WʨՇZr;&-'jSm*Wz7c=ۗfɝ,ӌn掺Erss&O5;M DnUKvJ4Uxuc }^}bU%q]JG(XV5Y:_r,uPYZ߈([4lʢ_?,2u^Yvmw_$}cwztG+~a.(hy櫣~DԤ x765D)g,ߧ 0ԓ͓Rked_vIf 2ǼJ~q^2WS8le&R19d0YI=Rֿ"c䦓1r:RiR-y!]ץR޶t,>#LnbaJ{Pk Ae雐0 QqKbcc^]夵j7=z|$7BԷ l3yY 4HN0[\ޤQUo|Չ0ifwr+*t=A+נۛH>ۋK5VlT?^D3C;bƔ?/gx*39*grV ʁ߭7R̟$oTӸ˨'9CB[A=b)Y=>!AXTĻ4["bB_'B9)+^?L2r͑c?ͨ^wp4{rڌm ٖEޒ=Gruo7v*T?仯[-QB?5_?@LHl Q?c4S\5Xo7̓S~[r&)i5n֔ǩ:u^jv/Oܞ~~OR'|{_RR{f/:C^Ffzy%eXI^ݓ:3'ugx}k7 oa;xv2exg=l/^j2 +|LCi=v8>J(T ߏAqbroZ?";:I-R i@X$%uΟPGZ'ZyE_N6fΉmQnAI(鹥IY>簍Xd#$c& 6Ɛ,c Hg ec={"x"f%H ˱x7WF΃dtw_?, D TVqm[| 2:.uߕ֕Ur9f׈ZU:s2jX+d%w.SeD`qZZ#-!?G.if̉߫o#8H<eɐX&kq@i=s1ɦkZ53=.^<=^ J8u*b:|x%ԐyйeE9y=AF"WujkN\c)U}'K-vOٺwX^6gg0t8FY-w\âMrTFGj>r*ƚVH9{LCfL(BSN|K4fvl_RF<dZ>G>t#4*C(wzH෉YʂpoJ[qAzz@feoVL`6?X*3F˭6ZiB&,=nߴi~ ,vÊ ߢa~J)3 ~퀫.Q\G[a,,69u?+x$B's&ɦT]STӎTFxFԔol}5F|+5";n.Kv g??j(Px=*dzLO_2M)ʟ'+P nʝpvM>67x=M Jf.Ԍ[L\G:px#-7itVJiuiI'yi)KkIlgM[3K]v;v43cʾq+V`=걤1l)b@Œtl qAx= r̐h7-/l&\)>!ISVncC鍊g&\\J)Q!liLt*EEɑRr-=\qlIX%D"J("5 =BDUS9NPWr~wij2ժ4gMx\SkT1cM`rT3jĶc w32@,E ϕMωQ t?Jpcߌr;Anrwi{n8$d~qˣbӯyImP f^Df:$0ԅB"X XHND2G7e++ L=jOQ]NZI 5W8*5 YS퉶idQ5S9j Q|-].3r-YwO9:8WVV@60[oF[lt?g_j-{/kWDXV#BaXJ6!:fe/{eRaAr2u(yi8Ik+ D0{߁=ʶi u1>"F)!ӣ\ptf7[jŞtbXM֡9D= I%2|w3>^Z 7fTs&5S;UiUuӅ[2YkjOgܓL'zWRǯSVԻGq*MJJӆN}["i(1s9uxQ/B ɗc=YBfS,,9\ȲlI~eSCSq`NgQO R(Lo)6Ck;2Oj!] (-3-)?3_WpRl j Qz|}ooC|勃zĵ %OzBxy ^͈Q `4&s$.%~0ۈw C=Ao{ωK~BOpȣWFxZ`l",y)xRC91RٞL" n5G?lt!,VA;9' A Eè M+!:Di%Ҁ ڿ!w囱D9vͣ6ƸCVuKxFT;v\7xj2:^6j*`aJjZ 0LF9;F5J`a7SW#08 #bh?{EbqxI>~5lիxe2G\Q H5Ҟ"^8뭽-q`CS콘e-Y+p)lM?XBGyGXu(U+`"ZrU ;hm "ĀNV L8"٢=1 Lɘq}VycMH6)RHGH`iLZLAewsl;!!#S][ᓔ54,e6O6p:Br3d`(y~38A}̴N WڌaJS1s&-s&١&Hc>L??3 TP5]<2>|*pRʹDi ܤyC D)LU2=^3BB2 QT[6Y\ڂv˦ z|sֵ -*oR0V1#j*5-^)U:DF'=yO9v #Mc <[}i?3~qC1BaEMB=Qv ؀*0xl{B#33g Ɔ^!gp,4x.h}S%2[ͳT*m,_WX|~'uPg|x$Hw0 /s,0-{Ge,[.ؙqx1a4GY<})Kh\̖3,&w\(ӈԦLy״s+zY Ɏ&8kftj?+>%Ԯ%,xJ3y!3 )f 3`ME`juVtBiK,Ve(g]1NTH,-VjZt|?]}w 㰰#@_1c<\s@,h(8M]2ϙBم@0x}aq#jO#{C P*Xc$=%#S|J%e-K-*ql܏#e܇q!2Š`!%DoC\׼;PMPw6c9 0q%< " ocuXP|{8αb5X,A'{XmF I9 k-2XGbtWi,Y\Ġ䜭MZas4@,ˁm5$Ύʱ..pho%dE c|c>fk6C+7Ѿ͒dp5@7vzI' \PVl&2΍rah8Ƀk_XJY/fQW5<1PiF11N6R!/*BexCh4Xno KURʼnqA)%VUddd=%lZSOW4jH~=W|!dW-Hyn_ RZs()Ԓ9dpwF1W|K㓭z'IBG(N$ϳPvi30(o sݿOEuF_DBָn<5LYOkngKfJW4mJϖAp,.obo"><%  } S|=CK>HJΰ~ e)$4\1&i?RЀ2 u]16P6i,t{ ;uצ&U0p K%~e$1-{¤1+XWZ,!JT9?DAiVQyVw?F4WNfi+晅Ƣߛi9wעY/f`KqDOטE? ܠ-Qgvc Sl/*/<.mq<yukA̰4xfl$ c_yr-}̗]V!V-1u[; \=>*/SAAbP1xzH< ~UO+ ֘kvSxNqw`1}=}n_׏S=T/&fZfwbh5qOMb9og3<֛Kb3!t0pf̷g c>d' bߌ$Dޤھ5MVcv o6>=%B&0m]g~Zv YR% w*x#>%kusuxDw@gm{'\ }RUA YѬId| _on 7IJiqiV2 &/_O #hY>nU*73\.+x|jr*p9`y\n.-ˋrpYS%7./eyrn_QrMbZ"D~n~30 [.2( Ĥ|X i87X8FG.# 52IQX:(&^jO{&$ڦuƲx_.߁'eqye<\^qJy\n.xrG:~ '-GX+ײVb~6xp}7C&w|>-(:v2+YRZPKTr*PKpJ$DPicoLisp$InFrame.classuQ]KA=WٵL+wMR˶ע)XXH|}sX1\IC? s9{'sg``D %;1c R^ 7CI~awsm& $:>!;(?PCPd; җGWJc=csA$ 88&P80cXCNbyBMNy{Sk yz. rS1̺E8W5哼w[|#1;yE R+Ny˴XbByfPK?5PKpJ$DPicoLisp$Namespace.classSn@=\6iҋ6(\%/TJR*x+uqmTSPPy@!| B.iKϞ9sfvק8yqVuM[9dp[]y̦j0+ҍC#\K8q(m mw'؉f3nΟ,MQl+iޑx"ݮ/U/"Lx }y(=z'2ޣͳ'n"ZU-K@("P2XAM ǚ<xua CxVN$UQ1m4slPgȺ,3%)ɸQɩ ig8 B@ i#QuX4)Fa#EUۨtb`DYFv}qLޅ4jc ;+H39c _i->bȽxw]1L%s~!TT+En~9̠| PKqDPKpJ$DPicoLisp$Control.class}R[oA2,N/ZZ nZĐ>4iZ:KER3-Nvw4 6.ᆹlpFt-x+En (0Ě#P$gZA}0U-{T!^NPb52T /BFZ/TvnPQ`Y"HI(KPFrۤgF U3 8o4CA = &%89ZU+pPKkZPKpJ$DPicoLisp$Bind.class]RN@u`|Ř(@BO$+4HhL(i5ٝ3{f7c01Śul0c+p1ՑӱǠ"܀!Y/Qޅ L};ih, JgNPKpJ$DPicoLisp$Env.class}ViWe~ J)mb[5@[*Z 6-!@I֭k]TUc<36>wy{'?Ѕ_Bh9 xRCOxZ3"aaxNĴ",31")8) ǑpQBTE]"U,y E }xIòeQiY6]RŜ%t7섊163I#5 Fxjʦ %*f̌T*Ld_ԕ)ԣ^|q?A7I{]q#;K4f%dz)ݟ1̬7ɷћ6<+/soQUL/n˶r=L v!{S r}ˌB6$Aa6G̒Cy&g%٘ SisA#=nL%M^Ԉu٤TCO>快$b*>бO~pqDǃxHGTV"qLݿod!WX$縢 Y}J: v FgҰ;ݶ̧sfo1nsVdx? +nװ"ϘXaS83Ιp7m^F(V"RNdꢁ RĠ=Wk&HeoEOuZ`ĢZO2irM#TfaY]4\*㎗,]9Kl:?k8$̦Yji6 7yyg}dps"GŨwxpA˹S\+@oJ{ĀϺDVqeuttP)XJPu FA@ 9 8F&:sP'X^0  tn'J T@ 4~#x̧7we[鴹m]xtp*ѲyU6QVlvOuZNUJ-cr]:A33جp,vϞb OlZBn {VqKmM Kv7K%ˡoUYv :Ho vkdga믏uX膆\Q1*pcXE #~gB$GJq4Gc 3.C]03"*Yeְ g?с\crvI'Aڳwȟ<.lE'ۂT&AٲK p 1(ϧ` h5lp 5 !);qcFC'F^6jkڒe՜)j5a kj5⃼sBTh0/>IbrB NT<<| >q7>'T4!7>3<O2|O *//+*&oo<|}_3G ~ ~ƛp*ů5y3YIUE'nC?'o[Eg٨΋nd"b*|GD W3#b,܊(DAoH|zhPOpCC@b{^uL@ĥ.G}0ICC5HfnB1 taڈ>=SQ"rUasRG1 BX$VWhL^ײA:߬JRVF)BSD)Ն wBItqՋQNeԎCa}=Dq)GIc.=#AlݻCSqQ9F'"_QJ8>4LjHTG(\ "M"EP2Ģ{s$$j*_#Ex,$BwTKel[8"I1i4܀[5\]Bح MT* {Wbc@,7r8jfC U[F sT5Ԡc9 7Z qlvQNMhmhd_K'J:z;{HLb>%UaJmD9J6#lH"M,-4[HEM[4H4X5<UmX‹b"#,#¾H"l%?'~Z5qK5B\@f6l*A\kZM5Al(wxh7g˘hԟf㹣%CaJz=D$.t";w>MlnMBtiJѣNtMlfmWSUUU.yΙZEňSR R/?urDy9^`y.ؐ2.}zi+)V[o3ZGG ecZ/SwEb!ɿF́:`M5#k0bCi.5k-BC$fV"AP~q0& ڇ)Y`]|D.Z&z0y̝L%>:K>f> ~0ďAJgHqM,B4 5|3lMbɈ|WVϞPL~x:,-_zҁU'!=$MH< 0b&h4V/= _8"x?0"$pMsN)(2wbMSPD%G48OAe%|P`ZuPPRpP(>hzH=l]Dj9 KNCc]$(7t&l#'%&rd,TLyq)C3EyB<$wdEӕO=RTC5JD jL8aGk t`a f `M#<^z"K^s(8ՔRHH[zCB\ܟ$ȠPZ5NXLat-gYU$I_g!L~ V ^o,Z-BF)̫lʠο'-`aaz33տ? g=E5^4i/0O8'J2 )f֟(K1[ s_ĸҪ;moҖʹU+8"^a(+ NN^ub@1 M-RrZS^OB~ǚcĞt-<8>}ԏZd9y/OctY[4V9IFLzsn%|ۜ6Teϻޖ/pH\pUUjμ;3Ů~&{[l~Y:|en3fpIcPh\.֍A{_-?[MGr1*Ά`<=̵|uW˚l3z­KKcqwY |y7K!iO;MX@UIs1YyC܍q΃~4NCLcw=E`cVia* c <XZV۲*׃gtAu/9$XĒ'OL"ess6y"ֱ-Q 6;/yJ'd!}e] 1KY6_u!TkH:$n(VUϬvq5A ķ>aXc>H`$1#@(u 1@;z1 aˡ0)R?[A!0~e$!&h7<dhuW&[Se0aQ!s{)(C\X!!{ވ&Huw{rs "*&H @(,*F,\ DBS(uklX +(*k]{]Z9{oޗDϓ3vf̙ϔw!ᕰjw{]#?@MПFn f[@ z@z;@?z@? (@?z''@? z@Ӡ,@?/%%_ WAouo~[}w@ =?1O@ _ ??9/@ +_A ;߃{Aw`B`$F1`, I& &LL0=&~`2 ` &L.<0 320@f0@0&:0CD)S`0 3L10#S f41`Ƃ)3x0LsI`&f*i`s̑`Sf:`f91`3 l0ǁf.T9<0'9 `N3L 0U`,z0Ԁ90`S;40`4i] 0+ 0s& i9os>߁\"0/s)\`s%\ 0ׂ`VY07 `ṋ`ns;lB+;`f=`6LM`6V0~0<A0;<a0 G<q0;<I0@qHOy̳`<%0/y̫`^70:7 -0o؟y{`|c0̿|s0_W` w`f7=`+J kZX6 6ll=6~`3 ؾ` 6l.<;  =З;llBE`[;l1#[ v41`ǂ-;xN{I`'v*i`{AW=l9#t3{4c v`;`=,f<<'= `O;l U`.b5`Ol-إ`փm{FM`]v9`W=`Lg=9`{XU`;=X"~5`/}-`{ثbׁjkF7-`ׂm`o{u1zX]+;`*r)ػAc  &nv+m`{?` `0G`8؝`$]`WO}`<%/}`_+* o} ``.`?)7 `%د~ | ;߃`{v# #Qhp 8'08DNOpzz>8N8q%v2q%vЧ//q'',/wr)N;7>s@99'>C)A48+")F3",owS8#QTLO}LF 4&u(ra)M !ag39LqoN vwT6P9|G g:3(LMc,0U7+E(g6#9Pι9>J2qN$N.89#$C,Pbr%ewNUةva, ˷Pv>5J\ʾdMQ}lԧn9|kf|˨YA2$t㌰ EIsΦ9au>:y6,8) Es~O I؋8\\ ea> J{%}$5>zFi::kư"7Ϲ kr8s8YN+8wsWXw5aT?Q?l ɉ:A/pH{)賙-ig+ ~;절#a/Σ1=Nt'j$ESaӔ%BBttlϒ0yŰ*伌>J}Feq^'ߠTm?w.žGp>#ӏ ESqª5Q8 >_k|C9Ko}}vSpfgGb(i Z88ВA jӁ06uROtWX]JyH2W)~7@&@M194 ?'l0(AOPD( VP@2qP =5^[xXSS)$쌚Y+ k iY jrʐH[ojUC™Z_X_0ScU1١u˰)5u!蚪5Tli>U%yzvH85,6~T_Q5uUVscMݢ)- )+UcSf7juغu񺐐`sM5'0I1^awSq ,/P ƌG`ԯ-V/Q8~iM[ji0tl {\u# &Jt\] SMȔ(9rzL`ץPԽͱ9ږ8J):- (]"+e75sG*{^gఏtӹ̬rlz/e1 mdA{κ^Zh+*87JjtT\]'7.@ƼzUQOjI9EKsM0u1fzla4rpܬxzDxULiǖ tsd /4^"t4OC&X w#$%19VdzavlAmeUBڄ ^T,ނ*/Wơ+ 8a.=|]׋5T5cL+|ܼ.P_Xj+s%t`TH@)MzS~ޮ=IVB:0ky00c ˇT|awI6HG=cP_^޵Wus i)V) k.5vST2X1w#m[6BP +!xc# }!HQP4Q'_zgA㒊߶47v@~_:mfJCc}燦K=o3@/64k\(.QSZ3r/jDoKLb\Vg'^*ڧة"w~PmUUXCChX}>)UC0\dV}Ւx3+ SͬZCS4̍ƪ7kg.ل!c;vng>vM4Ï{Dl+nZ͓;J]Ivuv=M鎅Kc]Ug p{z O/Q1R,e2l5M_WCcumhiXoWvnFzE9.L23+*먎2e s;RUX;%ci &YM'Phqi$VQ^C77el$ 4W~y^:α^DW?H+r٥qw#z4G$ޯ( RwgdZj"HwWsEtMju~_BY0VT4Qe"ǁ2b \Ay%NJ`|U-҈NEtHK$ uD=vE";n$IBV" !ӧԠJKJ<FzRS|!/桱lrmWqEhf,@ 5\(ݩ"H5nB&9=@1dKcAN4XjXN,zrmXi$heCYؽc[\ikWRy"eI o O]~ra΋:语aK)x, &(4r8u]M-oHسRTQ1#Ix| KyȑqBUqrjuCrhmE ǐXEM^@E}vu-E5ŗFL6.zU֘X5|T(+;\|9zK}\@iKbp-TCs#IS5R,zfN_Ip"1r4'z!?/17+ h:~saPp\_= 9[TO,CB4֓ cFzjRP k28ceX6Ng,"j ;Yުrl?TmS3oX݉1k3?XcI7é OӢ;1}JTJ+9k هU`h,)5 LLG I_%5n29-dmTS!n(wMvdjś"Gtk4q:-_ #xWpYl}+*Z\JY0/maf{˚首nΓMqQΝ8@oZhEES"c.d?Vnfz!t>S#z>vz+eC*05<4dThYY~F洖l,tk5,~7;ۣEn ,:"Ʊӄ2>2;nf&:pAv lZ\#E1UƸbd{-vcY݈5wp BRT S=pQH'ۖۏ7\F2T8>"pR WD=iWEO~2WG=h`DK:_&E>Q&);=(cPѵhD^u 6[95V7y ]޴4QNȆpū6yÄ :CD5.jY 2g-=:>Nk9,e=lZDҥnpK­PnQogИݎy5NNwj*80t/u\UKrQ/P.7f?s]{'#`cwwH=LX6&ß#{`F*h͈ l!< ]k^? @ѧ%A+t],҇PD7"0<_"(<<;#x̀^Xh@4{dơd'8VR]p\b\gśII'F) Qދ4Υ3#R}YD_NW#z^Qz!o7E-R즉y"* xsXx^>? ޢD3hԳ깈z>/gzxTͣ˱5Q5ilh$Iu/:o_ttVUmDMim#Q>L^Qj&1:꾈9^DGE1;'ȡu";x)b\ S߇$b+2ٹ0Ir5S)Z8gqfH +B"t}9ݕ=N~?QJUuj9fvwI7^++?%F'Un_7S=Jwkltn2wS)!vi瘹˱M}E7Wi}|Gw.M-Uq^6,^Hl)hK恢U3IG9݁\49F$bu5z$N}a1zՖ 3C9knPZ~|"\:8TIlGhv^@oz3&&HZM䦦Eu]ƣw~'>a,ԝXZ^b$ggx/cMKIw#R΄V+y7͋hg@KF$4pqD/S8 :ɶHRqk$pE`,k/ra l).^J?n2MǀiH<> ]'P_:gw?M(ӃPq=-FY&z긯)LĔgEFE&S1yEu g=z†tk5u1w^w'5W>Oy)v=cnZœV9tO>T!nv`ZZnmwAA'IfՁcA==RUurC{=nz&o>V ?3&aYU'}ƭR'ElGI o%m^''^y=!iDF'wF`C(2jnje.ip.*ѸxFc/f\샻EQ WN$AݭJ]M1kN yl}K]5=:GL8N>SXśgUHG\ArvK]7۾j۳򻏡~_>k=.}uH( C}-)#1L>8=M> IXk){h)9PU_hTa6ߙ!9T? &qORo47Wgp0;1HݫڄE?:VC_?:]aIݧ!#{?r!! ď\Je~rBG J?r!Wk֏\G~d5!k Gn"f?r !kȭGn'?~;]я ~nBG!d6?~d !~d+!}Gy~!B#?(! G I?_ yڏ#!#!3?9!_/ ʏ|M7~俄|G#{?!?G׏t >(#bL0Ř`1 0`EXz^t `` `}`9< `? fv c!EXc0ƆFQь `c+ `&061ؤ6)l*cءgVؑ(*tfa68*;!cvc'Sb-`UU8c "N `K `K `5k `M5Ɩ匭`+;=oؙfv.c2*>]Eb. `2vY?+2]Ʈ `1v}[ؚvc79v+c#cl}kevc `blC?{e-mblsX{ضvc=dlG{#%=cqv'{2bWƞ`0l{ ^b c[;c7{33ػ=`0a'}ؿ,}Kƾ `_3M/c>؏'v= `dI2$? ?Od'O2'dI2$? ?Od'O2'dI2$? ?Od'O2'dI2$? ?Od'O2'dI2$? ?Od'O2'dI2$? ?Od'O2'dI2$? ?Od'O2'dI2$? ?Od'O2'dI2$? ?O&_zh&y6yZ@hxn(M^M^:魢P]aBox]~~M;M^.B"M!ptߩ"ѻrCaJBl͐WnW fTOWjWk[unăSp6pͫ++T\Vt/H.owkE9ѳ@eFW޴S &o&of"oE"o.o,*hZL/&[;{˻nWY*{'1ert"|GhlsOH vy&^/UwӿM޳FdMmv676b b%Bz\%҉rӌZLoӊ2MqͲrs(ܱV U Md9P\ra[EdZ;˲Wl.+ʭ%/^q^у}@(Ga~{aFlGC<oD֢P/vUj3mM3m1.+d5C v"d`D̔"9Ev63}{::d.p_9 ܁QCKWf`i;pH6PνA8fȇK6HNN1,.ZRULBŲcX [Hl#,,wfm'"BmOVNQ ]>4ӹMϣKrn##ϓ#yT2h8g|j4d:kDb:</uro=s3 7 &x= e;ON񩨉7~-Vqv ׌Ip ډԻhC;ʼ(#KUnZ qk\QRL0. *Ւd 8d9(i5^}:R:. G:%[ wvCE ' %8ِZ)v~)~;q"oS!yqb8,e@sXLIsYm8iIQ֍Qm$:SK։9GZ-r<=!'ϏMj1E4/q!˗fRpxḛJl@758BZݝ4R;0wr^+.6htW[蜴bD.z s9%wfnZZ/iX#NFWvz Mܘ^3VEj'>2{qz>gt}&oquS;?/:ϝUic˖X/@D]V8wu[z$w𛳘J^ EOjM*vx%$>y[O)BǢvD$I+`MKmoL[M/mѴK4\pPTxġ48+3r.zNMT|6CvԑtWr13=C*V ӛk6$s-p/Y[yeQV3IkŴ-\FNZ&jwmntsb\/]7I:[bILe\Y( `/{efgMezgW,?Zܑ3AM\pCh!&y ~*綎wWɎ֎7t cLv|+)i5a 7,Gg/N>yuG;\q-b/jxq[q[k,?Aw= vakȜƯ EE>Z:T|kۼܺ؇[{O >]Gv֎O8^̿16U,?k%{Y&~UTҎ]IwvJ+Nɾ7Gs 홒kwq tc22hVVoy騞DO=`m*o_F)8[[Zt+$_ތ⤢";őYW)/;y=/(%c\Or+Ìm>D]`/fvkߡ~6 Or7qrOekVѮݬB;qfxOcVve2ulr;E1CmW)贫pN}.iR1!]̈́Td3u.9moT%ޢ0J;ۺT-zB[T:jJw7J)zNw4Ac!d zw8 >R"L24 q$N0\(DMn22NSn?iW׮lW}1SM* [*Ցtǰ7;|;8{7 'jҨLw3qBiAq'-fnj8bܐqC$Q踠r8DVtַ`u?}>댕QŲ&!lڤqD.V֎ \^^F>Wb]pt彾HJ+@1OI6*oX؏>_ %9RKBxJ C %>$ӻO2ؗd%9K^5B)s;;M0tՇᣒ[ 6  0Lbs0"ЈnS*+v* tvfrg̳y?eU pTR$n(/'cc?Fψ"R) P> OUqmjL6n!edSYc+0 T6C;۹W;I8;Y,Tos0ӎyv" 101kpC0%pRU n{nU"4Uk${>;*HMsmugbNToUݮQpRV5ynb3=ubHPOb{nYM:a 7zGk$%ܒ-˽VUVL/Zp DɻX8Sp VVp&(,Xڠ6JK{J RQI4;)KwpII}XZqDJayM^=ax:{4qnJ($ NG|MQ/1"G=kWs[ŊBʋ7D" &fq]vݛܽQĂoA!Ayѡ$g gXm{<^ h9>#+bE2Ju" ʬ/MohZ-|LgOgvLuU0ޅԮ8'"K+ɗ\}^U5z&&d#ڮjpxjEjݒ4*i|Eǜ8zUw~b n%3>V,=.NƉTXcD(QIkEf+m Z57M띸\/N 5MB ,u(c@:f7x85.._poM F2wrMձX-\Z1ܵ^ BӦ:$V~Ÿjqƾ5R t4ww,ቆO,m˨m)Y($~7eMkE'Z4kQg⊸(wEZ), V"H*XS(ؠ,e4`ԁݢ7Ob&ne 'qD~{NMINK^Z襓P酉:v**( Ԁ€fomylXZd"-25G qg2nN`G[S f/t %IƏNcG;"\NzZŊ$ ߦNw6*[ٷF˯E)ʆ: !JnA^#wam܏35=>IJ!J@~}z³Viڱúrtd~^ړ+ ]}뛍ϑV*nˀt+]eϽ0&LKm!13erGΓ1e{8ycN~ =:-.qwUzo&^uEk{߽eN3:25=8z/qH{v.YKT*`X"A^ᬼ'q^~ɐު:[m?جΤYz:gUf=P* zC,Lzd gceŚ,^ oQ6sJ<ޢe@-\SV-*N&+23ŕ>U޼D+ 6C:9p$b-]"C&G?Ugt(!"û&ݎ=:}8) %_j5?r=_Amj&yvu>m?nW𩂴@J0RǤήsϮY9wFOef0eefoRҝ*_ۤ."f5dl<_& &3Z*u6议N;:C]H%bK8x}"XՉ`.$sDQ״2ԍ؛8DM$~&_rDoO~;8>D{Y;w3?mW$H,̔, 97}Ysy ntde,l[r{v,5+K,x>mKξ[uFⳅ=C6US."eVT?2`V %}hjy]\ `:~:7w,Xt[Eu|+IMɌezh*8}1t x I"$+` BGQUd:am/-2,KiъlY2{rG S!pR9g9XYPI)z*;t݂SNUM)C"WuGjěB}:8wbo,Úv'EttgxNw[AnWcG/=uqG,b. {UǃqZ-إJF( &/S0F_C>}øv O,}acr="齤C^D;L=c-5$]NC#;WA&]鄲&n[eogc}89% PI驚ucA6Jvskd7nPKw PKpJ$DPicoLisp$1.classTYSA,L b4 5H^duw+ـ"4R>U$R{JЭ>>g^Y8 ΫɅT\İJ܈܆UDKLET\FBrI8n0kfahZ2DaU,,' G`h4,ÝbgYdPvQg*a)ȺZa-99m9nRt9`eZ] JnpG`IR3)2d#VP?1'L2xJۺ$M P†4 E8x4Tl `V@ +0,zdyv xpTS!ń]ZM+7#hZ%!!ΈJ#Y'2uN &ܝ1D*A}O`/O #7-T./PK?PKpJ$DPicoLisp$Symbol.classY |u_>Il6Wb$'qH@#[]N mGh%u-eRtlݺw׮˺uG׭ , I{ys=|_ЪP~ K~ 2;'q!e'5ٙ_70 E.KBuQIr1%K~pX ~S(WK"dmY We&{2|Y+B&(|_7M"? P&?//e-ķM|wMMkZkBߛ`M1܏ ` =6?e?DMwqڇ#^ᇲF+7){^V(\>)çYڬm#oyKx D⦌&KVH!Ƞ=ya/n}p~B,ej 8j R*d0XjkY|)WnOTjOYwT"ZZA5Zj1|RIs KL-7 K"[UuƍL?5 T0TQKTR-pPm]VvNY%6U`ciPKݭe1^ޢG ^{e{TTkJ=ʒʞXjZg^ c8iᓲOmFnMjysDa~U ўg=_aMifNht4ߛ!_#*;fFjMΙVI2MbՍVxK:*:D:%uusyq.S>l|hyw )h%o#+wo;)CŎp2+0;VE΍ U5 b:5@ ma;gϖs4]$UZ3$L3K?evuNƖJ&rC﷼8>mm iRBG PE0|lA;LH2;2+-IR1bKl9,&tCɾ8Ɩg^Tjt+ޮ+]ž#ѕY6toF7 rif|~3g;ҴSP5qII_{9ʣnY&FLE4EZ㎆""IAll@hh˫-rssڰDZ"&FDVUsle{)Ol{>ڴ6+Ixexa%'偵-(KbBM+mYK^2a|g I)GB:C͛Z󨟵`OI7ܲ 9l:yJpr 'b b}q])J]B.YrM[ cEް/gkrsx;>e+0JքOї.a^O¼_D}"a$QExs'Q'ID.cA&u C 4)=q#"VC\OQSFa8??0Mn mL c 9W"]z6;m|[GGoKݰ }lFQz 4/)Oh1!LjoR8?bMIaIVV!9h9EB1j)3; i^]VM2\VCr^j_+4DM#-,\ck "E?3?lάU{5-"VRLv.D D, E/!dHfљ@0]GI[.=*iJyveT4ty|,&Ծjh|{:>6O#fEr"y[SXW 4w`wX/C%Sa%ybgkb8{-cX"ZYU|p9:Ϲa KۼEBTIGkWq궢.*@i-kKԹ­k\ngY<1d:m\cV7ĶҠOS%EV"99E$Mrו"ͧ3͓k= 4Nwu\F5Oa/^}6LtŢvcjBk\uX.-v$gMԼ-ߣ!fLA({b`cU2[z`7%z8bB݊hdT똳:uױTy_G0n H$1+?"oҜ.ϗk! N@;Pvk1E=럈x%SKwp"lHxW~%l af}hY_Voh|J|Xkpi{r?͛3ߚJ¯FDŽ ¿&LϨgcxVq22PK]D^PKpJ$DPicoLisp$Any.class_O@@w "5!XKlV<CO!t~sܹ3?]WSĶ>i8]$2T&0!q^S[}80h}:bv03 #Ť?2/5D'F0Sg2G47fʤ\P"4N#K 1:-Jh~88IQe{Vߩ~/U w;#O8rs+Tԗ^՛sEeϳ{LAnbq S>vyvbH{UCk͏eLށ#G,raWdeV:XNcƲt-Myǻ;݂,Z>#X|e˧+X@r X"3TV5o~PKFlPKpJ$DPicoLisp$Cell.classX |[U佼f[Fv,iVR4`[PA Y4)i:6C* СkD~H  Q?8羗4IOk|s=>\VY|S֛.y+<՗Y+*bdU|U 1.Nİ 'n40rTŘqfDž5pa5^Xop?=̳]hkxPcu<Ϝ".WޜLMHOOGBesS͛6ƺ3yV9MDm,N7sZtS1doNS={6~ڛԒ$:xBT.xmoejJ"]uTD*< 9.{c6H&B j􊖢A ja1>ҦUbkZD^l i.[]] eӎKc BRM%3xK[hI8{FiiNmݜNEc==rR Mf\.jgYhq E%3ˊ3e!iKTsnE$"*;:?#KM:3Bn-<-d趡XT`t$2;S%5PAQ(oAAxb^蟙rT͆aCwE1Tv4Eב8'#Tu}H8f;@p@w VE8 3*qCy γ`:< MQʷbAlx~CfjC^fHu( ?so< g?<:Z @c3a0\싄ilsbT!CXY{g9haJ6;y;.( K d/28Dy;rQTbaZ'w4FoeLKxZOEM(){o^iJ&|eP12%[U"Җ&I1?P "FQ'A$b%:izhs07(*Ŕ '5$6wO[LfUOD\GeU-҄%X4ٌꆰ쓉'Or ա['1ϧ`>9eł,7jR؝߁:^n۫iRXg0C8A>cIJzQIGH ]{/yM3t&i L} / PCZCSenK(8<*v2>-GTx ̃^3" ,1!GGè0 _RTS v fdjE\ j>m ;썊!lsp VEi>UО~JdR֧H,YnCԌ!.kojv0pDo*PsLn&q 1,8o6dCF.ggoCYr-Mw˶Xe,.[J{lҲ-c?ʭZ+eAeP"lTI\z ס93 ,D#_k`JJuF l?P+j ,f'Y ;"Y4P΄Apf3! t%0G "ZbkO( ,u]+ 6.x+x͛8C9,Iѕ̼Do~㓃:\԰hxj{X B0r2s)%a%kp>>o`~9+xg'{~YZzɪJ}Z8`%" {aO۠y0`)oo'ë EbA C =6FɃu;蓅qWEp6Ɏ[Jj:ݶ B/Nr65k\!j˦5w ~*3o IfTBei]%iy"8~9L,}ʦoF2z4 ~MU^6TSS,l*[xqNhh*x޹m'Qd2w m DZj4$j{\vxSOP12x/.re9E*8r%bZC?QܾA'Z oyPڐdo uX:S׀RȳRmZį`|Jଛ/w~߷甗/]JMDF%>\VYOkp}&B$8O$5k~O N&b[PK$}˰ VPKpJ$D META-INF/PKpJ$D^P]]=META-INF/MANIFEST.MFPKpJ$D9#6PicoLisp$OutFrame.classPKpJ$DTr*WPicoLisp$Number.classPKpJ$D?5suPicoLisp$InFrame.classPKpJ$DqDvPicoLisp$Namespace.classPKpJ$DkZyPicoLisp$Control.classPKpJ$DyPi>P{PicoLisp$Bind.classPKpJ$D|PicoLisp$Env.classPKpJ$Dd<āPicoLisp$Number$1.classPKpJ$DvJ +PicoLisp$PicoLispReader.classPKpJ$DԇqےPicoLisp$PicoLispWriter.classPKpJ$Dr0pDEPicoLisp.classPKpJ$Dw PicoLisp$NilSym.classPKpJ$Der0?PicoLisp$1.classPKpJ$D?;PicoLisp$Catch.classPKpJ$D]D^PicoLisp$Symbol.classPKpJ$DFlPicoLisp$Any.classPKpJ$D$}˰ VPicoLisp$Cell.classPKpicolisp-3.1.5.2.orig/ersatz/pil0000755000000000000000000000017412265263724015174 0ustar rootroot#!/bin/sh # 29nov10abu # Run Ersatz PicoLisp exec java -DPID=$$ -cp .:tmp:${0%/*}/picolisp.jar PicoLisp ${0%/*}/lib.l "$@" picolisp-3.1.5.2.orig/ersatz/sys.src0000644000000000000000000025060512265263724016017 0ustar rootroot// 12sep13abu // (c) Software Lab. Alexander Burger import java.util.*; import java.math.*; import java.io.*; import java.net.*; import java.nio.*; import java.nio.channels.*; import java.lang.reflect.*; /* Ersatz PicoLisp Interpreter (Poor Man's PicoLisp) */ public class PicoLisp { final static Console Term = System.console(); final static StringBuffer Line = new StringBuffer(); final static Namespace Pico = new Namespace(); final static Namespace Transient = new Namespace(); final static byte MonLen[] = new byte[] {31,31,28,31,30,31,30,31,31,30,31,30,31}; final static byte Version[] = new byte[] {}; final static Number Zero = new Number(0); final static Number One = new Number(1); final static Number Two = new Number(2); final static NilSym Nil = new NilSym(); final static Symbol pico = mkSymbol(new Symbol(Pico), "pico", Pico); final static Symbol T = mkSymbol(null, "T", Pico); final static Symbol Pid = mkSymbol(new Number(System.getProperty("PID")), "*Pid", Pico); final static Symbol At = mkSymbol(Nil, "@", Pico); final static Symbol At2 = mkSymbol(Nil, "@@", Pico); final static Symbol At3 = mkSymbol(Nil, "@@@", Pico); final static Symbol This = mkSymbol(Nil, "This", Pico); final static Symbol Prompt = mkSymbol(Nil, "*Prompt", Pico); final static Symbol Dbg = mkSymbol(Nil, "*Dbg", Pico); final static Symbol Scl = mkSymbol(Zero, "*Scl", Pico); final static Symbol Class = mkSymbol(Nil, "*Class", Pico); final static Symbol Run = mkSymbol(Nil, "*Run", Pico); final static Symbol Up = mkSymbol(Nil, "^", Pico); final static Symbol Err = mkSymbol(Nil, "*Err", Pico); final static Symbol Msg = mkSymbol(Nil, "*Msg", Pico); final static Symbol Uni = mkSymbol(Nil, "*Uni", Pico); final static Symbol Adr = mkSymbol(Nil, "*Adr", Pico); final static Symbol Bye = mkSymbol(Nil, "*Bye", Pico); final static Symbol Quote = mkSymbol(Zero, "quote", Pico); final static Symbol Meth = mkSymbol(One, "meth", Pico); final static String Delim = " \t\n\r\"'(),[]`~{}"; static Catch Catch; static Env Env = new Env(); static Process[] Pids = new Process[12]; static PicoLispReader[] InFiles = new PicoLispReader[12]; static PicoLispWriter[] OutFiles = new PicoLispWriter[12]; final static PicoLispReader StdIn = new PicoLispReader(System.in, 0, null, 0); final static PicoLispWriter StdOut = new PicoLispWriter(System.out, 1); final static PicoLispWriter StdErr = new PicoLispWriter(System.err, 2); static PicoLispReader InFile = StdIn; static PicoLispWriter OutFile = StdOut; static Any TheCls, TheKey, Penv, Pnl; static String[] Argv; static String Home; static Calendar Cal; static int MaxFun; static long USec, Seed; static boolean Break, Jam, B; static Bind Brk; public static void main(String[] argv) { Argv = argv; 1 init(); for (boolean first = true; ; first = false) { try { if (first) loadAll(null); for (;;) load(null, ':', Nil); } catch (Control e) {} catch (Throwable e) {error(null, null, e.toString());} } } final static void init() { int i; String s; Home = ""; if (Argv.length > 0 && Argv[Argv.length-1].equals("+")) { Dbg.Car = T; String[] a = new String[Argv.length-1]; System.arraycopy(Argv, 0, a, 0, a.length); Argv = a; } if (Argv.length > 0 && (s = Argv[0]).charAt(0) != '-' && ((i = s.lastIndexOf('/')) >= 0 && !(i == 1 && s.charAt(0) == '.'))) Home = s.substring(0, i+1); try { if (Term != null) { final Pipe p = Pipe.open(); StdIn.Chan = p.source(); StdIn.Ops = SelectionKey.OP_READ; (new Thread() { public void run() { for (;;) { String s = Term.readLine(); if (s == null) { StdOut.newline(); bye(0); } Line.append(s); Line.append('\n'); try {p.sink().write(ByteBuffer.allocate(1));} catch (IOException e) {giveup(e);} } } } ).start(); } } catch (IOException e) {giveup(e);} USec = System.nanoTime() / 1000; } final static void giveup(Exception e) { System.err.println(e); System.exit(1); } final static Any bye(int n) { if (!B) { B = true; unwind(null); Bye.Car.prog(); } System.exit(n); return null; /* Brain-dead Java */ } final static Constructor javaConstructor(Any ex, Class cls, Class[] par) throws NoSuchMethodException { looking: for (Constructor m : cls.getConstructors()) { Class[] types = m.getParameterTypes(); if (types.length == par.length) { for (int i = 0; i < types.length; ++i) if (!(types[i].isAssignableFrom(par[i]))) continue looking; return m; } } throw new NoSuchMethodException(); } final static Method javaMethod(Any ex, Class cls, String nm, Class[] par) throws NoSuchMethodException { looking: for (Method m : cls.getMethods()) { if (m.getName().equals(nm)) { Class[] types = m.getParameterTypes(); if (types.length == par.length) { for (int i = 0; i < types.length; ++i) if (!(types[i].isAssignableFrom(par[i]))) continue looking; return m; } } } throw new NoSuchMethodException(nm); } final static int waitFd(Any ex, int fd, int ms) { int i; Selector sel; Any task = Env.Task, at = At.Car; try { for (;;) { sel = Selector.open(); int t = ms >= 0? ms : Integer.MAX_VALUE; if (fd >= 0 && InFiles[fd] != null) if (InFiles[fd].ready(sel)) t = 0; else InFiles[fd].register(sel); for (Any x = Env.Task = Run.Car; x instanceof Cell; x = x.Cdr) { if (memq(x.Car, task) == null) { if ((i = ((Number)x.Car.Car).Cnt) < 0) { if ((i = ((Number)x.Car.Cdr.Car).Cnt) < t) t = i; } else if (i != fd) { if (i < InFiles.length && InFiles[i] != null) if (InFiles[i].ready(sel)) t = 0; else InFiles[i].register(sel); } } } long d = System.currentTimeMillis(); if (t == 0) sel.selectNow(); else sel.select(t); t = (int)(System.currentTimeMillis() - d); if (ms > 0 && (ms -= t) < 0) ms = 0; for (Any x = Env.Task; x instanceof Cell; x = x.Cdr) { if (memq(x.Car, task) == null) { if ((i = ((Number)x.Car.Car).Cnt) < 0) { if ((i = ((Number)x.Car.Cdr.Car).Cnt - t) > 0) ((Number)x.Car.Cdr.Car).Cnt = i; else { ((Number)x.Car.Cdr.Car).Cnt = -((Number)x.Car.Car).Cnt; At.Car = x.Car.Car; x.Car.Cdr.Cdr.prog(); } } else if (i != fd) { if (i < InFiles.length && InFiles[i] != null && InFiles[i].ready(sel)) { At.Car = x.Car.Car; x.Car.Cdr.prog(); } } } } if (ms == 0 || fd < 0 || InFiles[fd] != null && InFiles[fd].ready(sel)) break; sel.close(); } } catch (IOException e) {giveup(e);} At.Car = at; Env.Task = task; return ms; } final static long initSeed(Any x) { long n; for (n = 0; x instanceof Cell; x = x.Cdr) n += initSeed(x.Car); if (x != Nil) { if (x instanceof Number && ((Number)x).Big == null) n += ((Number)x).Cnt; else { byte b[] = x instanceof Symbol? x.name().getBytes() : ((Number)x).Big.toByteArray(); for (int i = 0; i < b.length; ++i) n += b[i]; } } return n>=0? n*2 : -n*2+1; } final static Any date(int y, int m, int d) { int n; if (m<1 || m>12 || d<1 || d>MonLen[m] && (m!=2 || d!=29 || y%4!=0 || y%100==0 && y%400!=0)) return Nil; n = (12*y + m - 3) / 12; return new Number((4404*y+367*m-1094)/12 - 2*n + n/4 - n/100 + n/400 + d); } final static Any date(int n) { int y = (100*n - 20) / 3652425; n += (y - y/4); y = (100*n - 20) / 36525; n -= 36525*y / 100; int m = (10*n - 5) / 306; int d = (10*n - 306*m + 5) / 10; if (m < 10) m += 3; else { ++y; m -= 9; } return new Cell(new Number(y), new Cell(new Number(m), new Cell(new Number(d), Nil))); } final static Any time(Calendar cal) { return new Number(cal.get(Calendar.HOUR_OF_DAY) * 3600 + cal.get(Calendar.MINUTE) * 60 + cal.get(Calendar.SECOND)); } final static Any time(int h, int m, int s) { if (h < 0 || h > 23 || m < 0 || m > 59 || s < 0 || s > 60) return Nil; return new Number(h * 3600 + m * 60 + s); } final static char firstChar(Any s) { String nm = s.name(); return nm.length() == 0? '\0' : nm.charAt(0); } final static String path(String s) { if (s.length() > 0) if (s.charAt(0) == '+') { if (s.length() > 1 && s.charAt(1) == '@') return '+' + Home + s.substring(1); } else if (s.charAt(0) == '@') return Home + s.substring(1); return s; } final static void unwind(Catch target) { int i, j, n; Bind p; Catch q; Any x, y; while ((q = Catch) != null) { while ((p = Env.Bind) != null) { if ((i = p.Eswp) != 0) { j = i; n = 0; for (;;) { ++n; if (++j == 0 || (p = p.Link) == null) break; if (p.Eswp < i) --j; } do { for (p = Env.Bind, j = n; --j != 0; p = p.Link); if ((p.Eswp -= i) >= 0) { if (p.Eswp > 0) p.Eswp = 0; for (j = p.Cnt; (j -= 2) >= 0;) { y = p.Data[j+1]; x = y.Car; y.Car = p.Data[j]; p.Data[j] = x; } } } while (--n != 0); } if (Env.Bind == q.Env.Bind) break; if (Env.Bind.Eswp == 0) for (i = Env.Bind.Cnt; (i -= 2) >= 0;) Env.Bind.Data[i+1].Car = Env.Bind.Data[i]; Env.Bind = Env.Bind.Link; } while (Env.InFrames != q.Env.InFrames) Env.popInFiles(); while (Env.OutFrames != q.Env.OutFrames) Env.popOutFiles(); Env = q.Env; q.Fin.eval(); Catch = q.Link; if (q == target) return; } while (Env.Bind != null) { if (Env.Bind.Eswp == 0) for (i = Env.Bind.Cnt; (i -= 2) >= 0;) Env.Bind.Data[i+1].Car = Env.Bind.Data[i]; Env.Bind = Env.Bind.Link; } while (Env.InFrames != null) Env.popInFiles(); while (Env.OutFrames != null) Env.popOutFiles(); } final static void error(Any ex, Any x, String msg) { Up.Car = ex == null? Nil : ex; if (msg.length() != 0) { Msg.Car = mkStr(msg); for (Catch p = Catch; p != null; p = p.Link) { Any y = p.Tag; if (y != null) while (y instanceof Cell) { if (msg.indexOf(y.Car.name()) >= 0) throw new Control(ex, p.Tag, y.Car == Nil? Msg.Car : y.Car); y = y.Cdr; } } } InFile.Chr = 0; Break = false; Line.delete(0, Line.length()); Env.pushOutFile(new OutFrame(OutFiles[2], 0)); if (InFile.Name != null) StdErr.Wr.print('[' + InFile.Name + ':' + InFile.Src + "] "); if (ex != null) { StdErr.Wr.print("!? "); StdErr.print(ex); StdErr.newline(); } if (x != null) { StdErr.print(x); StdErr.Wr.print(" -- "); } if (msg.length() != 0) { StdErr.Wr.print(msg); StdErr.newline(); if (Err.Car != Nil && !Jam) { Jam = true; Err.Car.prog(); Jam = false; } load(null, '?', Nil); } unwind(null); Env.Intern = pico; Env.Args = null; Env.Next = 0; Env.Task = Env.Make = Env.Yoke = null; } final static Any err(Any ex, Any x, String msg) { error(ex, x, msg); throw new Control(); } final static Any brkLoad(Any x) { if (!Break) { Break = true; OutFile.Wr.flush(); Brk = new Bind(); Brk.add(Up.Car); Brk.add(Up); Up.Car = x; Brk.add(Run.Car); Brk.add(Run); Run.Car = Nil; Brk.add(At.Car); Brk.add(At); Env.Bind = Brk; Env.pushOutFile(new OutFrame(OutFiles[1], 0)); OutFile.print(x); OutFile.newline(); load(null, '!', Nil); Env.popOutFiles(); At.Car = Brk.Data[4]; Run.Car = Brk.Data[2]; x = Up.Car; Up.Car = Brk.Data[0]; Env.Bind = Brk.Link; Break = false; } return x; } final static void trace(int i, Any x, String s) { if (i > 64) i = 64; while (--i >= 0) StdErr.space(); if (x instanceof Symbol) StdErr.print(x); else { StdErr.print(x.Car); StdErr.space(); StdErr.print(x.Cdr); StdErr.space(); StdErr.print(This.Car); } StdErr.Wr.print(s); } final static Any execError(Any x) {return err(null, x, "Can't execute");} final static Any protError(Any x) {return err(null, x, "Protected symbol");} final static Any symError(Any x) {return err(null, x, "Symbol expected");} final static Any symNsError(Any ex, Any x) {return err(ex, x, "Bad symbol namespace");} final static Any argError(Any ex, Any x) {return err(ex, x, "Bad argument");} final static Any cntError(Any ex, Any x) {return err(ex, x, "Small number expected");} final static void needVar(Any ex, Any x) {if (x instanceof Number) err(ex, x, "Variable expected");} final static void badFd(Any ex, Any x) {err(ex, x, "Bad FD");} final static void closeErr(IOException e) {err(null, null, e.toString());} final static Any load(Any ex, char pr, Any x) { if (x instanceof Symbol && firstChar(x) == '-') return ((Symbol)x).parse(true,null).eval(); Symbol ns = Env.Intern; Env.pushInFile(x.rdOpen(ex)); Transient.clear(); x = Nil; for (;;) { Any y; if (InFile != StdIn) y = InFile.read('\0'); else { if (pr != '\0' && InFile.Chr == 0) { OutFile.Wr.print(Prompt.Car.run().name() + pr); OutFile.space(); OutFile.Wr.flush(); } y = InFile.read('\n'); while (InFile.Chr > 0) { if (InFile.Chr == '\n') { InFile.Chr = 0; break; } if (InFile.Chr == '#') InFile.comment(); else { if (InFile.Chr > ' ') break; InFile.get(); } } } if (y == Nil) { Env.Intern = ns; Env.popInFiles(); Transient.clear(); return x; } if (InFile != StdIn || InFile.Chr != 0 || pr == '\0') x = y.eval(); else { Any at = At.Car; x = At.Car = y.eval(); At3.Car = At2.Car; At2.Car = at; OutFile.Wr.print("-> "); OutFile.Wr.flush(); OutFile.print(x); OutFile.newline(); } } } final static String opt() { if (Argv.length == 0 || Argv[0].equals("-")) return null; String s = Argv[0]; String[] a = new String[Argv.length-1]; System.arraycopy(Argv, 1, a, 0, a.length); Argv = a; return s; } final static Any loadAll(Any ex) { String s; Any x = Nil; while ((s = opt()) != null) x = load(ex, '\0', mkStr(s)); return x; } final static Any undefined(Any x, Any ex) { return err(ex, x, "Undefined"); } final static Any[] append(Any[] a, int i, Any x) { if (i == a.length) { Any[] b = new Any[i*2]; System.arraycopy(a, 0, b, 0, i); a = b; } a[i] = x; return a; } final static int allocPid() { int i; for (i = 2; Pids[i] != null; ++i) { if (i == Pids.length) { Process[] p = new Process[i*2]; System.arraycopy(Pids, 0, p, 0, i); Pids = p; break; } } return i; } final static int allocFd() { int i; for (i = 3; InFiles[i] != null || OutFiles[i] != null; ++i) { if (i == InFiles.length) { PicoLispReader[] r = new PicoLispReader[i*2]; System.arraycopy(InFiles, 0, r, 0, i); InFiles = r; PicoLispWriter[] w = new PicoLispWriter[i*2]; System.arraycopy(OutFiles, 0, w, 0, i); OutFiles = w; break; } } return i; } final static Any mkSocket(SocketChannel chan) throws IOException { int i = allocFd(); Socket sock = chan.socket(); new PicoLispReader(sock.getInputStream(), i, chan, SelectionKey.OP_READ); new PicoLispWriter(sock.getOutputStream(), i); return new Number(i); } final static Any accept(Any ex, int i) { try { SocketChannel chan = ((ServerSocketChannel)InFiles[i].Chan).accept(); Adr.Car = mkStr(chan.socket().getInetAddress().getHostAddress()); return mkSocket(chan); } catch (IOException e) {} return null; } final static Any mkChar(int c) {return new Symbol(null, "" + (char)(c >= 0x10000? 0xFFFF : c));} final static Any mkStr(String nm) {return nm == null || nm.length() == 0? Nil : new Symbol(null, nm);} final static Any mkStr(StringBuilder sb) {return mkStr(sb.toString());} final static Symbol mkSymbol(Any val) {return new Symbol(val, null);} final static Symbol mkSymbol(Any val, String nm, Namespace table) { Symbol sym; if ((sym = table.get(nm)) == null) { sym = new Symbol(val, nm); table.put(nm, sym); } return sym; } final static Any strToNum(String s, int scl) throws NumberFormatException { if (s.length() != 0 && s.charAt(0) == '+') s = s.substring(1); if (s.indexOf('.') <= 0) return new Number(s); return new Number((new BigDecimal(s)).setScale(scl, RoundingMode.HALF_UP).unscaledValue()); } final static Any format(Any z, int scl, Any x) { char sep = '.', ign = '\0'; if (x instanceof Cell) { sep = firstChar(x.Car.eval()); if ((x = x.Cdr) instanceof Cell) ign = firstChar(x.Car.eval()); } if (z instanceof Number) return mkStr(((Number)z).toString(scl,sep,ign)); String s = z.name(); StringBuilder sb = new StringBuilder(); for (int i = 0; i < s.length(); ++i) { char c = s.charAt(i); if (c != ign) sb.append(c == sep? '.' : c); } try {return strToNum(sb.toString(), scl);} catch (NumberFormatException e) {return Nil;} } final static Any fish(Any ex, Any foo, Any[] v, Any res) { if (foo.apply(ex, false, v, 1) != Nil) return new Cell(v[0], res); if (v[0] instanceof Cell) { Any x = v[0]; if ((v[0] = x.Cdr) != Nil) res = fish(ex, foo, v, res); v[0] = x.Car; res = fish(ex, foo, v, res); v[0] = x; } return res; } final static Any all(Namespace table) { Any x = Nil; for (Iterator it = table.values().iterator(); it.hasNext();) x = new Cell(it.next(), x); return x; } final static Any meta(Any x, Any y) { Any z; for (; x instanceof Cell; x = x.Cdr) if (x.Car instanceof Symbol && ((z = x.Car.get(y)) != Nil || (z = meta(x.Car.Car, y)) != Nil)) return z; return Nil; } final static boolean isa(Any cls, Any x) { Any z; z = x = x.Car; while (x instanceof Cell) { if (!(x.Car instanceof Cell)) { while (x.Car instanceof Symbol) { if (cls == x.Car || isa(cls, x.Car)) return true; if (!((x = x.Cdr) instanceof Cell) || z == x) return false; } return false; } if (z == (x = x.Cdr)) return false; } return false; } final static void redefMsg(Any x, Any y) { StdErr.Wr.print("# "); StdErr.print(x); if (y != null) { StdErr.space(); StdErr.print(y); } StdErr.Wr.println(" redefined"); StdErr.Wr.flush(); } final static void putSrc(Symbol s, Any k) { if (Dbg.Car != Nil && InFile != null && InFile.Name != null) { Any x = new Cell(new Number(InFile.Src), mkSymbol(null, InFile.Name, Transient)); Any y = s.get(Dbg); if (k == null) { if (y == Nil) s.put(Dbg, new Cell(x, Nil)); else y.Car = x; } else if (y == Nil) s.put(Dbg, new Cell(Nil, new Cell(x, Nil))); else { for (Any z = y.Cdr; z instanceof Cell; z = z.Cdr) if (z.Car.Car == k) { z.Car.Cdr = x; return; } y.Cdr = new Cell(new Cell(k, x), y.Cdr); } } } final static void redefine(Symbol s, Any x) { if (s.Car != Nil && s != s.Car && !x.equal(s.Car)) redefMsg(s, null); s.Car = x; putSrc(s, null); } final static int xInt(Any x) {return ((Number)x).Cnt;} final static int evInt(Any ex) {return ((Number)ex.Car.eval()).Cnt;} final static long xLong(Any x) {return ((Number)x).longValue();} final static long evLong(Any ex) {return ((Number)ex.Car.eval()).longValue();} final static String evString(Any ex) {return ex.Car.eval().name();} final static Any circ(Any x) { HashSet mark = new HashSet(); for (;;) { mark.add(x); if (!((x = x.Cdr) instanceof Cell)) return null; if (mark.contains(x)) return x; } } final static Any fill(Any x, Any s) { Any y, z; if (x instanceof Number || x == Nil) return null; if (x instanceof Symbol) return x != x.Car && (s==Nil? x!=At && firstChar(x)=='@' : memq(x,s)!=null)? x.Car : null; if (x.Car == Up) { x = x.Cdr; if (!((y = x.Car.eval()) instanceof Cell)) return (z = fill(x.Cdr, s)) == null? x.Cdr : z; Any w = y; while (y.Cdr instanceof Cell) y = y.Cdr; y.Cdr = (z = fill(x.Cdr, s)) == null? x.Cdr : z; return w; } if ((y = fill(x.Car, s)) != null) { z = fill(x.Cdr, s); return new Cell(y, z == null? x.Cdr : z); } if ((y = fill(x.Cdr, s)) != null) return new Cell(x.Car, y); return null; } final static boolean isBlank(Any x) { if (x != Nil) { if (!(x instanceof Symbol)) return false; String s = x.name(); if (s != null) for (int i = 0; i < s.length(); ++i) if (s.charAt(i) > ' ') return false; } return true; } final static Any funq(Any x) { Any y; if (x == Nil || x instanceof Symbol) return Nil; if (x instanceof Number) return ((Number)x).Big == null && ((Number)x).Cnt <= MaxFun? x : Nil; for (y = x.Cdr; y instanceof Cell; y = y.Cdr) { if (y == x) return Nil; if (y.Car instanceof Cell) { if (y.Car.Car instanceof Number) { if (y.Cdr instanceof Cell) return Nil; } else if (y.Car.Car == Nil || y.Car.Car == T) return Nil; } else if (y.Cdr != Nil) return Nil; } if (y != Nil) return Nil; if ((x = x.Car) == Nil) return T; for (y = x; y instanceof Cell;) if (y.Car instanceof Number || y.Car instanceof Cell || y.Car == Nil || y.Car == T || x == (y = y.Cdr)) return Nil; return y instanceof Number || y == T? Nil : x; } final static Any trim(Any x) { Any y; if (!(x instanceof Cell)) return x; if ((y = trim(x.Cdr)) == Nil && isBlank(x.Car)) return Nil; return new Cell(x.Car, y); } final static Any nCdr(int n, Any x) { while (--n >= 0) x = x.Cdr; return x; } final static Any nth(int n, Any x) { if (--n < 0) return Nil; return nCdr(n,x); } final static Any sort(Any ex, Any lst, Any foo) { Any x = lst, l = Nil, r = Nil, c = Nil; do { int i = foo == Nil? lst.Car.compare(x.Car) : foo.apply(ex, false, new Any[] {x.Car, lst.Car}, 2) == Nil? -1 : 1; if (i > 0) l = new Cell(x.Car, l); else if (i < 0) r = new Cell(x.Car, r); else c = new Cell(x.Car, c); } while ((x = x.Cdr) instanceof Cell); if ((lst = l) instanceof Cell) { if (l.Cdr instanceof Cell) for (lst = l = sort(ex, l, foo); (l = l.Cdr).Cdr instanceof Cell;); if (c instanceof Cell) for (l.Cdr = c; (l = l.Cdr).Cdr instanceof Cell;); } else if ((lst = c) instanceof Cell) for (l = c; l.Cdr instanceof Cell; l = l.Cdr); else return sort(ex, r, foo); if (r instanceof Cell) l.Cdr = r.Cdr instanceof Cell? sort(ex, r, foo) : r; return lst; } final static Any consIdx(Any x, Any y) { if (x.Cdr.Cdr instanceof Cell) y = consIdx(x.Cdr.Cdr, y); y = new Cell(x.Car, y); return x.Cdr.Car instanceof Cell? consIdx(x.Cdr.Car, y) : y; } final static Any idx(Any var, Any key, int flg) { Any x, y, z, p; boolean ad; int i; if (key == null) return var.Car instanceof Cell? consIdx(var.Car, Nil) : Nil; if (!((x = var.Car) instanceof Cell)) { if (flg > 0) var.Car = new Cell(key, Nil); return Nil; } p = var; ad = true; for (;;) { if ((i = key.compare(x.Car)) == 0) { if (flg < 0) { if (!(x.Cdr.Car instanceof Cell)) { if (ad) p.Car = x.Cdr.Cdr; else p.Cdr = x.Cdr.Cdr; } else if (!((y = x.Cdr.Cdr) instanceof Cell)) { if (ad) p.Car = x.Cdr.Car; else p.Cdr = x.Cdr.Car; } else if (!((z = y.Cdr.Car) instanceof Cell)) { x.Car = y.Car; x.Cdr.Cdr = y.Cdr.Cdr; } else { while (z.Cdr.Car instanceof Cell) z = (y = z).Cdr.Car; x.Car = z.Car; y.Cdr.Car = z.Cdr.Cdr; } } return x; } if (!(x.Cdr instanceof Cell)) { if (flg > 0) x.Cdr = i < 0? new Cell(new Cell(key, Nil), Nil) : new Cell(Nil, new Cell(key, Nil)); return Nil; } if (i < 0) { if (!(x.Cdr.Car instanceof Cell)) { if (flg > 0) x.Cdr.Car = new Cell(key, Nil); return Nil; } p = x.Cdr; ad = true; x = p.Car; } else { if (!(x.Cdr.Cdr instanceof Cell)) { if (flg > 0) x.Cdr.Cdr = new Cell(key, Nil); return Nil; } p = x.Cdr; ad = false; x = p.Cdr; } } } final static Any consLup(Any x, Any y, Any from, Any to) { if (x instanceof Cell) { if (x.Car == T) return consLup(x.Cdr.Car, y, from, to); if (!(x.Car instanceof Cell)) return consLup(x.Cdr.Cdr, y, from, to); if (to.compare(x.Car.Car) >= 0) { y = consLup(x.Cdr.Cdr, y, from, to); if (from.compare(x.Car.Car) <= 0) { y = new Cell(x.Car, y); return consLup(x.Cdr.Car, y, from, to); } } if (from.compare(x.Car.Car) <= 0) return consLup(x.Cdr.Car, y, from, to); } return y; } final static Any member(Any x, Any y) { Any z = y; while (y instanceof Cell) { if (x.equal(y.Car)) return y; if (z == (y = y.Cdr)) return null; } return y == Nil || !x.equal(y)? null : y; } final static Any memq(Any x, Any y) { Any z = y; while (y instanceof Cell) { if (x == y.Car) return y; if (z == (y = y.Cdr)) return null; } return y == Nil || x != y? null : y; } final static int indx(Any x, Any y) { int i = 1; Any z = y; while (y instanceof Cell) { if (x.equal(y.Car)) return i; ++i; if (z == (y = y.Cdr)) return 0; } return 0; } final static boolean match(Any p, Any d) { Any x; for (;;) { if (!(p instanceof Cell)) { if (p instanceof Symbol && firstChar(p) == '@') { p.Car = d; return true; } return p.equal(d); } if ((x = p.Car) instanceof Symbol && firstChar(x) == '@') { if (!(d instanceof Cell)) { if (d.equal(p.Cdr)) { x.Car = Nil; return true; } return false; } if (match(p.Cdr, d.Cdr)) { x.Car = new Cell(d.Car, Nil); return true; } if (match(p.Cdr, d)) { x.Car = Nil; return true; } if (match(p, d.Cdr)) { x.Car = new Cell(d.Car, x.Car); return true; } } if (!(d instanceof Cell) || !match(x, d.Car)) return false; p = p.Cdr; d = d.Cdr; } } final static boolean unify(Number n1, Any x1, Number n2, Any x2) { lookup1: while (x1 instanceof Symbol && firstChar(x1) == '@') { for (Any x = Penv; x.Car instanceof Cell; x = x.Cdr) if (n1.Cnt == ((Number)x.Car.Car.Car).Cnt && x1 == x.Car.Car.Cdr) { n1 = (Number)x.Car.Cdr.Car; x1 = x.Car.Cdr.Cdr; continue lookup1; } break; } lookup2: while (x2 instanceof Symbol && firstChar(x2) == '@') { for (Any x = Penv; x.Car instanceof Cell; x = x.Cdr) if (n2.Cnt == ((Number)x.Car.Car.Car).Cnt && x2 == x.Car.Car.Cdr) { n2 = (Number)x.Car.Cdr.Car; x2 = x.Car.Cdr.Cdr; continue lookup2; } break; } if (n1.Cnt == n2.Cnt && x1.equal(x2)) return true; if (x1 instanceof Symbol && firstChar(x1) == '@') { if (x1 != At) { Penv = new Cell(new Cell(new Cell(n1,x1), Nil), Penv); Penv.Car.Cdr = new Cell(n2,x2); } return true; } if (x2 instanceof Symbol && firstChar(x2) == '@') { if (x2 != At) { Penv = new Cell(new Cell(new Cell(n2,x2), Nil), Penv); Penv.Car.Cdr = new Cell(n1,x1); } return true; } if (!(x1 instanceof Cell) || !(x2 instanceof Cell)) return x1.equal(x2); Any env = Penv; if (unify(n1, x1.Car, n2, x2.Car) && unify(n1, x1.Cdr, n2, x2.Cdr)) return true; Penv = env; return false; } final static Any lup(Number n, Any x) { lup: while (x instanceof Symbol && firstChar(x) == '@') { for (Any y = Penv; y.Car instanceof Cell; y = y.Cdr) if (n.Cnt == ((Number)y.Car.Car.Car).Cnt && x == y.Car.Car.Cdr) { n = (Number)y.Car.Cdr.Car; x = y.Car.Cdr.Cdr; continue lup; } break; } return x instanceof Cell? new Cell(lup(n, x.Car), lup(n, x.Cdr)) : x; } final static Any lookup(Number n, Any x) { return (x = lup(n,x)) instanceof Symbol && firstChar(x) == '@'? Nil : x; } final static Any uniFill(Any x) { if (x instanceof Number) return x; if (x instanceof Symbol) return lup((Number)Pnl.Car, x); return new Cell(uniFill(x.Car), uniFill(x.Cdr)); } final static Any evRun(boolean ev, Any x, int cnt, Any lst) { int i, j = cnt, n = 0; Bind b, bnd = Env.Bind; Any s, y, z; do { ++n; i = bnd.Eswp; bnd.Eswp -= cnt; if (i == 0) { for (i = 0; i < bnd.Cnt; i+= 2) { s = bnd.Data[i+1]; y = s.Car; s.Car = bnd.Data[i]; bnd.Data[i] = y; } if (bnd.Data[1] == At && --j == 0) break; } } while ((bnd = bnd.Link) != null); if (!(lst instanceof Cell)) z = ev? x.eval() : x.run(); else { bnd = new Bind(); do { s = lst.Car; bnd.add(s.Car); bnd.add(s); exclude: for (b = Env.Bind, j = n; ;) { for (i = 0; i < b.Cnt; i+= 2) if (s == b.Data[i+1]) { s.Car = b.Data[i]; break exclude; } if (--j == 0 || (b = b.Link) == null) break; } } while ((lst = lst.Cdr) instanceof Cell); Env.Bind = bnd; z = ev? x.eval() : x.run(); for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; } do { for (bnd = Env.Bind, i = n; --i != 0; bnd = bnd.Link); if ((bnd.Eswp += cnt) == 0) for (i = bnd.Cnt; (i -= 2) >= 0;) { s = bnd.Data[i+1]; y = s.Car; s.Car = bnd.Data[i]; bnd.Data[i] = y; } } while (--n > 0); return z; } final static Any evMethod(Any o, Any ex, Any x) { int i; Any y = ex.Car; Any cls = TheCls, key = TheKey; Bind bnd = new Bind(); bnd.add(At.Car); bnd.add(At); while (y instanceof Cell) { bnd.add(x.Car.eval()); // Save new value bnd.add(y.Car); // and symbol x = x.Cdr; y = y.Cdr; } if (y == Nil || y != At) { i = bnd.Cnt; if (y != Nil) { bnd.add(y.Car); // Save old value bnd.add(y); // and symbol y.Car = x; // Set new value } do { y = bnd.Data[--i]; x = y.Car; y.Car = bnd.Data[--i]; // Set new value bnd.Data[i] = x; // Save old value } while (i > 0); bnd.add(This.Car); bnd.add(This); This.Car = o; Env.Bind = bnd; y = cls; cls = Env.Cls; Env.Cls = y; y = key; key = Env.Key; Env.Key = y; x = ex.Cdr.prog(); } else { int next, argc, j = 0; Any arg, args[], av[] = null; if (x instanceof Cell) { av = new Any[6]; do av = append(av, j++, x.Car.eval()); while ((x = x.Cdr) instanceof Cell); } next = Env.Next; Env.Next = 0; argc = Env.ArgC; Env.ArgC = j; arg = Env.Arg; Env.Arg = Nil; args = Env.Args; Env.Args = av; i = bnd.Cnt; do { y = bnd.Data[--i]; x = y.Car; y.Car = bnd.Data[--i]; // Set new value bnd.Data[i] = x; // Save old value } while (i > 0); bnd.add(This.Car); bnd.add(This); This.Car = o; Env.Bind = bnd; y = cls; cls = Env.Cls; Env.Cls = y; y = key; key = Env.Key; Env.Key = y; x = ex.Cdr.prog(); Env.Args = args; Env.Arg = arg; Env.ArgC = argc; Env.Next = next; } for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; Env.Cls = cls; Env.Key = key; return x; } final static Any method(Any x) { Any y, z; if ((y = x.Car) instanceof Cell) { while ((z = y.Car) instanceof Cell) { if (z.Car == TheKey) return z.Cdr; if (!((y = y.Cdr) instanceof Cell)) return null; } do if ((x = method((TheCls = y).Car)) != null) return x; while ((y = y.Cdr) instanceof Cell); } return null; } final static Any extra(Any x) { Any y; for (x = x.Car; x.Car instanceof Cell; x = x.Cdr); while (x instanceof Cell) { if (x == Env.Cls || (y = extra(x.Car)) == null) { while ((x = x.Cdr) instanceof Cell) if ((y = method((TheCls = x).Car)) != null) return y; return null; } if (y != null && y != T) return y; x = x.Cdr; } return T; } final static Any loop(Any x) { Any a, y, z; for (;;) { y = x; do { if ((z = y.Car) instanceof Cell) { if (z.Car == Nil) { if ((a = (z = z.Cdr).Car.eval()) == Nil) return z.Cdr.prog(); At.Car = a; } else if (z.Car == T) { if ((a = (z = z.Cdr).Car.eval()) != Nil) { At.Car = a; return z.Cdr.prog(); } } else z.eval(); } } while ((y = y.Cdr) instanceof Cell); } } /* Ersatz PicoLisp Reader */ final static class InFrame { InFrame Link; PicoLispReader Rd; int Pid; InFrame(PicoLispReader rd, int pid) { Link = Env.InFrames; Rd = rd; Pid = pid; } } final static class PicoLispReader { Reader Rd; String Name; char Eof1, Eof2; int Fd, Chr, Src, Ops; InputStream Stream; SelectableChannel Chan; SelectionKey Key; PicoLispReader(Reader rd, String nm, int fd, SelectableChannel chan, int ops) { Rd = rd; Name = nm; InFiles[Fd = fd] = this; Chan = chan; Ops = ops; } PicoLispReader(InputStream in, int fd, SelectableChannel chan, int ops) { this(in == null? null : new InputStreamReader(in), null, fd, chan, ops); Stream = in; } PicoLispReader(String s, char eof1, char eof2) { Rd = new StringReader(s); Eof1 = eof1; Eof2 = eof2; } final boolean register(Selector sel) { if (Ops != 0) { try { Chan.configureBlocking(false); Key = Chan.register(sel, Ops); return true; } catch (IOException e) {} } return false; } final boolean ready(Selector sel) throws IOException { if (Key == null) return Rd != null && Rd.ready() || Stream != null && Stream.available() > 0; boolean rdy = (Key.readyOps() & Ops) != 0; Key.cancel(); Key = null; try{Chan.configureBlocking(true);} catch (IOException e) {} return rdy; } final void close() { try { if (Chan != null) Chan.close(); if (Rd != null) Rd.close(); InFiles[Fd] = null; } catch (IOException e) {closeErr(e);} } final void eofErr() {err(null, null, "EOF Overrun");} final void badInput() {err(null, null, "Bad input '" + (char)Chr + "'");} final int get() { try { if (this != StdIn || Term == null) Chr = Rd.read(); else { while (Line.length() == 0) { waitFd(null, 0, -1); ((Pipe.SourceChannel)StdIn.Chan).read(ByteBuffer.allocate(1)); } Chr = Line.charAt(0); Line.deleteCharAt(0); } if (Chr < 0) { if ((Chr = Eof1) != 0) Eof1 = '\0'; else if ((Chr = Eof2) != 0) Eof2 = '\0'; else Chr = -1; } return Chr; } catch (IOException e) {return Chr = -1;} } final boolean eol() { if (Chr < 0) return true; if (Chr == '\n') { Chr = 0; return true; } if (Chr == '\r') { get(); if (Chr == '\n') Chr = 0; return true; } return false; } final int skipc(int c) { if (Chr < 0) return Chr; for (;;) { while (Chr <= ' ') { get(); if (Chr < 0) return Chr; } if (Chr != c) return Chr; get(); while (Chr != '\n') { if (Chr < 0) return Chr; get(); } } } final void comment() { get(); if (Chr != '{') { while (Chr != '\n') { if (Chr < 0) return; get(); } } else { for (;;) { get(); if (Chr < 0) return; if (Chr == '}' && (get() == '#')) break; } get(); } } final int skip() { for (;;) { if (Chr < 0) return Chr; while (Chr <= ' ') { get(); if (Chr < 0) return Chr; } if (Chr != '#') return Chr; comment(); } } final boolean testEsc() { for (;;) { if (Chr < 0) return false; if (Chr == '^') { get(); if (Chr == '@') badInput(); if (Chr == '?') Chr = 127; else Chr &= 0x1F; return true; } if (Chr != '\\') return true; if (get() != '\n') return true; do get(); while (Chr == ' ' || Chr == '\t'); } } final Any rdAtom(int c) { Namespace table = Env.intern(); StringBuilder sb = new StringBuilder(); sb.append((char)c); while (Chr > 0) { if (Chr == '~') { Symbol s = mkSymbol(null, sb.toString(), table); if (!(((Symbol)s.Car).Obj instanceof Namespace)) symNsError(null, s); table = (Namespace)((Symbol)s.Car).Obj; sb = new StringBuilder(); } else { if (Delim.indexOf(Chr) >= 0) break; if (Chr == '\\') get(); sb.append((char)Chr); } get(); } String s = sb.toString(); if (s.equals("NIL")) return Nil; try {return strToNum(s, ((Number)Scl.Car).Cnt);} catch (NumberFormatException e) {return mkSymbol(Nil, s, table);} } final Any rdList() { Any x, res; get(); for (;;) { if (skip() == ')') { get(); return Nil; } if (Chr == ']') return Nil; if (Chr != '~') { res = x = new Cell(read0(false), Nil); break; } get(); if ((res = x = read0(false).eval()) instanceof Cell) { while (x.Cdr instanceof Cell) x = x.Cdr; break; } } for (;;) { if (skip() == ')') { get(); break; } if (Chr == ']') break; if (Chr == '.') { get(); if (Delim.indexOf(Chr) >= 0) { x.Cdr = skip()==')' || Chr==']'? res : read0(false); if (skip() == ')') get(); else if (Chr != ']') err(null, x, "Bad dotted pair"); break; } x = x.Cdr = new Cell(rdAtom('.'), Nil); } else if (Chr != '~') x = x.Cdr = new Cell(read0(false), Nil); else { get(); x.Cdr = read0(false).eval(); while (x.Cdr instanceof Cell) x = x.Cdr; } } return res; } final Any read0(boolean top) { Any x, y; if (skip() < 0) { if (top) return Nil; eofErr(); } if (top && Rd instanceof LineNumberReader) Src = ((LineNumberReader)Rd).getLineNumber() + 1; if (Chr == '(') { x = rdList(); if (top && Chr == ']') get(); return x; } if (Chr == '[') { x = rdList(); if (Chr != ']') err(null, x, "Super parentheses mismatch"); get(); return x; } if (Chr == '\'') { get(); return new Cell(Quote, read0(top)); } if (Chr == ',') { get(); x = read0(top); if (Uni.Car != T) x = (y = idx(Uni, x, 1)) instanceof Cell? y.Car : x; return x; } if (Chr == '`') { get(); return read0(top).eval(); } if (Chr == '"') { get(); if (Chr == '"') { get(); return Nil; } if (!testEsc()) eofErr(); StringBuilder sb = new StringBuilder(); sb.append((char)Chr); while (get() != '"') { if (!testEsc()) eofErr(); sb.append((char)Chr); } get(); return mkSymbol(null, sb.toString(), Transient); } if (Chr == ')' || Chr == ']' || Chr == '~') badInput(); if (Chr == '\\') get(); int i = Chr; get(); return rdAtom(i); } final Any read(int end) { if (Chr == 0) get(); if (Chr == end) return Nil; return read0(true); } final Any token(Any x, char c) { if (Chr == 0) get(); if (skipc(c) < 0) return null; if (Chr == '"') { get(); if (Chr == '"') { get(); return Nil; } if (!testEsc()) return Nil; Any y = x = new Cell(mkChar(Chr), Nil); while (get() != '"' && testEsc()) y = y.Cdr = new Cell(mkChar(Chr), Nil); get(); return x; } if (Chr >= '0' && Chr <= '9') { StringBuilder sb = new StringBuilder(); sb.append((char)Chr); while (get() >= '0' && Chr <= '9' || Chr == '.') sb.append((char)Chr); try {return strToNum(sb.toString(), ((Number)Scl.Car).Cnt);} catch (NumberFormatException e) {} } if (Chr != '+' && Chr != '-') { String s = x.name(); if (Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || s.indexOf(Chr) >= 0) { if (Chr == '\\') get(); StringBuilder sb = new StringBuilder(); sb.append((char)Chr); while (get() >= '0' && Chr <= '9' || Chr >= 'A' && Chr <= 'Z' || Chr == '\\' || Chr >= 'a' && Chr <= 'z' || s.indexOf(Chr) >= 0) { if (Chr == '\\') get(); sb.append((char)Chr); } s = sb.toString(); return s.equals("NIL")? Nil : mkSymbol(Nil, s, Env.intern()); } } c = (char)Chr; get(); return mkChar(c); } } /* Ersatz PicoLisp Printer */ final static class OutFrame { OutFrame Link; PicoLispWriter Wr; int Pid; OutFrame(PicoLispWriter wr, int pid) { Link = Env.OutFrames; Wr = wr; Pid = pid; } } final static class PicoLispWriter { PrintWriter Wr; String Name; int Fd; PicoLispWriter(PrintWriter wr, String nm, int fd) { Wr = wr; Name = nm; OutFiles[Fd = fd] = this; } PicoLispWriter(OutputStream out, int fd) { this(new PrintWriter(out), null, fd); } final void close() { Wr.close(); OutFiles[Fd] = null; } final void print(Any x) {Wr.print(x.toString());} final void space() {Wr.print(' ');} final void newline() { Wr.println(); Wr.flush(); } } /* Ersatz PicoLisp VM */ final static class Bind { Bind Link; Any[] Data; int Cnt, Eswp; Bind() { Link = Env.Bind; Data = new Any[12]; } final void add(Any x) {Data = append(Data, Cnt++, x);} } final static class Env { int Next, ArgC, Trace; Bind Bind; Symbol Intern; Any Arg, Args[], Cls, Key, Task, Make, Yoke; InFrame InFrames; OutFrame OutFrames; Env() {Intern = pico;} Env(Env env) { Next = env.Next; ArgC = env.ArgC; Trace = env.Trace; Bind = env.Bind; Intern = env.Intern; Arg = env.Arg; Args = env.Args; Cls = env.Cls; Key = env.Key; Task = env.Task; Make = env.Make; Yoke = env.Yoke; InFrames = env.InFrames; OutFrames = env.OutFrames; } final Namespace intern() { return (Namespace)((Symbol)Intern.Car).Obj; } final void pushInFile(InFrame in) { InFrames = in; InFile = InFiles[in.Rd.Fd]; } final void popInFiles() { if (InFrames.Pid != 0) { InFile.close(); if (InFrames.Pid > 1) { try { Pids[InFrames.Pid].waitFor(); Pids[InFrames.Pid] = null; } catch (InterruptedException e) {} //#! sighandler() } } InFile = (InFrames = InFrames.Link) == null? StdIn : InFiles[InFrames.Rd.Fd]; } final void pushOutFile(OutFrame out) { OutFrames = out; OutFile = OutFiles[out.Wr.Fd]; } final void popOutFiles() { if (OutFrames.Pid != 0) { OutFile.close(); if (OutFrames.Pid > 1) { try { Pids[OutFrames.Pid].waitFor(); Pids[OutFrames.Pid] = null; } catch (InterruptedException e) {} //#! sighandler() } } OutFile = (OutFrames = OutFrames.Link) == null? StdOut : OutFiles[OutFrames.Wr.Fd]; } } final static class Catch { Catch Link; Any Tag, Fin; Env Env; Catch(Any tag, Any fin, Env env) { Tag = tag; Fin = fin; Env = new Env(env); Link = Catch; Catch = this; } } final static class Control extends RuntimeException { Any Tag, Val; Control() {} Control(Any ex, Any tag, Any val) { Tag = tag; Val = val; for (Catch p = Catch; p != null; p = p.Link) if (p.Tag == T || p.Tag == tag) { unwind(p); return; } err(ex, tag, "Tag not found"); } } final static class Namespace extends HashMap { final void copy(Namespace table) { for (Iterator it = values().iterator(); it.hasNext();) { Symbol sym = it.next(); if (table.get(sym.Name) == null) table.put(sym.Name, sym); } } } static abstract class Any { Any Car, Cdr; abstract Any put(Any key, Any val); abstract Any get(Any key); abstract Any prop(Any key); abstract Any putl(Any lst); abstract Any getl(); abstract Any eval(); abstract Any prog(); abstract Any run(); abstract Any call(Any ex); abstract Any func(Any ex); abstract Any apply(Any ex, boolean cf, Any[] v, int n); abstract boolean equal(Any x); abstract int compare(Any x); abstract long length(); abstract long size(); abstract InFrame rdOpen(Any ex); abstract OutFrame wrOpen(Any ex); abstract String name(); } final static class Number extends Any { int Cnt; BigInteger Big; Number(int i) {Cnt = i;} Number(long n) { if (n >= Integer.MIN_VALUE && n <= Integer.MAX_VALUE) Cnt = (int)n; else Big = new BigInteger(new byte[] {(byte)(n>>56), (byte)(n>>48), (byte)(n>>40), (byte)(n>>32), (byte)(n>>24), (byte)(n>>16), (byte)(n>>8), (byte)n}); } Number(BigInteger b) { if (b.bitLength() < 32) Cnt = b.intValue(); else Big = b; } Number(String s) { try {Cnt = Integer.parseInt(s);} catch (NumberFormatException e) {Big = new BigInteger(s);} } final long longValue() {return Big == null? Cnt : Big.longValue();} final static BigInteger big(int i) { return new BigInteger(new byte[] {(byte)(i>>24), (byte)(i>>16), (byte)(i>>8), (byte)i}); } final Any put(Any key, Any val) {return symError(this);} final Any get(Any key) {return symError(this);} final Any prop(Any key) {return symError(this);} final Any putl(Any lst) {return symError(this);} final Any getl() {return symError(this);} final Any eval() {return this;} final Any prog() {return execError(this);} final Any run() {return execError(this);} final Any call(Any ex) {return ex;} final Any func(Any ex) { try { switch(Cnt) { case 0: // (quote . any) -> any return ex.Cdr; case 1: // (meth 'obj ['any ..]) -> any return doMeth(ex); 1 default: return undefined(this, ex); } } catch (Throwable e) { if (e instanceof Control) throw (Control)e; return err(ex, null, e.toString()); } } final static Any doMeth(Any ex) { Any x, y, z; z = (x = ex.Cdr).Car.eval(); for (TheKey = ex.Car; ; TheKey = TheKey.Car) if (TheKey.Car instanceof Number) { TheCls = null; if ((y = method(z)) != null) return evMethod(z, y, x.Cdr); err(ex, TheKey, "Bad message"); } } 1 final Any apply(Any ex, boolean cf, Any[] v, int n) { Any x, y = Nil; if (n > 0) { y = x = new Cell(mkSymbol(cf? v[0].Car : v[0]), Nil); for (int i = 1; i < n; ++i) x = x.Cdr = new Cell(mkSymbol(cf? v[i].Car : v[i]), Nil); } return func(new Cell(this, y)); } final boolean equal(Any x) { if (x == this) return true; if (!(x instanceof Number)) return false; Number num = (Number)x; if (Big == null) return num.Big == null && Cnt == num.Cnt; return Big.equals(num.Big); } final int compare(Any x) { if (x == this) return 0; if (x == Nil) return +1; if (!(x instanceof Number)) return -1; Number num = (Number)x; if (Big == null) { if (num.Big == null) return Cnt == num.Cnt? 0 : Cnt > num.Cnt? 1 : -1; return -num.Big.signum(); } if (num.Big == null) return Big.signum(); return Big.compareTo(num.Big); } final long length() {return (Big == null? Integer.toString(Cnt) : Big.toString()).length();} final long size() { if (Big == null) { int n = 2 * (Cnt >= 0? Cnt : -Cnt); if (n == 0) return 1; int i = 1; while ((n >>= 8) != 0) ++i; return i; } return Big.toByteArray().length; } final InFrame rdOpen(Any ex) { int i; InFrame f; if ((i = Cnt) < 0) { for (f = Env.InFrames;;) { if ((f = f.Link) == null) badFd(ex, this); if (++i == 0) { i = f.Rd.Fd; break; } } } if (i >= InFiles.length || InFiles[i] == null) badFd(ex, this); return new InFrame(InFiles[i],0); } final OutFrame wrOpen(Any ex) { int i; OutFrame f; if ((i = Cnt) < 0) { for (f = Env.OutFrames;;) { if ((f = f.Link) == null) badFd(ex, this); if (++i == 0) { i = f.Wr.Fd; break; } } } if (i >= OutFiles.length || OutFiles[i] == null) badFd(ex, this); return new OutFrame(OutFiles[i],0); } final String name() {return Big == null? Integer.toString(Cnt) : Big.toString();} final public String toString() {return name();} final public String toString(int scl, char sep, char ign) { String s = name(); StringBuilder sb = new StringBuilder(); if (s.charAt(0) == '-') { sb.append('-'); s = s.substring(1); } if ((scl = s.length() - scl - 1) < 0) { sb.append('0'); sb.append(sep); while (scl < -1) { sb.append('0'); ++scl; } } for (int i = 0;;) { sb.append(s.charAt(i++)); if (i == s.length()) return sb.toString(); if (scl == 0) sb.append(sep); else if (ign != '\0' && scl > 0 && scl % 3 == 0) sb.append(ign); --scl; } } final Number abs() { if (Big == null) { if (Cnt >= 0) return this; if (Cnt != Integer.MIN_VALUE) return new Number(-Cnt); return new Number(-(long)Cnt); } return new Number(Big.abs()); } final Number neg() { if (Big == null) { if (Cnt != Integer.MIN_VALUE) return new Number(-Cnt); return new Number(-(long)Cnt); } return new Number(Big.negate()); } final Number add(Number num) { if (Big == null) { if (num.Big == null) return new Number((long)Cnt + (long)num.Cnt); return new Number(big(Cnt).add(num.Big)); } if (num.Big == null) return new Number(Big.add(big(num.Cnt))); return new Number(Big.add(num.Big)); } final Number sub(Number num) { if (Big == null) { if (num.Big == null) return new Number((long)Cnt - (long)num.Cnt); return new Number(big(Cnt).subtract(num.Big)); } if (num.Big == null) return new Number(Big.subtract(big(num.Cnt))); return new Number(Big.subtract(num.Big)); } final Number mul(Number num) { if (Big == null) { if (num.Big == null) return new Number((long)Cnt * (long)num.Cnt); return new Number(big(Cnt).multiply(num.Big)); } if (num.Big == null) return new Number(Big.multiply(big(num.Cnt))); return new Number(Big.multiply(num.Big)); } final Number div(Number num) { if (Big == null) { if (num.Big == null) return new Number((long)Cnt / (long)num.Cnt); return new Number(big(Cnt).divide(num.Big)); } if (num.Big == null) return new Number(Big.divide(big(num.Cnt))); return new Number(Big.divide(num.Big)); } final Number rem(Number num) { if (Big == null) { if (num.Big == null) return new Number((long)Cnt % (long)num.Cnt); return new Number(big(Cnt).remainder(num.Big)); } if (num.Big == null) return new Number(Big.remainder(big(num.Cnt))); return new Number(Big.remainder(num.Big)); } final Number shift(int i) { if (Big == null) { if (i >= 0) return new Number((long)Cnt >> i); if (i > -32) return new Number((long)Cnt << -i); return new Number((new BigInteger(new byte[] {(byte)(Cnt>>24), (byte)(Cnt>>16), (byte)(Cnt>>8), (byte)Cnt})).shiftRight(i)); } return new Number(Big.shiftRight(i)); } final boolean tst(Number num) { if (Big == null) { if (num.Big == null) return Cnt == (Cnt & num.Cnt); BigInteger b = big(Cnt); return b.equals(b.and(num.Big)); } if (num.Big == null) return Big.equals(Big.and(big(num.Cnt))); return Big.equals(Big.and(num.Big)); } final Number and(Number num) { if (Big == null) { if (num.Big == null) return new Number((long)Cnt & (long)num.Cnt); return new Number(big(Cnt).and(num.Big)); } if (num.Big == null) return new Number(Big.and(big(num.Cnt))); return new Number(Big.and(num.Big)); } final Number or(Number num) { if (Big == null) { if (num.Big == null) return new Number((long)Cnt | (long)num.Cnt); return new Number(big(Cnt).or(num.Big)); } if (num.Big == null) return new Number(Big.or(big(num.Cnt))); return new Number(Big.or(num.Big)); } final Number xor(Number num) { if (Big == null) { if (num.Big == null) return new Number((long)Cnt ^ (long)num.Cnt); return new Number(big(Cnt).xor(num.Big)); } if (num.Big == null) return new Number(Big.xor(big(num.Cnt))); return new Number(Big.xor(num.Big)); } } final static class Symbol extends Any { Object Obj; Any Prop[]; String Name; Symbol(Any val, String nm) { Car = val == null? this : val; Name = nm; } Symbol(Object obj) { Car = this; Obj = obj; } final void wipe() { Car = Nil; Prop = null; } final Any put(Any key, Any val) { if (key.equal(Zero)) Car = val; else if (Prop != null) { Any x; int i = Prop.length, p = -1; do { if ((x = Prop[--i]) == null) p = i; else if (x instanceof Cell) { if (key == x.Cdr) { if (val == Nil) Prop[i] = null; else if (val == T) Prop[i] = key; else x.Car = val; return val; } } else if (key == x) { if (val == Nil) Prop[i] = null; else if (val != T) Prop[i] = new Cell(val, key); return val; } } while (i != 0); if (val != Nil) { if (p < 0) { Any[] a = new Any[(p = Prop.length) * 2]; System.arraycopy(Prop, 0, a, 0, p); Prop = a; } Prop[p] = val != T? new Cell(val, key) : key; } } else if (val != Nil) (Prop = new Any[3])[2] = val != T? new Cell(val, key) : key; return val; } final Any get(Any key) { if (key.equal(Zero)) return Car; if (Prop == null) return Nil; Any x; int i = Prop.length; do { if ((x = Prop[--i]) != null) { if (x instanceof Cell) { if (key == x.Cdr) return x.Car; } else if (key == x) return T; } } while (i != 0); return Nil; } final Any prop(Any key) { Any x; if (Prop == null) { (Prop = new Any[3])[2] = x = new Cell(Nil, key); return x; } int i = Prop.length, p = -1; do { if ((x = Prop[--i]) == null) p = i; else if (x instanceof Cell) { if (key == x.Cdr) return x; } else if (key == x) return key; } while (i != 0); if (p < 0) { Any[] a = new Any[(p = Prop.length) * 2]; System.arraycopy(Prop, 0, a, 0, p); Prop = a; } Prop[p] = x = new Cell(Nil, key); return x; } final Any putl(Any lst) { Prop = new Any[6]; int i = 0; for (Any y = lst; y instanceof Cell; y = y.Cdr) Prop = append(Prop, i++, y.Car); return lst; } final Any getl() { Any x = Nil; if (Prop != null) for (int i = Prop.length; --i >= 0;) if (Prop[i] != null) x = new Cell(Prop[i], x); return x; } final Any eval() {return Car;} final Any prog() {return Car;} final Any run() {return Car;} final Any call(Any ex) { if (Car == Nil) undefined(this, ex); return Car.func(ex); } final Any func(Any ex) {return Car.func(ex);} final Any apply(Any ex, boolean cf, Any[] v, int n) { if (Car == Meth.Car) { Any x, y, z, o = cf? v[0].Car : v[0]; TheCls = null; TheKey = this; if ((z = method(o)) != null) { int i; Any cls = Env.Cls; Any key = Env.Key; Env.Cls = TheCls; Env.Key = TheKey; Bind bnd = new Bind(); bnd.add(At.Car); bnd.add(At); for (x = z.Car, i = 0; x instanceof Cell; ++i) { bnd.add((y = x.Car).Car); // Save value bnd.add(y); // and symbol y.Car = i >= n? Nil : cf? v[i].Car : v[i]; x = x.Cdr; } if (x == Nil || x != At) { if (x != Nil) { bnd.add(x.Car); // Save value bnd.add(x); // and symbol x.Car = Nil; // Set to NIL while (--n >= i) x.Car = new Cell(mkSymbol(cf? v[n].Car : v[n]), x.Car); } bnd.add(This.Car); bnd.add(This); This.Car = o; Env.Bind = bnd; x = z.Cdr.prog(); } else { int next, argc, j = 0; Any arg, args[], av[] = null; if (i < n) { av = new Any[6]; do av = append(av, j++, x.Car.eval()); while (++i < n); } next = Env.Next; Env.Next = 0; argc = Env.ArgC; Env.ArgC = j; arg = Env.Arg; Env.Arg = Nil; args = Env.Args; Env.Args = av; bnd.add(This.Car); bnd.add(This); This.Car = o; Env.Bind = bnd; x = z.Cdr.prog(); Env.Args = args; Env.Arg = arg; Env.ArgC = argc; Env.Next = next; } for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; Env.Cls = cls; Env.Key = key; return x; } err(ex, o, "Bad object"); } if (Car == Nil || Car == this) undefined(this, ex); return Car.apply(ex, cf, v, n); } final boolean equal(Any x) { if (x == this) return true; if (x instanceof Symbol) { Symbol s = (Symbol)x; if (Name != null) return Name.equals(s.Name); if (Obj != null) return Obj.equals(s.Obj); } return false; } final int compare(Any x) { if (x == this) return 0; if (this == T || x == Nil || x instanceof Number) return +1; if (x == T || x instanceof Cell) return -1; String a = Name; String b = ((Symbol)x).Name; if (a == null) return b == null? hashCode() - x.hashCode() : -1; if (b == null) return +1; return a.compareTo(b); } final long length() {return name().length();} final long size() {return name().getBytes().length;} final InFrame rdOpen(Any ex) { try { String nm = path(name()); if (nm.charAt(0) == '+') nm = nm.substring(1); // No file reader with "rw" mode return new InFrame(new PicoLispReader(new LineNumberReader(new FileReader(nm)), nm, allocFd(), null, 0), 1); } catch (IOException e) { err(ex, this, "Read open error"); return null; } } final OutFrame wrOpen(Any ex) { try { String nm = path(name()); if (nm.charAt(0) == '+') return new OutFrame(new PicoLispWriter(new PrintWriter(new FileWriter(nm.substring(1), true)), nm, allocFd()), 1); return new OutFrame(new PicoLispWriter(new PrintWriter(nm), nm, allocFd()), 1); } catch (IOException e) { err(ex, this, "Write open error"); return null; } } final String name() {return Name != null? Name : Obj == null? "" : Obj.toString();} final public String toString() { if (Name == null) { String s; if (Obj == null) return "$" + hashCode(); int i = (s = Obj.getClass().toString()).lastIndexOf('.'); if (i >= 0) s = s.substring(i + 1); if (s.startsWith("class ")) s = s.substring(6); return '$' + s; } if (Env.intern().get(Name) == this) { if (Name.equals(".")) return "\\."; StringBuilder sb = new StringBuilder(); if (Name.charAt(0) == '#') sb.append('\\'); for (int i = 0; i < Name.length(); ++i) { char c = Name.charAt(i); if (c == '\\' || Delim.indexOf(c) >= 0) sb.append('\\'); sb.append(c); } return sb.toString(); } StringBuilder sb = new StringBuilder(); sb.append('\"'); for (int i = 0; i < Name.length(); ++i) { char c = Name.charAt(i); if (c == '\\' || c == '^' || c == '"') sb.append('\\'); else if (c == 127) {sb.append('^'); c = '?';} else if (c < ' ') {sb.append('^'); c |= 0x40;} sb.append(c); } sb.append('\"'); return sb.toString(); } final Any parse(boolean skp, Any s) { Any x, y, z; PicoLispReader rd; if (s == null) rd = new PicoLispReader(name(), '\n', ']'); else rd = new PicoLispReader(name(), '\0', '\0'); if (skp) rd.get(); if (s == null) return rd.rdList(); if ((x = rd.token(s, '\0')) == null) return Nil; z = y = new Cell(x, Nil); while ((x = rd.token(s, '\0')) != null) y = y.Cdr = new Cell(x, Nil); return z; } } final static class NilSym extends Any { NilSym() { Car = this; Cdr = this; } final Any put(Any key, Any val) {return protError(this);} final Any get(Any key) {return this;} final Any prop(Any key) {return this;} final Any putl(Any lst) {return protError(this);} final Any getl() {return protError(this);} final Any eval() {return this;} final Any prog() {return this;} final Any run() {return this;} final Any call(Any ex) {return undefined(this,ex);} final Any func(Any ex) {return undefined(this,ex);} final Any apply(Any ex, boolean cf, Any[] v, int n) {return undefined(this,ex);} final boolean equal(Any x) {return x == Nil;} final int compare(Any x) {return x == this? 0 : -1;} final long length() {return 0;} final long size() {return 0;} final InFrame rdOpen(Any ex) {return new InFrame(InFiles[0], 0);} final OutFrame wrOpen(Any ex) {return new OutFrame(OutFiles[1], 0);} final String name() {return "";} final public String toString() {return "NIL";} } final static class Cell extends Any { Cell(Any car, Any cdr) { Car = car; Cdr = cdr; } final Any put(Any key, Any val) {return symError(this);} final Any get(Any key) { Any x, y = this; if (key instanceof Number) { int n = ((Number)key).Cnt; if (n > 0) { while (--n != 0) y = y.Cdr; return y.Car; } if (n < 0) { while (++n != 0) y = y.Cdr; return y.Cdr; } } else do if ((x = y.Car) instanceof Cell && key == x.Car) return x.Cdr; while ((y = y.Cdr) instanceof Cell); return Nil; } final Any prop(Any key) {return symError(this);} final Any putl(Any lst) {return symError(this);} final Any getl() {return symError(this);} final Any eval() {return Car.call(this);} final Any prog() { Any ex; for (ex = this; ex.Cdr != Nil; ex = ex.Cdr) ex.Car.eval(); return ex.Car.eval(); } final Any run() { Any x, at = At.Car; Any ex = this; do x = ex.Car.eval(); while ((ex = ex.Cdr) != Nil); At.Car = at; return x; } final Any call(Any ex) {return eval().func(ex);} final Any func(Any ex) { int i; Any x, y; Bind bnd = new Bind(); bnd.add(At.Car); bnd.add(At); for (x = Car; x instanceof Cell; x = x.Cdr) { bnd.add((ex = ex.Cdr).Car.eval()); // Save new value bnd.add(x.Car); // and symbol } if (x == Nil || x != At) { i = bnd.Cnt; if (x != Nil) { bnd.add(x.Car); // Save old value bnd.add(x); // and symbol x.Car = ex.Cdr; // Set new value } do { y = bnd.Data[--i]; x = y.Car; y.Car = bnd.Data[--i]; // Set new value bnd.Data[i] = x; // Save old value } while (i > 0); Env.Bind = bnd; x = Cdr.prog(); } else { int next, argc, j = 0; Any arg, args[], av[] = null; if (ex.Cdr != Nil) { av = new Any[6]; do av = append(av, j++, (ex = ex.Cdr).Car.eval()); while (ex.Cdr != Nil); } next = Env.Next; Env.Next = 0; argc = Env.ArgC; Env.ArgC = j; arg = Env.Arg; Env.Arg = Nil; args = Env.Args; Env.Args = av; i = bnd.Cnt; do { y = bnd.Data[--i]; x = y.Car; y.Car = bnd.Data[--i]; // Set new value bnd.Data[i] = x; // Save old value } while (i > 0); Env.Bind = bnd; x = Cdr.prog(); Env.Args = args; Env.Arg = arg; Env.ArgC = argc; Env.Next = next; } for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; return x; } final Any apply(Any ex, boolean cf, Any[] v, int n) { int i; Any x, y; Bind bnd = new Bind(); bnd.add(At.Car); bnd.add(At); for (x = Car, i = 0; x instanceof Cell; ++i, x = x.Cdr) { bnd.add((y = x.Car).Car); // Save value bnd.add(y); // and symbol y.Car = i >= n? Nil : cf? v[i].Car : v[i]; } if (x == Nil || x != At) { if (x != Nil) { bnd.add(x.Car); // Save old value bnd.add(x); // and symbol x.Car = Nil; // Set to NIL while (--n >= i) x.Car = new Cell(mkSymbol(cf? v[n].Car : v[n]), x.Car); } Env.Bind = bnd; x = Cdr.prog(); } else { int next, argc, j = 0; Any arg, args[], av[] = null; if (i < n) { av = new Any[6]; do av = append(av, j++, cf? v[i].Car : v[i]); while (++i < n); } next = Env.Next; Env.Next = 0; argc = Env.ArgC; Env.ArgC = j; arg = Env.Arg; Env.Arg = Nil; args = Env.Args; Env.Args = av; Env.Bind = bnd; x = Cdr.prog(); Env.Args = args; Env.Arg = arg; Env.ArgC = argc; Env.Next = next; } for (i = bnd.Cnt; (i -= 2) >= 0;) bnd.Data[i+1].Car = bnd.Data[i]; Env.Bind = bnd.Link; return x; } final boolean equal(Any x) { if (!(x instanceof Cell)) return false; if (!x.Car.equal(Car)) return false; HashSet mark = new HashSet(); Any y = this, a = x, b = y; for (;;) { if (!(x.Cdr instanceof Cell)) return x.Cdr.equal(y.Cdr); if (!(y.Cdr instanceof Cell)) return false; mark.add(x); x = x.Cdr; y = y.Cdr; if (mark.contains(x)) { for (;;) { if (a == x) { if (b != y) return false; for (;;) { a = a.Cdr; if ((b = b.Cdr) == y) return a == x; if (a == x) return true; } } if (b == y) return false; a = a.Cdr; b = b.Cdr; } } if (!x.Car.equal(y.Car)) return false; } } final int compare(Any x) { if (x == this) return 0; if (x == T) return -1; if (!(x instanceof Cell)) return +1; Any y = this; Any a = this; Any b = x; for (;;) { int n; if ((n = y.Car.compare(x.Car)) != 0) return n; if (!((y = y.Cdr) instanceof Cell)) return y.compare(x.Cdr); if (!((x = x.Cdr) instanceof Cell)) return x == T? -1 : +1; if (y == a && x == b) return 0; } } final long length() { long n = 0; HashSet mark = new HashSet(); for (Any x = this;;) { ++n; mark.add(x); if (!((x = x.Cdr) instanceof Cell)) return n; if (mark.contains(x)) return -1; } } final long size() { long n = 0; HashSet mark = new HashSet(); for (Any x = this;;) { ++n; if (x.Car instanceof Cell) n += x.Car.size(); mark.add(x); if (!((x = x.Cdr) instanceof Cell) || mark.contains(x)) return n; } } final InFrame rdOpen(Any ex) { try { int len = (int)length(); String[] cmd = new String[len]; Any x = this; for (int i = 0; i < len; ++i) { cmd[i] = x.Car.name(); x = x.Cdr; } int pid = allocPid(); return new InFrame(new PicoLispReader((Pids[pid] = Runtime.getRuntime().exec(cmd)).getInputStream(), allocFd(), null, 0), pid); } catch (IOException e) { err(ex, this, "Pipe read open error"); return null; } } final OutFrame wrOpen(Any ex) { try { int len = (int)length(); String[] cmd = new String[len]; Any x = this; for (int i = 0; i < len; ++i) { cmd[i] = x.Car.name(); x = x.Cdr; } int pid = allocPid(); return new OutFrame(new PicoLispWriter((Pids[pid] = Runtime.getRuntime().exec(cmd)).getOutputStream(), allocFd()), pid); } catch (IOException e) { err(ex, this, "Pipe write open error"); return null; } } final String name() {return Car.name() + Cdr.name();} final public String toString() { Any x, y; StringBuilder sb; if (Car == Quote && this != Cdr) return '\'' + Cdr.toString(); x = this; sb = new StringBuilder(); sb.append('('); if ((y = circ(x)) == null) { for (;;) { sb.append(x.Car.toString()); if ((x = x.Cdr) == Nil) break; if (!(x instanceof Cell)) { sb.append(" . "); sb.append(x.toString()); break; } sb.append(' '); } } else if (y == x) { do { sb.append(x.Car.toString()); sb.append(' '); } while (y != (x = x.Cdr)); sb.append('.'); } else { do { sb.append(x.Car.toString()); sb.append(' '); } while (y != (x = x.Cdr)); sb.append(". ("); do { sb.append(x.Car.toString()); sb.append(' '); } while (y != (x = x.Cdr)); sb.append(".)"); } sb.append(')'); return sb.toString(); } } } picolisp-3.1.5.2.orig/bin/0000755000000000000000000000000012265263724013720 5ustar rootrootpicolisp-3.1.5.2.orig/bin/pil0000755000000000000000000000015312265263724014431 0ustar rootroot#!/usr/bin/picolisp /usr/lib/picolisp/lib.l (load "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l") picolisp-3.1.5.2.orig/bin/psh0000755000000000000000000000042512265263724014441 0ustar rootroot#!bin/picolisp lib.l # 06may11abu # (c) Software Lab. Alexander Burger (load "@lib/misc.l" "@lib/http.l") (raw T) (let *Dbg NIL (client "localhost" (format (opt)) (pack "!psh?" (pw) "&" (in '("tty") (line T))) (ctty (read)) (line) (line) ) ) (bye) picolisp-3.1.5.2.orig/bin/replica0000755000000000000000000000165112265263724015270 0ustar rootroot#!bin/picolisp lib.l # 03dec13abu # Use: bin/replica [dbs1 ..] # : bin/ssl 443 '/!replica' 60 (load "@lib/misc.l" "@lib/http.l") (allow "!replica") (argv *Port *KeyFile *Journal *Pool *Blob . *Dbs) (setq *Port (format *Port) *SSLKey (in *KeyFile (line T)) ) (de replica () (ctl *KeyFile (protect (when (= (line T) *SSLKey) (let? X (line T) (if (format X) (when (abort 420 (out (tmp 'replica) (echo @))) # Journal (prin (peek)) (flush) (journal (tmp 'replica)) ) (let Blob (pack *Blob X) # Blob (call 'mkdir "-p" (dirname Blob)) (out Blob (echo)) ) ) ) ) ) ) ) (pool *Pool (mapcar format *Dbs) *Journal) (server *Port) picolisp-3.1.5.2.orig/bin/watchdog0000755000000000000000000000424312265263724015451 0ustar rootroot#!bin/picolisp lib.l # 09mar08abu # (c) Software Lab. Alexander Burger # Use: bin/watchdog .. (load "@lib/misc.l") # *MailHost *MailPort *MailFrom *MailTo *Watch (argv *MailHost *MailPort *MailFrom . *MailTo) (setq *MailPort (format *MailPort)) (unless (call 'test "-p" "fifo/beat") (call 'mkdir "-p" "fifo") (call 'rm "-f" "fifo/beat") (call 'mkfifo "fifo/beat") ) (push1 '*Bye '(call 'rm "fifo/beat")) (de *Err (prin (stamp)) (space) (println *Watch) ) (task (open "fifo/beat") (in @ (let X (rd) (cond ((not X) (bye)) ((num? X) (del (assoc X *Watch) '*Watch) ) ((atom X) # bin/picolisp -"out 'fifo/beat (pr '$(tty))" -bye (let D (+ (* 86400 (date T)) (time T)) (out X (for W *Watch (prinl (align 5 (car W)) " " (- (cadr W) D) " " (or (caddr W) "o") " " (cdddr W) ) ) ) ) ) ((assoc (car X) *Watch) # X = (Pid Tim . Any) (let W @ # W = (Pid Tim Flg . Any) (when (caddr W) (msg (car W) " " (stamp) " resumed") ) (set (cdr W) (cadr X)) (set (cddr W)) (con (cddr W) (or (cddr X) (cdddr W))) ) ) (T (push '*Watch (list (car X) (cadr X) NIL (cddr X)))) ) ) ) ) (task -54321 54321 (let D (+ (* 86400 (date T)) (time T)) (for W (filter '((X) (> D (cadr X))) *Watch) (if (caddr W) (prog (msg (car W) " " (stamp) (if (kill (car W) 15) " killed" " gone") ) (del W '*Watch) ) (inc (cdr W) 3600) (set (cddr W) T) (let Sub (pack "Timeout " (car W) " " (cdddr W)) (msg (car W) " " (stamp)) (unless (mail *MailHost *MailPort *MailFrom *MailTo Sub) (msg (cons Sub *MailTo) " mail failed " (stamp)) ) ) ) ) ) ) (wait) picolisp-3.1.5.2.orig/cygwin/0000755000000000000000000000000012265263724014450 5ustar rootrootpicolisp-3.1.5.2.orig/cygwin/README0000644000000000000000000001717312265263724015341 0ustar rootrootPorting PicoLisp to Cygwin A few months back, I was looking at Lisp programming language offerings for the MS Windows environment. I want an interpreter that is fast and powerful, yet small. I want it to work well in the Cygwin/Win32 environment. Enter PicoLisp. http://software-lab.de/down.html According to the PicoLisp FAQ, "PicoLisp is for programmers who want to control their programming environment, at all levels, from the application domain down to the bare metal." Yes! That's part of what I want a Lisp for. Especially a Lisp I might embed in other applications. I want control. PicoLisp looked promising. PicoLisp is designed with a philosophy of "succinctness", according to the literature on the site. Although there are even smaller Lisp interpreters available, PicoLisp seemed to strike a balance between terseness and functionality. PicoLisp is written using standard C, and the author (Alexander Burger) distributes it as C source code under the GNU General Public License. That means if you want to use PicoLisp, you'll need to compile it yourself, or otherwise obtain the executables. PicoLisp comes in two flavours: picolisp, and an even smaller version: mini picolisp. (More about mini picolisp in a bit.) When you do build PicoLisp for yourself, you'll get a powerhouse of a Lisp including APIs for building web servers, gui web application servers (for browser clients running java and/or javascript) integrated relational databases, prolog db access, and much more. PicoLisp even comes with two example versions of a flight simulator: one which runs under X-Windows, the other which uses a client's browser/java for the display. There's a chess game written in PicoLisp and Prolog. Lest one think that PicoLisp is a mere toy, consider this. In 2006, PicoLisp won second prize in the German-language C't Magazine database contest, beating entries written using DB2 and Oracle. Industrial-strength databases with tightly integrated web applications have been crafted with PicoLisp. http://tinyurl.com/y9wu39 PicoLisp has some drawbacks and limitations. As the FAQ warns, PicoLisp "does not pretend to be easy to learn." It is not a Common Lisp flavor. It is not "some standard, 'safe' black-box, which may be easier to learn." Also, for my purposes, I want software that runs not only on Linux, but also on PCs with the MS-Windows operating systems. And there was the rub: PicoLisp isn't distributed with binaries or Windows exe files. Even worse (for Windows users), PicoLisp wasn't ported to Cygwin. I have a growing list of portable apps that will run on a flash drive, many of them I compiled from source from using Cygwin tools like make, gcc, etc. Cygwin provides a POSIX emulation layer in the form of cygwin1.dll and other libraries. This lets a PC running Windows look like much like a Linux or UNIX box to programs which have been compiled for Cygwin. I'd compiled hundreds of programs for Cygwin and here was PicoLisp which I wanted to have running on all my PCs, Linux ones as well as the MS-Windows PCs, too. So this was beginning to look like a challenge. I'd just take a little peek at porting PicoLisp to Cygwin, and see how it would go. I'd ported everything from sox to busybox to fluxbox to Cygwin, so I felt ready for porting PicoLisp. PicoLisp comes in two flavors. Mini picolisp and full picolisp. Mini PicoLisp is a kind of a "pure" PicoLisp without system-dependent functions like databases, UTF-8, bignums, IPC, and networking. This seemed like a good place to start my PicoLisp porting adventures. I first tried a straight Cygwin/gcc build, and that worked fine, no hitches. Then I remembered the -mno-cygwin compiler flag for Cygwin's gcc. When you compile with -mno-cygwin, gcc causes the resulting executable to be built without Cygwin dll library dependances. For C code that relies heavily upon the POSIX emulation aspects of Cygwin, this might not work. But why not try building mini picolisp with the -mno-cygwin option? The C code for mini picolisp is free from Linux/POSIX system calls, and it compiled with no problems using -mno-cygwin. It produced a mini picolisp exe file of about 73K, which is not dependant upon any Cygwin DLLs. Porting the full PicoLisp interpreter proved to be more of a challenge. Whereas the mini picolisp was careful to avoid Linux system calls, PicoLisp takes the opposite approach and uses Linux (UNIX/POSIX) system functions where needed. Additionally, PicoLisp has the ability to dynamically load shared libraries for various extensions. Since we need to use shared libraries anyway, I wanted for all of picolisp to go into a single DLL. Then the picolisp exe would be a just small stub that uses that the shared library, picolisp.dll. PicoLisp applications often use fork, so this should also be more efficient when forking. Splitting up PicoLisp this way (a DLL and an exe stub) would allow the picolisp.dll to be used as a Lisp library. As a shared library, it would then be possible for other applications to treat PicoLisp as an embedded interpreter, somewhat like librep, but much smaller and more portable. Wanting to see how much I could squeeze down the size of the executables and libraries under Cygwin, I used gcc's -Os option, which requests that gcc optimize by making the smallest possible code. Doing this resulted in a picolisp dll of just 150K, and a picolisp exe stub of only 2K. Of course, if you want this full PicoLisp to run on a Windows PC which does not already have Cygwin installed, you'll need to obtain a few Cygwin DLLs which provide the POSIX emulation layer for PicoLisp. For the most part, the port to Win32/Cygwin went smoothly. There were just a few differences between Linux and Cygwin that were handled with macro ifdef statements in the C code that allow something to be done differently for the Cygwin compilation. In the end it turned out that the biggest problem was the fcntl system function that does file and record locking. This was especially frustrating, as time and time again, I thought I'd found a solution or a work-around to the differences in semantics of the fcntl call between Linux and Cygwin, only to have the my "solution" fail with more rigorous testing. The locking problem was finally just circumvented for Windows by simply not using fcntl locking. So, there is no file or record locking for PicoLisp running under Windows. (See the locking notes in http://www.sqlite.org/lockingv3.html for another perspective on locking system functions in Windows.) However, all the example applications run fine, running in a special (Solo) mode in PicoLisp, in the few places it even matters. This avoids depending on buggy or non-existent record locking functionality with the various Windows versions and file system types. So, what do we have at this point? PicoLisp is running on the PC. A working, industrial-strength Lisp interpreter is PicoLisp, ready for writing applications that are succinct yet powerful. PicoLisp comes with a Prolog interpreter and relational databases and flight simulators and chess games and web servers and chat servers and sendmail and much more. And PicoLisp itself is written in highly portable C, running on Linux and Windows. PicoLisp is readily embedable, and will be useful to add scripting languages (Lisp, Prolog) to other applications, either statically linked, or as a shared library (DLL). PicoLisp is a little dynamo. It even has the ability to use in-line C code which is compiled on-the-fly into a shared library. This in-line C ability uses gcc. (And it works with tcc, the Tiny C Compiler, too.) With the tremendous number of PCs out there now able to run PicoLisp, watch out! PicoLisp may be small, but sometimes very powerful things come in small packages. Doug Snead, Jan. 2007 picolisp-3.1.5.2.orig/cygwin/tcc.l0000644000000000000000000000140612265263724015377 0ustar rootroot# 21jan07abu # (c) Software Lab. Alexander Burger # use the Tiny C Compiler http://fabrice.bellard.free.fr/tcc (de tcc (S L . @) (out (tmp S ".c") (chdir '@ (prinl "#include ")) (here "/**/") ) (apply call L 'tcc "-shared" "-rdynamic" (pack "-I" (dospath "/usr/include")) (pack "-I" (dospath (path "@/src"))) "-falign-functions" "-fomit-frame-pointer" "-W" "-Wimplicit" "-Wreturn-type" "-Wunused" "-Wformat" "-Wuninitialized" "-Wstrict-prototypes" "-pipe" "-D_GNU_SOURCE" "-D_FILE_OFFSET_BITS=64" "-DNOWAIT" "-o" (tmp S ".dll") (tmp S ".c") (dospath (path "@/bin/picolisp.def"))) (while (args) (def (next) (def (tmp S ': (arg)))) ) ) (de dospath (p) (in '("cygpath" "-m" p) (line T)) ) picolisp-3.1.5.2.orig/dbg.l0000644000000000000000000000040012265263724014053 0ustar rootroot# 27feb13abu # (c) Software Lab. Alexander Burger (on *Dbg) (if (info (pil "editor")) (load (pil "editor")) (load "@lib/led.l" "@lib/edit.l") ) (load "@lib/debug.l" "@lib/lint.l" "@lib/sq.l") (noLint 'later (loc "@Prg" later)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/ext.l0000644000000000000000000000020512265263724014122 0ustar rootroot# 14apr10abu # (c) Software Lab. Alexander Burger (load "@lib/misc.l" "@lib/btree.l" "@lib/db.l" "@lib/pilog.l") # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/games/0000755000000000000000000000000012265263724014244 5ustar rootrootpicolisp-3.1.5.2.orig/games/README0000644000000000000000000001426012265263724015127 0ustar rootroot24apr12abu (c) Software Lab. Alexander Burger PicoLisp Demo Games =================== This directory contains a few simple games. They are neither especially interesting, nor powerful, but may be useful as programming examples. For a global PicoLisp installation (see the INSTALL file), either supply a full path to "/usr/share/picolisp/games/.l" instead of just "games/.l" in the commands below, or change the working directory to "/usr/share/picolisp/". 'mine' is a simplified version of the minesweeper game. You can start it as: $ pil games/mine.l -main -go + It will display a 12-by-12 field with 24 (default) hidden mines. You can move around using the standard 'vi'-keys 'j' (down), 'k' (up), 'l' (right) and 'h' (left). Hit ENTER or SPACE to uncover a field, and ESC to terminate the game. In the latter case (of if a mine exploded), you'll get the PicoLisp prompt. Then you can continue the game with : (go) possibly after re-initializing it with : (main) or exit the PicoLisp interpreter with ENTER. 'nim' and 'ttt' are only testbeds for the general 'game' alpha-beta search function (normally, these games are better implemented by directly exploring their underlying principles and strategies). Start 'nim' as $ pil games/nim.l + and then find the optimal move path for, let's say, three heaps of four matches each: : (nim 4 4 4) -> (-100 ((1 . 4) 1 . -4) ((2 . 4) 2 . -4) ((3 . 4) 3 . -4)) This is a winning position (a minimal cost of -100), with three moves (in the CARs of the move list: Take 4 from heap 1, then 4 from heap 2, and finally 4 from heap 3). To play Tic-Tac-Toe, enter $ pil games/ttt.l -main + A three-by-three board is displayed. Enter your moves with the 'go' function: : (go a 1) +---+---+---+ 3 | | | | +---+---+---+ 2 | | | | +---+---+---+ 1 | T | | | +---+---+---+ a b c Your positions are marked with 'T', the computer's with '0'. The 'chess' game is minimalistic (447 lines of code). Nevertheless, it plays some slow - though correct - chess. Start it as: $ pil games/chess.l -main + +---+---+---+---+---+---+---+---+ 8 ||||||||| +---+---+---+---+---+---+---+---+ 7 |

|

|

|

|

|

|

|

| +---+---+---+---+---+---+---+---+ 6 | | - | | - | | - | | - | +---+---+---+---+---+---+---+---+ 5 | - | | - | | - | | - | | +---+---+---+---+---+---+---+---+ 4 | | - | | - | | - | | - | +---+---+---+---+---+---+---+---+ 3 | - | | - | | - | | - | | +---+---+---+---+---+---+---+---+ 2 | P | P | P | P | P | P | P | P | +---+---+---+---+---+---+---+---+ 1 | R | N | B | Q | K | B | N | R | +---+---+---+---+---+---+---+---+ a b c d e f g h The pieces are indicated by the letters 'K'ing, 'Q'ueen, 'R'ook, 'B'ishop, k'N'ight and 'P'awn, with black pieces in angular brackets. Alternatively, you can also run it through XBoard (in the X Window System): $ xboard -fcp games/xchess Without XBoard, you may enter your moves with the field names (in lower case) for the "from" and "to" positions: : (go e2 e4) Castling may be entered by just specifying the king's move: : (go e1 g1) To promote a pawn to some piece other than a queen, you can specify a class: : (go h7 h8 +Knight) To undo one or several moves, enter : (go -) and to redo them : (go +) To switch sides (and have the computer play against itself), call 'go' without arguments: : (go) The initial board position can be restored with : (main) The global variable '*Depth' holds the maximal depth of the alpha-beta tree search. It defaults to 5. You may change it to some smaller value for a faster response, or to a larger value for a deeper search: : (setq *Depth 7) The same effect can be achieved by passing the desired depth as the first argument to 'main': : (main 7) The second (optional) argument to 'main' is your color ('NIL' for white and 'T' for black). To setup some given board position, call 'main' with a list of triples, with each describing: 1. The field 2. The piece's classes 3. An optional flag to indicate that the piece did not move yet : (main 5 NIL (quote (a2 (+White +Pawn) T) (b1 (+White +King)) (d4 (+Black +King)) ) ) +---+---+---+---+---+---+---+---+ 8 | | - | | - | | - | | - | +---+---+---+---+---+---+---+---+ 7 | - | | - | | - | | - | | +---+---+---+---+---+---+---+---+ 6 | | - | | - | | - | | - | +---+---+---+---+---+---+---+---+ 5 | - | | - | | - | | - | | +---+---+---+---+---+---+---+---+ 4 | | - | || | - | | - | +---+---+---+---+---+---+---+---+ 3 | - | | - | | - | | - | | +---+---+---+---+---+---+---+---+ 2 | P | - | | - | | - | | - | +---+---+---+---+---+---+---+---+ 1 | - | K | - | | - | | - | | +---+---+---+---+---+---+---+---+ a b c d e f g h At any time, you can print the current board position in the above format to a file with : (ppos "file") which later can be restored with : (load "file") There is also a plain 'sudoku' solver: $ pil games/sudoku.l + : (main (quote (5 3 0 0 7 0 0 0 0) (6 0 0 1 9 5 0 0 0) (0 9 8 0 0 0 0 6 0) (8 0 0 0 6 0 0 0 3) (4 0 0 8 0 3 0 0 1) (7 0 0 0 2 0 0 0 6) (0 6 0 0 0 0 2 8 0) (0 0 0 4 1 9 0 0 5) (0 0 0 0 8 0 0 7 9) ) ) +---+---+---+---+---+---+---+---+---+ 9 | 5 3 | 7 | | + + + + + + + + + + 8 | 6 | 1 9 5 | | + + + + + + + + + + 7 | 9 8 | | 6 | +---+---+---+---+---+---+---+---+---+ 6 | 8 | 6 | 3 | + + + + + + + + + + 5 | 4 | 8 3 | 1 | + + + + + + + + + + 4 | 7 | 2 | 6 | +---+---+---+---+---+---+---+---+---+ 3 | 6 | | 2 8 | + + + + + + + + + + 2 | | 4 1 9 | 5 | + + + + + + + + + + 1 | | 8 | 7 9 | +---+---+---+---+---+---+---+---+---+ a b c d e f g h i Type : (go) to let it search for a solution. picolisp-3.1.5.2.orig/games/chess.l0000644000000000000000000003546112265263724015537 0ustar rootroot# 24apr12abu # (c) Software Lab. Alexander Burger # *Board a1 .. h8 # *White *Black *WKPos *BKPos *Pinned # *Depth *Moved *Undo *Redo *Me *You (load "@lib/simul.l") ### Fields/Board ### # x y color piece whAtt blAtt (setq *Board (grid 8 8)) (for (X . Lst) *Board (for (Y . This) Lst (=: x X) (=: y Y) (=: color (not (bit? 1 (+ X Y)))) ) ) (de *Straight `west `east `south `north) (de *Diagonal ((This) (: 0 1 1 0 -1 1)) # Southwest ((This) (: 0 1 1 0 -1 -1)) # Northwest ((This) (: 0 1 -1 0 -1 1)) # Southeast ((This) (: 0 1 -1 0 -1 -1)) ) # Northeast (de *DiaStraight ((This) (: 0 1 1 0 -1 1 0 -1 1)) # South Southwest ((This) (: 0 1 1 0 -1 1 0 1 1)) # West Southwest ((This) (: 0 1 1 0 -1 -1 0 1 1)) # West Northwest ((This) (: 0 1 1 0 -1 -1 0 -1 -1)) # North Northwest ((This) (: 0 1 -1 0 -1 -1 0 -1 -1)) # North Northeast ((This) (: 0 1 -1 0 -1 -1 0 1 -1)) # East Northeast ((This) (: 0 1 -1 0 -1 1 0 1 -1)) # East Southeast ((This) (: 0 1 -1 0 -1 1 0 -1 1)) ) # South Southeast ### Pieces ### (de piece (Typ Cnt Fld) (prog1 (def (pack (mapcar '((Cls) (cdr (chop Cls))) Typ)) Typ ) (init> @ Cnt Fld) ) ) (class +White) # color ahead (dm init> (Cnt Fld) (=: ahead north) (extra Cnt Fld) ) (dm name> () (pack " " (extra) " ") ) (dm move> (Fld) (adjMove '*White '*WKPos whAtt- whAtt+) ) (class +Black) # color ahead (dm init> (Cnt Fld) (=: color T) (=: ahead south) (extra Cnt Fld) ) (dm name> () (pack '< (extra) '>) ) (dm move> (Fld) (adjMove '*Black '*BKPos blAtt- blAtt+) ) (class +piece) # cnt field attacks (dm init> (Cnt Fld) (=: cnt Cnt) (move> This Fld) ) (dm ctl> ()) (class +King +piece) (dm name> () 'K) (dm val> () 120) (dm ctl> () (unless (=0 (: cnt)) -10) ) (dm moves> () (make (unless (or (n0 (: cnt)) (get (: field) (if (: color) 'whAtt 'blAtt)) ) (tryCastle west T) (tryCastle east) ) (try1Move *Straight) (try1Move *Diagonal) ) ) (dm attacks> () (make (try1Attack *Straight) (try1Attack *Diagonal) ) ) (class +Castled) (dm ctl> () 30) (class +Queen +piece) (dm name> () 'Q) (dm val> () 90) (dm moves> () (make (tryMoves *Straight) (tryMoves *Diagonal) ) ) (dm attacks> () (make (tryAttacks *Straight) (tryAttacks *Diagonal T) ) ) (class +Rook +piece) (dm name> () 'R) (dm val> () 47) (dm moves> () (make (tryMoves *Straight)) ) (dm attacks> () (make (tryAttacks *Straight)) ) (class +Bishop +piece) (dm name> () 'B) (dm val> () 33) (dm ctl> () (when (=0 (: cnt)) -10) ) (dm moves> () (make (tryMoves *Diagonal)) ) (dm attacks> () (make (tryAttacks *Diagonal T)) ) (class +Knight +piece) (dm name> () 'N) (dm val> () 28) (dm ctl> () (when (=0 (: cnt)) -10) ) (dm moves> () (make (try1Move *DiaStraight)) ) (dm attacks> () (make (try1Attack *DiaStraight)) ) (class +Pawn +piece) (dm name> () 'P) (dm val> () 10) (dm moves> () (let (Fld1 ((: ahead) (: field)) Fld2 ((: ahead) Fld1)) (make (and (tryPawnMove Fld1 Fld2) (=0 (: cnt)) (tryPawnMove Fld2 T) ) (tryPawnCapt (west Fld1) Fld2 (west (: field))) (tryPawnCapt (east Fld1) Fld2 (east (: field))) ) ) ) (dm attacks> () (let Fld ((: ahead) (: field)) (make (and (west Fld) (link @)) (and (east Fld) (link @)) ) ) ) ### Move Logic ### (de inCheck (Color) (if Color (get *BKPos 'whAtt) (get *WKPos 'blAtt)) ) (de whAtt+ (This Pce) (=: whAtt (cons Pce (: whAtt))) ) (de whAtt- (This Pce) (=: whAtt (delq Pce (: whAtt))) ) (de blAtt+ (This Pce) (=: blAtt (cons Pce (: blAtt))) ) (de blAtt- (This Pce) (=: blAtt (delq Pce (: blAtt))) ) (de adjMove (Var KPos Att- Att+) (let (W (: field whAtt) B (: field blAtt)) (when (: field) (put @ 'piece NIL) (for F (: attacks) (Att- F This)) ) (nond (Fld (set Var (delq This (val Var)))) ((: field) (push Var This)) ) (ifn (=: field Fld) (=: attacks) (put Fld 'piece This) (and (isa '+King This) (set KPos Fld)) (for F (=: attacks (attacks> This)) (Att+ F This)) ) (reAtttack W (: field whAtt) B (: field blAtt)) ) ) (de reAtttack (W W2 B B2) (for This W (unless (memq This W2) (for F (: attacks) (whAtt- F This)) (for F (=: attacks (attacks> This)) (whAtt+ F This)) ) ) (for This W2 (for F (: attacks) (whAtt- F This)) (for F (=: attacks (attacks> This)) (whAtt+ F This)) ) (for This B (unless (memq This B2) (for F (: attacks) (blAtt- F This)) (for F (=: attacks (attacks> This)) (blAtt+ F This)) ) ) (for This B2 (for F (: attacks) (blAtt- F This)) (for F (=: attacks (attacks> This)) (blAtt+ F This)) ) ) (de try1Move (Lst) (for Dir Lst (let? Fld (Dir (: field)) (ifn (get Fld 'piece) (link (list This (cons This Fld))) (unless (== (: color) (get @ 'color)) (link (list This (cons (get Fld 'piece)) (cons This Fld) ) ) ) ) ) ) ) (de try1Attack (Lst) (for Dir Lst (and (Dir (: field)) (link @)) ) ) (de tryMoves (Lst) (for Dir Lst (let Fld (: field) (loop (NIL (setq Fld (Dir Fld))) (T (get Fld 'piece) (unless (== (: color) (get @ 'color)) (link (list This (cons (get Fld 'piece)) (cons This Fld) ) ) ) ) (link (list This (cons This Fld))) ) ) ) ) (de tryAttacks (Lst Diag) (use (Pce Cls Fld2) (for Dir Lst (let Fld (: field) (loop (NIL (setq Fld (Dir Fld))) (link Fld) (T (and (setq Pce (get Fld 'piece)) (<> (: color) (get Pce 'color)) ) ) (T (== '+Pawn (setq Cls (last (type Pce)))) (and Diag (setq Fld2 (Dir Fld)) (= (get Fld2 'y) (get ((get Pce 'ahead) Fld) 'y)) (link Fld2) ) ) (T (memq Cls '(+Knight +Queen +King))) (T (and Pce (xor Diag (== Cls '+Bishop)))) ) ) ) ) ) (de tryPawnMove (Fld Flg) (unless (get Fld 'piece) (if Flg (link (list This (cons This Fld))) (for Cls '(+Queen +Knight +Rook +Bishop) (link (list This (cons This) (cons (piece (list (car (type This)) Cls) (: cnt)) Fld ) ) ) ) ) ) ) (de tryPawnCapt (Fld1 Flg Fld2) (if (get Fld1 'piece) (unless (== (: color) (get @ 'color)) (if Flg (link (list This (cons (get Fld1 'piece)) (cons This Fld1) ) ) (for Cls '(+Queen +Knight +Rook +Bishop) (link (list This (cons (get Fld1 'piece)) (cons This) (cons (piece (list (car (type This)) Cls) (: cnt)) Fld1 ) ) ) ) ) ) (let? Pce (get Fld2 'piece) (and (== Pce (car *Moved)) (= 1 (get Pce 'cnt)) (isa '+Pawn Pce) (n== (: color) (get Pce 'color)) (link (list This (cons Pce) (cons This Fld1))) ) ) ) ) (de tryCastle (Dir Long) (use (Fld1 Fld2 Fld Pce) (or (get (setq Fld1 (Dir (: field))) 'piece) (get Fld1 (if (: color) 'whAtt 'blAtt)) (get (setq Fld2 (Dir Fld1) Fld Fld2) 'piece) (when Long (or (get (setq Fld (Dir Fld)) 'piece) (get Fld (if (: color) 'whAtt 'blAtt)) ) ) (and (== '+Rook (last (type (setq Pce (get (Dir Fld) 'piece))))) (=0 (get Pce 'cnt)) (link (list This (cons This) (cons (piece (cons (car (type This)) '(+Castled +King)) 1) Fld2 ) (cons Pce Fld1) ) ) ) ) ) ) (de pinned (Fld Lst Color) (use (Pce L P) (and (loop (NIL (setq Fld (Dir Fld))) (T (setq Pce (get Fld 'piece)) (and (= Color (get Pce 'color)) (setq L (make (loop (NIL (setq Fld (Dir Fld))) (link Fld) (T (setq P (get Fld 'piece))) ) ) ) (<> Color (get P 'color)) (memq (last (type P)) Lst) (cons Pce L) ) ) ) (link @) ) ) ) ### Moves ### # Move ((p1 (p1 . f2)) . ((p1 . f1))) # Capture ((p1 (p2) (p1 . f2)) . ((p1 . f1) (p2 . f2))) # Castle ((K (K) (C . f2) (R . f4)) . ((R . f3) (K . f1))) # Promote ((P (P) (Q . f2)) . ((Q) (P . f1))) # Capt/Prom ((P (p1) (P) (Q . f2)) . ((Q) (P . f1) (p1 . f2))) (de moves (Color) (filter '((Lst) (prog2 (move (car Lst)) (not (inCheck Color)) (move (cdr Lst)) ) ) (mapcan '((Pce) (mapcar '((Lst) (cons Lst (flip (mapcar '((Mov) (cons (car Mov) (get Mov 1 'field))) (cdr Lst) ) ) ) ) (moves> Pce) ) ) (if Color *Black *White) ) ) ) (de move (Lst) (if (atom (car Lst)) (inc (prop (push '*Moved (pop 'Lst)) 'cnt)) (dec (prop (pop '*Moved) 'cnt)) ) (for Mov Lst (move> (car Mov) (cdr Mov)) ) ) ### Evaluation ### (de mate (Color) (and (inCheck Color) (not (moves Color))) ) (de battle (Fld Prey Attacker Defender) (use Pce (loop (NIL (setq Pce (mini 'val> Attacker)) 0) (setq Attacker (delq Pce Attacker)) (NIL (and (asoq Pce *Pinned) (not (memq Fld @))) (max 0 (- Prey (battle Fld (val> Pce) Defender Attacker))) ) ) ) ) # Ref. Sargon, Dan and Kate Spracklen, Hayden 1978 (de cost (Color) (if (mate (not Color)) -9999 (setq *Pinned (make (for Dir *Straight (pinned *WKPos '(+Rook +Queen)) (pinned *BKPos '(+Rook +Queen) T) ) (for Dir *Diagonal (pinned *WKPos '(+Bishop +Queen)) (pinned *BKPos '(+Bishop +Queen) T) ) ) ) (let (Ctl 0 Mat 0 Lose 0 Win1 NIL Win2 NIL Flg NIL) (use (White Black Col Same B) (for Lst *Board (for This Lst (setq White (: whAtt) Black (: blAtt)) ((if Color inc dec) 'Ctl (- (length White) (length Black))) (let? Val (and (: piece) (val> @)) (setq Col (: piece color) Same (== Col Color)) ((if Same dec inc) 'Ctl (ctl> (: piece))) (unless (=0 (setq B (if Col (battle This Val White Black) (battle This Val Black White) ) ) ) (dec 'Val 5) (if Same (setq Lose (max Lose B) Flg (or Flg (== (: piece) (car *Moved))) ) (when (> B Win1) (xchg 'B 'Win1) (setq Win2 (max Win2 B)) ) ) ) ((if Same dec inc) 'Mat Val) ) ) ) ) (unless (=0 Lose) (dec 'Lose 5)) (if Flg (* 4 (+ Mat Lose)) (when Win2 (dec 'Lose (>> 1 (- Win2 5))) ) (+ Ctl (* 4 (+ Mat Lose))) ) ) ) ) ### Game ### (de display (Res) (when Res (disp *Board T '((This) (cond ((: piece) (name> @)) ((: color) " - ") (T " ") ) ) ) ) (and (inCheck *You) (prinl "(+)")) Res ) (de moved? (Lst) (or (> 16 (length Lst)) (find '((This) (n0 (: cnt))) Lst) ) ) (de bookMove (From To) (let Pce (get From 'piece) (list 0 (list (list Pce (cons Pce To)) (cons Pce From))) ) ) (de myMove () (let? M (cadr (cond ((moved? (if *Me *Black *White)) (game *Me *Depth moves move cost) ) (*Me (if (member (get *Moved 1 'field 'x) (1 2 3 5)) (bookMove 'e7 'e5) (bookMove 'd7 'd5) ) ) ((rand T) (bookMove 'e2 'e4)) (T (bookMove 'd2 'd4)) ) ) (move (car (push '*Undo M))) (off *Redo) (cons (caar M) (cdr (asoq (caar M) (cdr M))) (pick cdr (cdar M)) ) ) ) (de yourMove (From To Cls) (when (find '((Mov) (and (== (caar Mov) (get From 'piece)) (== To (pick cdr (cdar Mov))) (or (not Cls) (isa Cls (car (last (car Mov)))) ) ) ) (moves *You) ) (prog1 (car (push '*Undo @)) (off *Redo) (move @) ) ) ) (de undo () (move (cdr (push '*Redo (pop '*Undo)))) ) (de redo () (move (car (push '*Undo (pop '*Redo)))) ) (de setup (Depth You Init) (setq *Depth (or Depth 5) *You You *Me (not You)) (off *White *Black *Moved *Undo *Redo) (for Lst *Board (for This Lst (=: piece) (=: whAtt) (=: blAtt)) ) (if Init (for L Init (with (piece (cadr L) 0 (car L)) (unless (caddr L) (=: cnt 1) (push '*Moved This) ) ) ) (mapc '((Cls Lst) (piece (list '+White Cls) 0 (car Lst)) (piece '(+White +Pawn) 0 (cadr Lst)) (piece '(+Black +Pawn) 0 (get Lst 7)) (piece (list '+Black Cls) 0 (get Lst 8)) ) '(+Rook +Knight +Bishop +Queen +King +Bishop +Knight +Rook) *Board ) ) ) (de main (Depth You Init) (setup Depth You Init) (display T) ) (de go Args (display (cond ((not Args) (xchg '*Me '*You) (myMove)) ((== '- (car Args)) (and *Undo (undo))) ((== '+ (car Args)) (and *Redo (redo))) ((apply yourMove Args) (display T) (myMove)) ) ) ) # Print position to file (de ppos (File) (out File (println (list 'main *Depth *You (lit (mapcar '((This) (list (: field) (val This) (not (memq This *Moved)) ) ) (append *White *Black) ) ) ) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/games/mine.l0000644000000000000000000000620412265263724015353 0ustar rootroot# 08feb11abu # (c) Software Lab. Alexander Burger (load "@lib/term.l") # Spielfeldbelegung: # NIL Verdeckt: Leeres Feld # T Verdeckt: Mine # 0-8 Aufgedeckt, Nachbarminen (seed (in "/dev/urandom" (rd 8))) # Globale Konstanten (de *Minen . 24) # Anzahl der Minen (de *FeldX . 12) # Feldgroesse X (de *FeldY . 12) # Feldgroesse Y (de *NachbarX -1 0 +1 -1 +1 -1 0 +1) (de *NachbarY -1 -1 -1 0 0 +1 +1 +1) # Globale Variablen (de *Feld) # Datenbereich des Minenfeldes # Eine Mine legen (de legeMine () (use (X Y) (while (get *Feld (setq Y (rand 1 *FeldY)) (setq X (rand 1 *FeldX)) ) ) (set (nth *Feld Y X) T) ) ) # *Feld anzeigen (de anzeigen (Flg) (let (N 0 Y 0) (for L *Feld (prin (align 2 (inc 'Y)) " ") (for C L (prin " " (cond ((not C) (inc 'N) "-") (Flg C) ((=T C) "-") (T C) ) ) ) (prinl) ) (prin " ") (for C *FeldX (prin " " (char (+ 64 C))) ) (prinl) (prinl "<" N "> ") ) ) # Ein Feld ausrechnen (de wertFeld (X Y) (when (=0 (set (nth *Feld Y X) (cnt '((DX DY) (=T (get *Feld (+ Y DY) (+ X DX))) ) *NachbarX *NachbarY ) ) ) (mapc '((DX DY) (and (>= *FeldX (inc 'DX X) 1) (>= *FeldY (inc 'DY Y) 1) (not (member (cons DX DY) *Visit)) (push '*Visit (cons DX DY)) (wertFeld DX DY) ) ) *NachbarX *NachbarY ) ) ) # Hauptfunktion (de main (N) (when N (setq *Minen N) ) (setq *Feld (make (do *FeldY (link (need *FeldX)))) ) (do *Minen (legeMine)) ) (de go () (use (K X Y) (anzeigen) (xtUp (+ 2 *FeldY)) (xtRight 4) (one X Y) (catch NIL (until (= "^[" (setq K (key))) (case K ("j" (unless (= Y *FeldY) (xtDown 1) (inc 'Y) ) ) ("k" (unless (= Y 1) (xtUp 1) (dec 'Y) ) ) ("l" (unless (= X *FeldX) (xtRight 2) (inc 'X) ) ) ("h" (unless (= X 1) (xtLeft 2) (dec 'X) ) ) ((" " "^J" "^M") (xtLeft (+ 2 (* 2 X))) (xtUp (dec Y)) (when (=T (get *Feld Y X)) (anzeigen T) (prinl "*** BUMM ***") (throw) ) (let *Visit NIL (wertFeld X Y) ) (anzeigen) (unless (find '((L) (memq NIL L)) *Feld) (prinl ">>> Gewonnen! <<<") (throw) ) (xtUp (- *FeldY Y -3)) (xtRight (+ 2 (* 2 X))) ) ) ) (xtLeft (+ 2 (* 2 X))) (xtDown (+ 3 (- *FeldY Y))) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/games/nim.l0000644000000000000000000000110512265263724015201 0ustar rootroot# 08feb11abu # (c) Software Lab. Alexander Burger (load "@lib/simul.l") # Nim (de nim Pos (game T NIL '((Flg) # Moves (make (for (I . N) Pos (do N (link (cons (cons I N) I (- N)) ) (dec 'N) ) ) ) ) '((Mov) # Move (dec (nth Pos (car Mov)) (cdr Mov)) ) '((Flg) # Cost (let N (apply + Pos) (if (=0 N) -100 N) ) ) ) ) ### Test ### (test '(-100 ((1 . 4) 1 . -4) ((2 . 4) 2 . -4) ((3 . 4) 3 . -4)) (nim 4 4 4) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/games/sudoku.l0000644000000000000000000000343512265263724015740 0ustar rootroot# 10jul10abu # (c) Software Lab. Alexander Burger (load "@lib/simul.l") ### Fields/Board ### # val lst (setq *Board (grid 9 9) *Fields (apply append *Board) ) # Init values to zero (empty) (for L *Board (for This L (=: val 0) ) ) # Build lookup lists (for (X . L) *Board (for (Y . This) L (=: lst (make (let A (* 3 (/ (dec X) 3)) (do 3 (inc 'A) (let B (* 3 (/ (dec Y) 3)) (do 3 (inc 'B) (unless (and (= A X) (= B Y)) (link (prop (get *Board A B) 'val) ) ) ) ) ) ) (for Dir '(`west `east `south `north) (for (This (Dir This) This (Dir This)) (unless (memq (:: val) (made)) (link (:: val)) ) ) ) ) ) ) ) # Cut connections (for display only) (for (X . L) *Board (for (Y . This) L (when (member X (3 6)) (con (car (val This))) ) (when (member Y (4 7)) (set (cdr (val This))) ) ) ) # Display board (de display () (disp *Board 0 '((This) (if (=0 (: val)) " " (pack " " (: val) " ") ) ) ) ) # Initialize board (de main (Lst) (for (Y . L) Lst (for (X . N) L (put *Board X (- 10 Y) 'val N) ) ) (display) ) # Find solution (de go () (unless (recur (*Fields) (with (car *Fields) (if (=0 (: val)) (loop (NIL (or (assoc (inc (:: val)) (: lst)) (recurse (cdr *Fields)) ) ) (T (= 9 (: val)) (=: val 0)) ) (recurse (cdr *Fields)) ) ) ) (display) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/games/ttt.l0000644000000000000000000000337012265263724015237 0ustar rootroot# 08feb11abu # (c) Software Lab. Alexander Burger # *Board (load "@lib/simul.l") (de display () (for Y (3 2 1) (prinl " +---+---+---+") (prin " " Y) (for X (1 2 3) (prin " | " (or (get *Board X Y) " ")) ) (prinl " |") ) (prinl " +---+---+---+") (prinl " a b c") ) (de find3 (P) (find '((X Y DX DY) (do 3 (NIL (= P (get *Board X Y))) (inc 'X DX) (inc 'Y DY) T ) ) (1 1 1 1 2 3 1 1) (1 2 3 1 1 1 1 3) (1 1 1 0 0 0 1 1) (0 0 0 1 1 1 1 -1) ) ) (de myMove () (when (game NIL 8 '((Flg) # Moves (unless (find3 (or (not Flg) 0)) (make (for (X . L) *Board (for (Y . P) L (unless P (link (cons (cons X Y (or Flg 0)) (list X Y) ) ) ) ) ) ) ) ) '((Mov) # Move (set (nth *Board (car Mov) (cadr Mov)) (cddr Mov)) ) '((Flg) # Cost (if (find3 (or Flg 0)) -100 0) ) ) (let Mov (caadr @) (set (nth *Board (car Mov) (cadr Mov)) 0) ) (display) ) ) (de yourMove (X Y) (and (sym? X) (>= 3 (setq X (- (char X) 96)) 1) (num? Y) (>= 3 Y 1) (not (get *Board X Y)) (set (nth *Board X Y) T) (display) ) ) (de main () (setq *Board (make (do 3 (link (need 3))))) (display) ) (de go Args (cond ((not (yourMove (car Args) (cadr Args))) "Illegal move!" ) ((find3 T) "Congratulation, you won!") ((not (myMove)) "No moves") ((find3 0) "Sorry, you lost!") ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/games/xchess0000755000000000000000000000261412265263724015472 0ustar rootroot#!/usr/bin/picolisp /usr/lib/picolisp/lib.l # 15jul11abu # (c) Software Lab. Alexander Burger (load "/usr/share/picolisp/games/chess.l") (de reply @ (prinl (glue " " (rest))) (flush) ) (de xmove () (when (myMove) (let L (car *Undo) (reply "move" (pack (cdr (asoq (caar L) (cdr L))) (pick cdr (cdar L)) ) ) ) ) ) (in NIL (loop (case (read) (protover (read) (reply "feature" "myname=\"PicoLisp Chess\"") (reply "feature" "time=0" "sigint=0" "usermove=1") (reply "feature" "done=1") ) (accepted (read)) (new (seed (in "/dev/urandom" (rd 3))) (setup (format (sys "XCHESS_DEPTH"))) ) (level (line T)) (sd (setup (read))) (black (off *Me) (on *You)) (white (on *Me) (off *You)) (usermove (let (L (line) From (pack (head 2 L)) To (pack (head 2 (cddr L))) F (get L 5)) (if (and (yourMove (intern From) (intern To)) (or (not F) (= "q" F))) (xmove) (reply "Illegal move:" (pack L)) ) ) ) (go (xchg '*Me '*You) (xmove)) (undo (undo)) (remove (undo) (undo)) (result (line T)) (random) (hard) (quit (bye)) (T (reply "Error (unknown command):" @)) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/0000755000000000000000000000000012265263724014111 5ustar rootrootpicolisp-3.1.5.2.orig/src64/Makefile0000644000000000000000000000602512265263724015554 0ustar rootroot# 08jan13abu # (c) Software Lab. Alexander Burger .SILENT: bin = ../bin lib = ../lib ifeq ($(MAKECMDGOALS), x86-64.linux) UNAME = Linux MACHINE = x86_64 else ifeq ($(MAKECMDGOALS), x86-64.freeBsd) UNAME = FreeBSD MACHINE = x86_64 else ifeq ($(MAKECMDGOALS), x86-64.sunOs) UNAME = SunOS MACHINE = x86_64 else ifeq ($(MAKECMDGOALS), ppc64.linux) UNAME = Linux MACHINE = ppc64 else UNAME = $(shell uname) ifeq ($(MAKECMDGOALS), emu) MACHINE = emu else MACHINE = $(shell uname -m) endif endif endif endif endif SYS = FMT = .c ARCH = emu STRIP = : ifeq ($(UNAME), Linux) OS = Linux ifeq ($(MACHINE), x86_64) SYS = .linux FMT = .s ARCH = x86-64 AS = as else ifeq ($(MACHINE), ppc64) SYS = .linux FMT = .s ARCH = ppc64 AS = as -mppc64 -a64 endif endif LD-MAIN = -Wl,--no-as-needed -rdynamic -lc -lm -ldl LD-SHARED = -shared -export-dynamic STRIP = strip else ifeq ($(UNAME), FreeBSD) OS = FreeBSD SYS = .freeBsd FMT = .s ARCH = x86-64 AS = as LD-MAIN = -Wl,--no-as-needed -rdynamic -lc -lm LD-SHARED = -shared -rdynamic STRIP = strip else ifeq ($(UNAME), SunOS) OS = SunOS SYS = .sunOs FMT = .s ARCH = x86-64 AS = gas --64 LD-MAIN = -m64 -lc -lm -ldl -lsocket -lnsl LD-SHARED = -m64 -shared STRIP = strip else ifeq ($(UNAME), Darwin) OS = Darwin LD-MAIN = -lc -lm -ldl LD-SHARED = -dynamiclib -undefined dynamic_lookup STRIP = strip -x endif endif endif endif baseFiles = version.l glob.l main.l \ gc.l apply.l flow.l sym.l subr.l big.l io.l db.l net.l err.l sFiles = \ $(ARCH)$(SYS).base$(FMT) \ $(ARCH)$(SYS).ext$(FMT) \ $(ARCH)$(SYS).ht$(FMT) all: picolisp x86-64.linux: $(sFiles) x86-64.freeBsd: $(sFiles) x86-64.sunOs: $(sFiles) ppc64.linux: $(sFiles) emu: picolisp picolisp: $(bin)/picolisp $(lib)/ext $(lib)/ht ### Link ### $(bin)/picolisp: $(ARCH)$(SYS).base.o $(CC) -o $(bin)/picolisp $(ARCH)$(SYS).base.o $(LD-MAIN) $(STRIP) $(bin)/picolisp $(lib)/ext: $(ARCH)$(SYS).ext.o $(CC) -o $(lib)/ext $(ARCH)$(SYS).ext.o $(LD-SHARED) $(STRIP) $(lib)/ext $(lib)/ht: $(ARCH)$(SYS).ht.o $(CC) -o $(lib)/ht $(ARCH)$(SYS).ht.o $(LD-SHARED) $(STRIP) $(lib)/ht ### Assemble ### .s.o: $(AS) -o $*.o $*.s ### Compile ### sysdefs: sysdefs.c $(CC) -o sysdefs -D_FILE_OFFSET_BITS=64 sysdefs.c $(STRIP) sysdefs emu.base.o: sysdefs emu.base.c $(CC) -c -O -fomit-frame-pointer -D_FILE_OFFSET_BITS=64 emu.base.c .c.o: $(CC) -c -O -fpic -fomit-frame-pointer -D_FILE_OFFSET_BITS=64 $*.c ### Translate ### $(ARCH)$(SYS).base$(FMT): arch/$(ARCH).l $(baseFiles) sys/$(ARCH)$(SYS).code.l ./mkAsm $(ARCH) "$(SYS)" $(FMT) $(OS) base "" $(lib)/map $(baseFiles) sys/$(ARCH)$(SYS).code.l $(ARCH)$(SYS).ext$(FMT): arch/$(ARCH).l ext.l $(ARCH)$(SYS).base$(FMT) ./mkAsm $(ARCH) "$(SYS)" $(FMT) $(OS) ext T "" ext.l $(ARCH)$(SYS).ht$(FMT): arch/$(ARCH).l ht.l $(ARCH)$(SYS).base$(FMT) ./mkAsm $(ARCH) "$(SYS)" $(FMT) $(OS) ht T "" ht.l ### Clean up ### clean: rm -f emu.*.c *.s *.o *.symtab sysdefs # vi:noet:ts=4:sw=4 picolisp-3.1.5.2.orig/src64/apply.l0000644000000000000000000012451312265263724015421 0ustar rootroot# 13nov12abu # (c) Software Lab. Alexander Burger (code 'applyXYZ_E 0) ld C (Y) # Get 'foo' do cnt C # Short number? if nz # Yes push (EnvApply) # Build apply frame link sym S # Align stack to cell boundary if nz push ZERO end ld E Nil # Init 'args' list do cmp Z Y # Any args? while ne # Yes push (Z) # Next arg ld A S # Value address push ZERO # Dummy symbol's tail push E # Dummy cell's CDR push A # CAR cmp S (StkLimit) # Stack check jlt stkErrX ld E S # Set 'args' list add Z I loop push E # 'args' list push C # 'fun' ld E S # Set 'exe' link ld (EnvApply) L # Close apply frame call (C T) # Eval SUBR drop pop (EnvApply) ret end big C # Undefined if bignum jnz undefinedCX cmp S (StkLimit) # Stack check jlt stkErrX atom C # Pair? if z # Yes # Apply EXPR push X # Save 'exe' ld X (C) # Parameter list in X push (EnvBind) # Build bind frame link push (At) # Bind At push At do atom X # More parameters? while z # Yes ld E (X) # Get symbol ld X (X CDR) push (E) # Save old value push E # Save symbol cmp Y Z # More args? if ne # Yes sub Y I ld (E) (Y) # Set new value to next arg else ld (E) Nil # New value NIL end loop cmp X Nil # NIL-terminated parameter list? if eq # Yes link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld Z (C CDR) # Body in Z prog Z # Run body add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' ret end # Non-NIL parameter cmp X At # '@'? if ne # No push (X) # Save last parameter's old value push X # and the last parameter link ld (EnvBind) L # Close bind frame push 0 # Init env swap cmp Y Z # More args? if eq # No ld (X) Nil # Set new value to NIL ld Z (C CDR) # Body in Z prog Z # Run body else push (EnvApply) # Build apply frame link sym S # Align stack to cell boundary if nz push ZERO end ld E Nil # Init 'args' list do push (Z) # Next arg push ZERO # Dummy symbol's tail push E # Dummy cell's CDR lea A (S II) # Value address push A # CAR cmp S (StkLimit) # Stack check jlt stkErrX ld E S # Set 'args' list add Z I cmp Z Y # More args? until eq # No ld (X) E # Set new value to 'args' list link ld (EnvApply) L # Close apply frame ld Z (C CDR) # Body in Z prog Z # Run body drop pop (EnvApply) end add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' ret end # Evaluated argument list link ld (EnvBind) L # Close bind frame push 0 # Init env swap push (EnvNext) # Save current 'next' push (EnvArgs) # and varArgs base cmp Y Z # Any args? if eq # No ld (EnvArgs) 0 ld (EnvNext) 0 else link # Build varArgs frame do sub Y I push (Y) # Push next argument cmp S (StkLimit) # Stack check jlt stkErrX cmp Y Z # More args? until eq # No ld (EnvArgs) S # Set new varArgs base ld (EnvNext) L # Set new 'next' link # Close varArgs frame end ld Z (C CDR) # Body in Z prog Z # Run body null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end pop (EnvArgs) # Restore varArgs base pop (EnvNext) # and 'next' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' ret end ld A (C) # Else symbolic, get value cmp A (Meth) # Method? if eq # Yes sub Y I # First arg ld E (Y) # Get object num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end push Z # Save arg pointers push Y ld Y C # 'msg' ld Z 0 # No classes call methodEY_FCYZ # Found? jne msgErrYX # No xchg Z (S I) # 'cls' xchg (S I) (EnvCls) xchg Y (S) # 'key' xchg (S) (EnvKey) # 'key' push X # 'exe' ld X (C) # Parameter list in X push (EnvBind) # Build bind frame link push (At) # Bind At push At push (This) # Bind This push This ld (This) (Y) # to object do atom X # More parameters? while z # Yes ld E (X) # Get symbol ld X (X CDR) push (E) # Save old value push E # Save symbol cmp Y Z # More args? if ne # Yes sub Y I ld (E) (Y) # Set new value to next arg else ld (E) Nil # New value NIL end loop cmp X Nil # NIL-terminated parameter list? if eq # Yes link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld Z (C CDR) # Body in Z prog Z # Run body add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret end # Non-NIL parameter cmp X At # '@'? if ne # No push (X) # Save last parameter's old value push X # and the last parameter link ld (EnvBind) L # Close bind frame push 0 # Init env swap cmp Y Z # More args? if eq # No ld (X) Nil # Set new value to NIL ld Z (C CDR) # Body in Z prog Z # Run body else push (EnvApply) # Build apply frame link sym S # Align stack to cell boundary if nz push ZERO end ld E Nil # Init 'args' list do push (Z) # Next arg push ZERO # Dummy symbol's tail push E # Dummy cell's CDR lea A (S II) # Value address push A # CAR cmp S (StkLimit) # Stack check jlt stkErrX ld E S # Set 'args' list add Z I cmp Z Y # More args? until eq # No ld (X) E # Set new value to 'args' list link ld (EnvApply) L # Close apply frame ld Z (C CDR) # Body in Z prog Z # Run body drop pop (EnvApply) end add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret end # Evaluated argument list link ld (EnvBind) L # Close bind frame push 0 # Init env swap push (EnvNext) # Save current 'next' push (EnvArgs) # and varArgs base cmp Y Z # Any args? if eq # No ld (EnvArgs) 0 ld (EnvNext) 0 else link # Build varArgs frame do sub Y I push (Y) # Push next argument cmp S (StkLimit) # Stack check jlt stkErrX cmp Y Z # More args? until eq # No ld (EnvArgs) S # Set new varArgs base ld (EnvNext) L # Set new 'next' link # Close varArgs frame end ld Z (C CDR) # Body in Z prog Z # Run body null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end pop (EnvArgs) # Restore varArgs base pop (EnvNext) # and 'next' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret end cmp A (A) # Auto-symbol? if eq # Yes call sharedLibC_FA # Try dynamic load jz undefinedCX end ld C A loop (code 'applyVarXYZ_E 0) ld C (Y) # Get 'foo' do cnt C # Short number? if nz # Yes push (EnvApply) # Build apply frame link sym S # Align stack to cell boundary if nz push ZERO end ld E Nil # Init 'args' list do cmp Z Y # Any args? while ne # Yes push ((Z)) # Next arg ld A S # Value address push ZERO # Dummy symbol's tail push E # Dummy cell's CDR push A # CAR cmp S (StkLimit) # Stack check jlt stkErrX ld E S # Set 'args' list add Z I loop push E # 'args' list push C # 'fun' ld E S # Set 'exe' link ld (EnvApply) L # Close apply frame call (C T) # Eval SUBR drop pop (EnvApply) ret end big C # Undefined if bignum jnz undefinedCX cmp S (StkLimit) # Stack check jlt stkErrX atom C # Pair? if z # Yes # Apply EXPR push X # Save 'exe' ld X (C) # Parameter list in X push (EnvBind) # Build bind frame link push (At) # Bind At push At do atom X # More parameters? while z # Yes ld E (X) # Get symbol ld X (X CDR) push (E) # Save old value push E # Save symbol cmp Y Z # More args? if ne # Yes sub Y I ld (E) ((Y)) # Set new value to CAR of next arg else ld (E) Nil # New value NIL end loop cmp X Nil # NIL-terminated parameter list? if eq # Yes link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld Z (C CDR) # Body in Z prog Z # Run body add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' ret end # Non-NIL parameter cmp X At # '@'? if ne # No push (X) # Save last parameter's old value push X # and the last parameter link ld (EnvBind) L # Close bind frame push 0 # Init env swap cmp Y Z # More args? if eq # No ld (X) Nil # Set new value to NIL ld Z (C CDR) # Body in Z prog Z # Run body else push (EnvApply) # Build apply frame link sym S # Align stack to cell boundary if nz push ZERO end ld E Nil # Init 'args' list do push ((Z)) # Next arg push ZERO # Dummy symbol's tail push E # Dummy cell's CDR lea A (S II) # Value address push A # CAR cmp S (StkLimit) # Stack check jlt stkErrX ld E S # Set 'args' list add Z I cmp Z Y # More args? until eq # No ld (X) E # Set new value to 'args' list link ld (EnvApply) L # Close apply frame ld Z (C CDR) # Body in Z prog Z # Run body drop pop (EnvApply) end add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' ret end # Evaluated argument list link ld (EnvBind) L # Close bind frame push 0 # Init env swap push (EnvNext) # Save current 'next' push (EnvArgs) # and varArgs base cmp Y Z # Any args? if eq # No ld (EnvArgs) 0 ld (EnvNext) 0 else link # Build varArgs frame do sub Y I push ((Y)) # Push CAR of next argument cmp S (StkLimit) # Stack check jlt stkErrX cmp Y Z # More args? until eq # No ld (EnvArgs) S # Set new varArgs base ld (EnvNext) L # Set new 'next' link # Close varArgs frame end ld Z (C CDR) # Body in Z prog Z # Run body null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end pop (EnvArgs) # Restore varArgs base pop (EnvNext) # and 'next' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' ret end ld A (C) # Else symbolic, get value cmp A (Meth) # Method? if eq # Yes sub Y I # First arg ld E ((Y)) # Get object num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end push Z # Save arg pointers push Y ld Y C # 'msg' ld Z 0 # No classes call methodEY_FCYZ # Found? jne msgErrYX # No xchg Z (S I) # 'cls' xchg (S I) (EnvCls) xchg Y (S) # 'key' xchg (S) (EnvKey) # 'key' push X # 'exe' ld X (C) # Parameter list in X push (EnvBind) # Build bind frame link push (At) # Bind At push At push (This) # Bind This push This ld (This) ((Y)) # to object do atom X # More parameters? while z # Yes ld E (X) # Get symbol ld X (X CDR) push (E) # Save old value push E # Save symbol cmp Y Z # More args? if ne # Yes sub Y I ld (E) ((Y)) # Set new value to CAR of next arg else ld (E) Nil # New value NIL end loop cmp X Nil # NIL-terminated parameter list? if eq # Yes link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld Z (C CDR) # Body in Z prog Z # Run body add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret end # Non-NIL parameter cmp X At # '@'? if ne # No push (X) # Save last parameter's old value push X # and the last parameter link ld (EnvBind) L # Close bind frame push 0 # Init env swap cmp Y Z # More args? if eq # No ld (X) Nil # Set new value to NIL ld Z (C CDR) # Body in Z prog Z # Run body else push (EnvApply) # Build apply frame link sym S # Align stack to cell boundary if nz push ZERO end ld E Nil # Init 'args' list do push ((Z)) # Next arg push ZERO # Dummy symbol's tail push E # Dummy cell's CDR lea A (S II) # Value address push A # CAR cmp S (StkLimit) # Stack check jlt stkErrX ld E S # Set 'args' list add Z I cmp Z Y # More args? until eq # No ld (X) E # Set new value to 'args' list link ld (EnvApply) L # Close apply frame ld Z (C CDR) # Body in Z prog Z # Run body drop pop (EnvApply) end add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret end # Evaluated argument list link ld (EnvBind) L # Close bind frame push 0 # Init env swap push (EnvNext) # Save current 'next' push (EnvArgs) # and varArgs base cmp Y Z # Any args? if eq # No ld (EnvArgs) 0 ld (EnvNext) 0 else link # Build varArgs frame do sub Y I push ((Y)) # Push CAR of next argument cmp S (StkLimit) # Stack check jlt stkErrX cmp Y Z # More args? until eq # No ld (EnvArgs) S # Set new varArgs base ld (EnvNext) L # Set new 'next' link # Close varArgs frame end ld Z (C CDR) # Body in Z prog Z # Run body null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end pop (EnvArgs) # Restore varArgs base pop (EnvNext) # and 'next' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X # 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret end cmp A (A) # Auto-symbol? if eq # Yes call sharedLibC_FA # Try dynamic load jz undefinedCX end ld C A loop # (apply 'fun 'lst ['any ..]) -> any (code 'doApply 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) eval # Eval 'fun' link push E ld Y S # Pointer to 'fun' in Y ld Z (Z CDR) # Second arg ld E (Z) eval+ # Eval 'lst' do ld Z (Z CDR) # Args atom Z # More? while z # Yes push E # Save 'lst' ld E (Z) eval+ # Eval next arg xchg E (S) # Keep 'lst' in E loop do atom E # Expand 'lst' while z push (E) cmp S (StkLimit) # Stack check jlt stkErrX ld E (E CDR) loop ld Z S # Z on last argument link # Close frame call applyXYZ_E # Apply drop pop Z pop Y pop X ret # (pass 'fun ['any ..]) -> any (code 'doPass 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'any' args ld Z (Z CDR) # Any? atom Z while z # Yes ld E (Z) eval+ # Eval next 'lst' push E loop ld C (EnvNext) # VarArgs do cmp C (EnvArgs) # Any? while ne # Yes sub C I push (C) # Next arg loop ld Z S # Z on last argument link # Close frame call applyXYZ_E # Apply drop pop Z pop Y pop X ret # (maps 'fun 'sym ['lst ..]) -> any (code 'doMaps 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Save 'fun' ld Y S # Pointer to 'fun' in Y ld E (Z) ld Z (Z CDR) eval+ # Eval 'sym' push E # 'sym' do # 'lst' args atom Z # More 'lst' args? while z # Yes ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) loop link # Last argument ld E (Y -I) # Get 'sym' num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end ld E (E TAIL) # Get property list off E SYM # Clear 'extern' tag ld (Y -I) E ld E Nil # Preset return value do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L I) # Last arg call applyVarXYZ_E # Apply pop Y lea Z (L I) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop drop pop Z pop Y pop X ret # (map 'fun 'lst ..) -> lst (code 'doMap 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No link # Last argument ld E Nil # Preset return value do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L I) # Last arg call applyXYZ_E # Apply pop Y lea Z (L I) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop drop pop Z pop Y pop X ret # (mapc 'fun 'lst ..) -> lst (code 'doMapc 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No link # Last argument ld E Nil # Preset return value do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L I) # Last arg call applyVarXYZ_E # Apply pop Y lea Z (L I) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop drop pop Z pop Y pop X ret # (maplist 'fun 'lst ..) -> lst (code 'doMaplist 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push Nil # Result link # Last argument push 0 # Result tail do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L II) # Last arg call applyXYZ_E # Apply pop Y call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil null (L -I) # Result tail? if z # No ld (L I) C # Store result else ld ((L -I) CDR) C # Set new CDR of result tail end ld (L -I) C # Store result tail lea Z (L II) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (mapcar 'fun 'lst ..) -> lst (code 'doMapcar 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push Nil # Result link # Last argument push 0 # Result tail do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L II) # Last arg call applyVarXYZ_E # Apply pop Y call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil null (L -I) # Result tail? if z # No ld (L I) C # Store result else ld ((L -I) CDR) C # Set new CDR of result tail end ld (L -I) C # Store result tail lea Z (L II) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (mapcon 'fun 'lst ..) -> lst (code 'doMapcon 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push Nil # Result link # Last argument push 0 # Result tail do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L II) # Last arg call applyXYZ_E # Apply pop Y atom E # Got pair? if z # Yes null (L -I) # Result tail? if z # No ld (L I) E # Store result else ld A (L -I) # Else get result tail do atom (A CDR) # Find last cell while z ld A (A CDR) loop ld (A CDR) E # Set new CDR end ld (L -I) E # Store result tail end lea Z (L II) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (mapcan 'fun 'lst ..) -> lst (code 'doMapcan 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push Nil # Result link # Last argument push 0 # Result tail do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L II) # Last arg call applyVarXYZ_E # Apply pop Y atom E # Got pair? if z # Yes null (L -I) # Result tail? if z # No ld (L I) E # Store result else ld A (L -I) # Else get result tail do atom (A CDR) # Find last cell while z ld A (A CDR) loop ld (A CDR) E # Set new CDR end ld (L -I) E # Store result tail end lea Z (L II) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (filter 'fun 'lst ..) -> lst (code 'doFilter 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push Nil # Result link # Last argument push 0 # Result tail do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L II) # Last arg call applyVarXYZ_E # Apply pop Y cmp E Nil # NIL? if ne # No call consE_C # Cons with NIL ld (C) ((Y -I)) # Element of first 'lst' ld (C CDR) Nil null (L -I) # Result tail? if z # No ld (L I) C # Store result else ld ((L -I) CDR) C # Set new CDR of result tail end ld (L -I) C # Store result tail end lea Z (L II) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (extract 'fun 'lst ..) -> lst (code 'doExtract 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push Nil # Result link # Last argument push 0 # Result tail do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L II) # Last arg call applyVarXYZ_E # Apply pop Y cmp E Nil # NIL? if ne # No call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil null (L -I) # Result tail? if z # No ld (L I) C # Store result else ld ((L -I) CDR) C # Set new CDR of result tail end ld (L -I) C # Store result tail end lea Z (L II) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (seek 'fun 'lst ..) -> lst (code 'doSeek 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No link # Last argument ld E Nil # Preset return value do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L I) # Last arg call applyXYZ_E # Apply pop Y cmp E Nil # NIL? if ne # No ld E (Y -I) # Return first 'lst' break T end lea Z (L I) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop drop pop Z pop Y pop X ret # (find 'fun 'lst ..) -> any (code 'doFind 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No link # Last argument ld E Nil # Preset return value do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L I) # Last arg call applyVarXYZ_E # Apply pop Y cmp E Nil # NIL? if ne # No ld E ((Y -I)) # Return CAR of first 'lst' break T end lea Z (L I) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop drop pop Z pop Y pop X ret # (pick 'fun 'lst ..) -> any (code 'doPick 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No link # Last argument ld E Nil # Preset return value do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L I) # Last arg call applyVarXYZ_E # Apply pop Y cmp E Nil # NIL? break ne # No lea Z (L I) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop drop pop Z pop Y pop X ret # (cnt 'fun 'lst ..) -> cnt (code 'doCnt 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No link # Last argument push ZERO # Result do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L I) # Last arg call applyVarXYZ_E # Apply pop Y cmp E Nil # NIL? if ne # No add (S) (hex "10") # Increment count end lea Z (L I) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop pop E # Get result drop pop Z pop Y pop X ret # (sum 'fun 'lst ..) -> num (code 'doSum 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push ZERO # Safe push ZERO # Result link # Last argument do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L III) # Last arg call applyVarXYZ_E # Apply pop Y num E # Number? if nz # Yes ld (L II) E # Save ld A (L I) # Result so far call addAE_A # Add ld (L I) A # Result end lea Z (L III) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (maxi 'fun 'lst ..) -> any (code 'doMaxi 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push Nil # Value push Nil # Result link # Last argument do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L III) # Last arg call applyVarXYZ_E # Apply ld Y E # Keep ld A (L II) # Maximal value call compareAE_F # Compare with current if lt ld (L I) (((S) -I)) # New result ld (L II) Y # New maximum end pop Y lea Z (L III) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (mini 'fun 'lst ..) -> any (code 'doMini 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push TSym # Value push Nil # Result link # Last argument do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L III) # Last arg call applyVarXYZ_E # Apply ld Y E # Keep ld A (L II) # Minimal value call compareAE_F # Compare with current if gt ld (L I) (((S) -I)) # New result ld (L II) Y # New minimum end pop Y lea Z (L III) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun'? until eq # Yes loop ld E (L I) # Result drop pop Z pop Y pop X ret # (fish 'fun 'any) -> lst (code 'doFish 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) eval # Eval 'fun' link push E # Push 'fun' ld Y S # Pointer to 'fun' in Y ld Z (Z CDR) # Second arg ld E (Z) eval+ # Eval 'any' push ZERO # Apply arg push E # 'any' push Nil # Result link # Close frame ld A (L II) # Get 'any' call fishAXY # Fish for results ld E (L I) # Result drop pop Z pop Y pop X ret (code 'fishAXY 0) push A # Save arg push Y lea Z (L III) # Set apply arg ld (Z) A call applyXYZ_E # Apply pop Y pop A cmp E Nil # NIL? if ne # No call cons_C # New cell ld (C) A # Cons arg ld (C CDR) (L I) # into result ld (L I) C ret end atom A # Pair? jnz ret # No cmp (A CDR) Nil # CDR? if ne # Yes push A ld A (A CDR) call fishAXY # Recurse on CDR pop A end ld A (A) jmp fishAXY # Recurse on CAR # (by 'fun1 'fun2 'lst ..) -> lst (code 'doBy 2) push X push Y push Z ld X E # Keep expression in X ld Z (E CDR) # Z on args ld E (Z) ld Z (Z CDR) eval # Eval 'fun1' link push E # Push 'fun1' ld E (Z) ld Z (Z CDR) eval+ # Eval 'fun2' xchg E (S) # Push push E # Push 'fun1' ld Y S # Pointer to 'fun1' in Y do # 'lst' args ld E (Z) eval+ # Eval next 'lst' push E ld Z (Z CDR) atom Z # More 'lst' args? until nz # No push Nil # Result link # Last argument push 0 # Result tail do atom (Y -I) # First 'lst' done? while z # No push Y lea Z (L II) # Last arg call applyVarXYZ_E # Apply pop Y call consE_C # Cons with element from first 'lst' ld (C) E ld (C CDR) ((Y -I)) call consC_A # Concat to result ld (A) C ld (A CDR) Nil null (L -I) # Result tail? if z # No ld (L I) A # Store result else ld ((L -I) CDR) A # Set new CDR of result tail end ld (L -I) A # Store result tail lea Z (L II) # Last arg do ld (Z) ((Z) CDR) # Pop all lists add Z I cmp Z Y # Reached 'fun1'? until eq # Yes loop ld Z Y # Point to 'fun1' add Y I # Pointer to 'fun2' in Y ld (Z) (L I) # Result call applyXYZ_E # Apply ld C E # Remove CARs in result list do atom C # More elements? while z # Yes ld (C) ((C) CDR) ld C (C CDR) loop drop pop Z pop Y pop X ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/arch/0000755000000000000000000000000012265263724015026 5ustar rootrootpicolisp-3.1.5.2.orig/src64/arch/emu.l0000644000000000000000000013754012265263724016003 0ustar rootroot# 23jun13abu # (c) Software Lab. Alexander Burger # Byte order (in '("./sysdefs") (case (read) ("L" (on *LittleEndian)) ("B" (off *LittleEndian)) (T (quit "Bad endianess")) ) (case (read) (32 (off *Bits64)) (64 (on *Bits64)) (T (quit "Bad wordsize")) ) ) (off *AlignedCode) # Register assignments (de *Registers (A . "A") (C . "C") (E . "E") (B . "A.b[0]") (D "A" . "C") (X . "X") (Y . "Y") (Z . "Z") (L . "L") (S . "S") (F . T) ) # Emulator specific (off *AsmData *AsmCode *AsmOpcodes *Labels *SysFun) (off *BaseData *BaseCode *BaseOpcodes) (zero *AsmPos *OpOffs) # Direct address expressions (de directExpr (Str) (let (Lst (str Str "_") A (_aggr)) (or (num? A) (pack "(uint8_t*)" (text (cdr A) (car A))) ) ) ) (de _aggr () (let X (_prod) (while (member (car Lst) '("+" "-")) (let (Op (intern (pop 'Lst)) Y (_prod)) (if2 (pair X) (pair Y) (if (= '+ Op) (quit "Bad direct expression") (setq X (- (car X) (car Y))) ) (set X (Op (car X) Y)) (setq X (cons (Op X (car Y)))) (and (sym? X) (or (baseCode X) (absCode X)) (setq X @)) (and (sym? Y) (or (baseCode Y) (absCode Y)) (setq Y @)) (setq X (Op X Y)) ) ) ) X ) ) (de _prod () (let X (_term) (while (member (car Lst) '("*" "/")) (setq X ((intern (pop 'Lst)) X (_term))) ) X ) ) (de _term () (let X (pop 'Lst) (cond ((num? X) X) ((and *FPic (get *BaseData X)) (cons @ "Data+@1") ) ((get *AsmData X) (cons (car @) (if *FPic "LibData+@1" "Data+@1")) ) ((baseCode X) (cons @ "(Code+@1)") ) ((absCode X) (cons @ (if *FPic "(LibCode+@1)" "(Code+@1)")) ) ((= "+" X) (_term)) ((= "-" X) (- (_term))) ((= "(" X) (prog1 (_aggr) (pop 'Lst))) (T (quit "Bad term" X)) ) ) ) (de sysFun (S O) (cond ((=0 O) (pack "(void(*)())" S)) ((absCode S) (push1 '*SysFun (pack "void fun" @ "(long a, long c, long e, long x, long y, long z) {begin(" @ ", a, c, e, x, y, z);}" ) ) (pack "(void(*)())fun" @) ) (T (quit "Bad function address" S)) ) ) # Addressing modes (de op.p (Arg M) (cond ((=0 M) (pack "(uint8_t*)" Arg)) # Immediate ((not M) (pack Arg ".p")) # Register ((get Arg 'sys) @) ((=T M) # Direct (let E (directExpr Arg) (if (num? E) (pack "(uint8_t*)" E) (pack "(" E ")") ) ) ) ((get Arg 1 'sys) @) ((=T (cdr M)) (let E (directExpr (cdr Arg)) (pack "(*(ptr)(" ((if (num? E) op.p op.n) (car Arg) (car M)) " + " E ")).p" ) ) ) ((cdr Arg) (pack "(*(ptr)(" (op.p (car Arg) (car M)) " + " @ ")).p") ) (T (pack "(*(ptr)" (op.p (car Arg) (car M)) ").p")) ) ) (de op.n (Arg M) (cond ((=0 M) # Immediate (let N (format Arg) (if (>= N `(** 2 31)) (pack "0x" (hex N) "LL") Arg ) ) ) ((not M) # Register (if (= "A.b[0]" Arg) Arg (pack Arg ".n") ) ) ((=T M) # Direct (if (get Arg 'sys) (pack "(uint64_t)(unsigned long)" (sysFun @ T)) (let E (directExpr Arg) (if (num? E) (pack "(uint64_t)" E) (pack "((uint64_t)(unsigned long)(" E "))") ) ) ) ) ((=T (cdr M)) (let E (directExpr (cdr Arg)) (pack "((ptr)(" ((if (num? E) op.p op.n) (car Arg) (car M)) " + " E "))->n" ) ) ) ((cdr Arg) (pack "((ptr)(" (op.p (car Arg) (car M)) " + " @ "))->n") ) (T (pack "((ptr)" (op.p (car Arg) (car M)) ")->n")) ) ) (de op.i (S O) (if (and (format (setq S (op.n S O))) (>= 32767 (abs @))) S (pack "(int)" S) ) ) (de op.b (Arg M) (cond ((=0 M) Arg) # Immediate ((not M) # Register (if (= "A.b[0]" Arg) Arg (pack Arg ".b[0]") ) ) ((=T M) # Direct (let E (directExpr Arg) (if (num? E) (pack "(uint8_t)" E) (pack "*(" E ")") ) ) ) ((=T (cdr M)) (let E (directExpr (cdr Arg)) (pack "*(" ((if (num? E) op.p op.n) (car Arg) (car M)) " + " E ")" ) ) ) ((cdr Arg) (pack "*(" (op.p (car Arg) (car M)) " + " @ ")") ) (T (pack "*" (op.p (car Arg) (car M)))) ) ) (de op.a (Arg M) (cond ((=0 M) (quit "Can't take address" Arg)) # Immediate ((flg? M) (op.p Arg M)) # Register or Direct ((=T (cdr M)) (let E (directExpr (cdr Arg)) (pack "(" ((if (num? E) op.p op.n) (car Arg) (car M)) " + " E ")" ) ) ) ((cdr Arg) (pack "(" (op.p (car Arg) (car M)) " + " @ ")") ) (T (op.p (car Arg) (car M))) ) ) (de highWord (Arg M) (if (atom M) # Immediate, Register or Direct 0 (if (cdr Arg) (pack "((ptr)(" (op.p (car Arg) (car M)) " + " @ " + 8))->n") (pack "((ptr)(" (op.p (car Arg) (car M)) " + 8))->n") ) ) ) ### Instruction set ### (de alignSection (Align) (if (== 'data *Section) (when (gt0 (% (asmDataLength) 16)) (conc (car *AsmData) (need (- 16 @) 0)) ) (setq Align (/ Align 2)) (until (= Align (& *AsmPos 7)) (addCode '(NIL '(nop))) ) ) ) (de fmtInstruction (Lst) (replace (chop (str Lst)) "\"") ) (de opcode ("X" "Args" "Body") (cond ((= "X" '(nop)) 0) ((index "X" *BaseOpcodes) @) ((assoc "X" *AsmOpcodes) (+ *OpOffs (index @ *AsmOpcodes))) (T (queue '*AsmOpcodes (cons "X" ~(as *Dbg (pack "fprintf(stderr, \"%ld: %s\\n\", Code<=PC && PC MAX64 - @2;" ) ) ) (asm subc (Dst D Src S) (genCode (Dst D Src S) (list 'subc Dst Src) ((op.n Dst D) (op.n Src S)) "if ((tmp.n = @1 - Carry) > MAX64 - Carry)" " Result = @1 = MAX64 - @2;" "else" " Carry = (Result = @1 = tmp.n - @2) > MAX64 - @2;" ) ) (asm inc (Dst D) (genCode (Dst D) (list 'inc Dst) ((op.n Dst D)) "Result = ++@1;" ) ) (asm dec (Dst D) (genCode (Dst D) (list 'dec Dst) ((op.n Dst D)) "Result = --@1;" ) ) (asm not (Dst D) (genCode (Dst D) (list 'not Dst) ((op.n Dst D)) "Result = @1 = ~@1;" ) ) (asm neg (Dst D) (genCode (Dst D) (list 'neg Dst) ((op.n Dst D)) "Result = @1 = -@1;" ) ) (asm and (Dst D Src S) (genCode (Dst D Src S) (list 'and Dst Src) ((op.n Dst D) (op.n Src S)) "Result = @1 &= @2;" ) ) (asm or (Dst D Src S) (genCode (Dst D Src S) (list 'or Dst Src) ((op.n Dst D) (op.n Src S)) "Result = @1 |= @2;" ) ) (asm xor (Dst D Src S) (genCode (Dst D Src S) (list 'xor Dst Src) ((op.n Dst D) (op.n Src S)) "Result = @1 \^= @2;" ) ) (asm off (Dst D Src S) (genCode (Dst D Src S) (list 'off Dst (pack (cdr (chop Src)))) ((op.n Dst D) (op.n Src S)) "Result = @1 &= @2;" ) ) (asm test (Dst D Src S) (genCode (Dst D Src S) (list 'test Dst Src) ((op.n Dst D) (op.n Src S)) "Result = @1 & @2;" ) ) (asm shl (Dst D Src S) (genCode (Dst D Src S) (list 'shl Dst Src) ((op.n Dst D) (op.n Src S)) "Carry = @1 >> 64 - @2 & 1;" "Result = @1 <<= @2;" ) ) (asm shr (Dst D Src S) (genCode (Dst D Src S) (list 'shr Dst Src) ((op.n Dst D) (op.n Src S)) "Carry = @1 >> @2 - 1 & 1;" "Result = @1 >>= @2;" ) ) (asm rol (Dst D Src S) (if (=0 S) (genCode (Dst D Src) (list 'rol Dst Src) ((op.n Dst D) Src) "@1 = @1 << @2 | @1 >> (64 - @2);" ) (genCode (Dst D Src S) (list 'rol Dst Src) ((op.n Dst D) (op.i Src S)) "i = @2, @1 = @1 << i | @1 >> (64 - i);" ) ) ) (asm ror (Dst D Src S) (if (=0 S) (genCode (Dst D Src) (list 'ror Dst Src) ((op.n Dst D) Src) "@1 = @1 >> @2 | @1 << (64 - @2);" ) (genCode (Dst D Src S) (list 'ror Dst Src) ((op.n Dst D) (op.i Src S)) "i = @2, @1 = @1 >> i | @1 << (64 - i);" ) ) ) (asm rcl (Dst D Src S) (genCode (Dst D Src S) (list 'rcl Dst Src) ((op.n Dst D) (op.i Src S)) "@1 = @1 << @2 | @1 >> (64 - @2);" "i = @1 & 1, @1 = @1 & ~1 | Carry, Carry = i;" ) ) (asm rcr (Dst D Src S) (genCode (Dst D Src S) (list 'rcr Dst Src) ((op.n Dst D) (op.i Src S)) "i = @1 & 1, @1 = @1 & ~1 | Carry, Carry = i;" "@1 = @1 >> @2 | @1 << (64 - @2);" ) ) (asm mul (Src S) (genCode (Src S) (list 'mul Src) ((op.n Src S)) "mul2(@1);" ) ) (asm div (Src S) (genCode (Src S) (list 'div Src) ((op.n Src S)) "div2(@1);" ) ) (asm zxt () # 8 bit -> 64 bit (genCode NIL '(zxt) NIL "A.n &= 0xFF;" ) ) (asm setz () (genCode NIL '(setz) NIL "Carry = 0, Result = 0;" ) ) (asm clrz () (genCode NIL '(clrz) NIL "Result = 1;" ) ) (asm setc () (genCode NIL '(setc) NIL "Carry = 1;" ) ) (asm clrc () (genCode NIL '(clrc) NIL "Carry = 0;" ) ) # Comparisons (asm cmp (Dst D Src S) (cond ((or (= Dst "A.b[0]") (= Src "A.b[0]")) (genCode (Dst D Src S) (list 'cmp Dst Src) ((op.b Dst D) (op.b Src S)) "Carry = (Result = @1 - @2) > MAX64 - @2;" ) ) ((and (= Dst "S") (= Src '(StkLimit))) (genCode (Dst D Src S) (list 'cmp Dst Src) ((op.n Dst D) (op.n Src S)) "if (S.p < Stack + 4064)" " emuStkErr();" "Carry = (Result = @1 - @2) > MAX64 - @2;" ) ) (T (genCode (Dst D Src S) (list 'cmp Dst Src) ((op.n Dst D) (op.n Src S)) "Carry = (Result = @1 - @2) > MAX64 - @2;" ) ) ) ) (asm cmpn (Dst D Src S Cnt C) (genCode (Dst D Src S Cnt C) (list 'cmpn Dst Src Cnt) ((op.a Dst D) (op.a Src S) (op.i Cnt C)) "Result = (uint64_t)memcmp(@1, @2, @3);" ) ) (asm slen (Dst D Src S) (genCode (Dst D Src S) (list 'slen Dst Src) ((op.n Dst D) (op.a Src S)) "@1 = (uint64_t)strlen(@2);" ) ) (asm memb (Src S Cnt C) (if S (genCode (Src S Cnt C) (list 'memb Src Cnt) ((op.a Src S) (op.i Cnt C)) "Result = !(uint64_t)(unsigned long)memchr(@1, (int)A.b[0], @2);" ) (genCode (Src S Cnt C) (list 'memb Src Cnt) ((op.a Src S) (op.i Cnt C) Cnt) "if (!(Result = !(tmp.p = (uint8_t*)memchr(@1, (int)A.b[0], @2))))" " @3.n -= tmp.p - @1 + 1, @1 = tmp.p + 1;" ) ) ) (asm null (Src S) (genCode (Src S) (list 'null Src) ((op.n Src S)) "Carry = 0, Result = @1;" ) ) (asm nulp (Src S) (genCode (Src S) (list 'nulp Src) ((op.i Src S)) "Result = @1;" ) ) (asm nul4 () (genCode NIL '(nul4) NIL "Carry = 0, Result = (int32_t)A.l;" ) ) # Byte addressing (asm set (Dst D Src S) (genCode (Dst D Src S) (list 'set Dst Src) ((op.b Dst D) (op.b Src S)) "@1 = @2;" ) ) (asm nul (Src S) (genCode (Src S) (list 'nul Src) ((op.b Src S)) "Carry = 0, Result = @1;" ) ) # Types (asm cnt (Src S) (genCode (Src S) (list 'cnt Src) ((op.b Src S)) "Result = @1 & 2;" ) ) (asm big (Src S) (genCode (Src S) (list 'big Src) ((op.b Src S)) "Result = @1 & 4;" ) ) (asm num (Src S) (genCode (Src S) (list 'num Src) ((op.b Src S)) "Result = @1 & 6;" ) ) (asm sym (Src S) (genCode (Src S) (list 'sym Src) ((op.b Src S)) "Result = @1 & 8;" ) ) (asm atom (Src S) (genCode (Src S) (list 'atom Src) ((op.b Src S)) "Result = @1 & 14;" ) ) # Flow Control (de localAddr (Adr) (or (pre? "." Adr) # Local label ".1" (and (cdr (setq Adr (split (chop Adr) "_"))) # Local jump "foo_22" (= *Label (pack (glue "_" (head -1 Adr)))) (format (last Adr)) ) ) ) (asm call (Adr A) (nond (A # Absolute (cond ((baseCode Adr) (genCode (Adr) (list 'call Adr) ((baseCode Adr)) "S.p -= 8, *(uint16_t**)S.p = PC;" "PC = Code + @1;" ) ) (*FPic (genCode (Adr) (list 'call Adr) ((absCode Adr)) "S.p -= 8, *(uint16_t**)S.p = PC;" "PC = LibCode + @1;" ) ) (T (genCode (Adr) (list 'call Adr) ((absCode Adr)) "S.p -= 8, *(uint16_t**)S.p = PC;" "PC = Code + @1;" ) ) ) ) ((=T A) # Indexed: Ignore SUBR (genCode (Adr A) (list 'call (list Adr)) (Adr) "S.p -= 8, *(uint16_t**)S.p = PC;" "PC = (uint16_t*)@1.p;" ) ) (NIL # Indirect (genCode (Adr A) (list 'call (list Adr)) ((op.p Adr A)) "S.p -= 8, *(uint16_t**)S.p = PC;" "PC = *(uint16_t**)@1;" ) ) ) ) (asm jmp (Adr A) (nond (A # Absolute (cond ((localAddr Adr) (genCode (Adr) (list 'jmp (relCode Adr)) ((relCode Adr)) "PC += @1;" ) ) ((baseCode Adr) (genCode (Adr) (list 'jmp Adr) ((baseCode Adr)) "PC = Code + @1;" ) ) (*FPic (genCode (Adr) (list 'jmp Adr) ((absCode Adr)) "PC = LibCode + @1;" ) ) (T (genCode (Adr) (list 'jmp Adr) ((absCode Adr)) "PC = Code + @1;" ) ) ) ) ((=T A) # Indexed: Ignore SUBR (genCode (Adr A) (list 'jmp (list Adr)) (Adr) "PC = (uint16_t*)@1.p;" ) ) (NIL # Indirect (genCode (Adr A) (list 'jmp (list Adr)) ((op.p Adr A)) "PC = *(uint16_t**)@1;" ) ) ) ) (de _jmp (Opc Test) (nond (A # Absolute (cond ((localAddr Adr) (genCode (Adr Opc Test) (list Opc (relCode Adr)) ((relCode Adr) Test) "if (@2)" " PC += @1;" ) ) ((baseCode Adr) (genCode (Adr Opc Test) (list Opc Adr) ((baseCode Adr) Test) "if (@2)" " PC = Code + @1;") ) (*FPic (genCode (Adr Opc Test) (list Opc Adr) ((absCode Adr) Test) "if (@2)" " PC = LibCode + @1;") ) (T (genCode (Adr Opc Test) (list Opc Adr) ((absCode Adr) Test) "if (@2)" " PC = Code + @1;") ) ) ) ((=T A) # Indexed: Ignore SUBR (genCode (Adr Opc Test) (list Opc Adr) (Adr Test) "if (@2)" " PC = (uint16_t*)@1.p;" ) ) (NIL # Indirect (genCode (Adr A Opc Test) (list Opc (list Adr)) ((op.p Adr A) Test) "if (@2)" " PC = (uint16_t**)@1;" ) ) ) ) (asm jz (Adr A) (_jmp "jz" "!Result") ) (asm jeq (Adr A) (_jmp "jz" "!Result") ) (asm jnz (Adr A) (_jmp "jnz" "Result") ) (asm jne (Adr A) (_jmp "jnz" "Result") ) (asm js (Adr A) (_jmp "js" "(int64_t)Result < 0") ) (asm jns (Adr A) (_jmp "jns" "(int64_t)Result >= 0") ) (asm jsz (Adr A) (_jmp "jsz" "(int64_t)Result <= 0") ) (asm jnsz (Adr A) (_jmp "jnsz" "(int64_t)Result > 0") ) (asm jc (Adr A) (_jmp "jc" "Carry") ) (asm jlt (Adr A) (_jmp "jc" "Carry") ) (asm jnc (Adr A) (_jmp "jnc" "!Carry") ) (asm jge (Adr A) (_jmp "jnc" "!Carry") ) (asm jcz (Adr A) (_jmp "jcz" "!Result || Carry") ) (asm jle (Adr A) (_jmp "jcz" "!Result || Carry") ) (asm jncz (Adr A) (_jmp "jncz" "Result && !Carry") ) (asm jgt (Adr A) (_jmp "jncz" "Result && !Carry") ) (asm ret () (genCode NIL '(ret) NIL "PC = *(uint16_t**)S.p, S.p += 8;" ) ) # Floating point (asm ldd () (genCode NIL '(ldd) NIL "A.d = *(double*)C.p;" ) ) (asm ldf () (genCode NIL '(ldf) NIL "A.f = *(float*)C.p;" ) ) (asm fixnum () (genCode NIL '(fixnum) ((directExpr "TSym") (directExpr "Nil")) "if (E.b[0] & 8)" " A.d = A.f * (float)(E.n >> 4);" "else" " A.d = A.d * (double)(E.n >> 4);" "if (isinf(A.d) == 1 || A.d > (double)0xFFFFFFFFFFFFFFFLL)" " E.p = @1;" "else if (isnan(A.d) || isinf(A.d) == -1 || A.d < (double)-0xFFFFFFFFFFFFFFFLL)" " E.p = @2;" "else if (A.d >= 0)" " E.n = (uint64_t)(A.d + 0.5) << 4 | 2;" "else" " E.n = (uint64_t)(0.5 - A.d) << 4 | 10;" ) ) (asm float () (genCode NIL '(float) ((directExpr "Nil")) "if (A.b[0] & 8) {" " if (((ptr)X.p)->n & 2) {" " tmp.f = (float)(((ptr)X.p)->n >> 4) / (float)(A.n >> 4);" " if (((ptr)X.p)->n & 8)" " tmp.f = -tmp.f;" " }" " else" " tmp.f = X.p == @1? -INFINITY : INFINITY;" "}" "else {" " if (((ptr)X.p)->n & 2) {" " tmp.d = (double)(((ptr)X.p)->n >> 4) / (double)(A.n >> 4);" " if (((ptr)X.p)->n & 8)" " tmp.d = -tmp.d;" " }" " else" " tmp.d = X.p == @1? -INFINITY : INFINITY;" "}" ) ) (asm std () (genCode NIL '(std) NIL "*(double*)Z.p = tmp.d;" ) ) (asm stf () (genCode NIL '(stf) NIL "*(float*)Z.p = tmp.f;" ) ) # C-Calls (de *C-Params # Function return value and parameters (getpid i) (getenv p p) (setenv i p p i) (isatty i i) (tcgetattr i i "struct termios") (tcsetattr i i i "struct termios") (tcsetpgrp - i i) (signal p i f) (sigfillset - "sigset_t") (sigemptyset - "sigset_t") (sigaddset - "sigset_t" i) (sigprocmask - i "sigset_t" "sigset_t") (sigaction - i "struct sigaction" "struct sigaction") (gettimeofday - -2 "struct timezone") (malloc p i) (realloc p p i) (fork i) (getpgrp i) (setpgid - i i) (execvp i p 0) (kill i i i) (raise - i) (alarm i i) (waitpid i i "int" i) (free - p) (stat i p "struct stat") (lstat i p "struct stat") (fcntl i i i p) (pipe i "int") (select i i "fd_set" "fd_set" "fd_set" (2 . -2)) (open i p i i) (dup i i) (dup2 - i i) (read n i p i) (write n i p i) (lseek n i n i) (pread n i p i n) (pwrite n i p i n) (close i i) (fopen p p p) (freopen p p p p) (getc_unlocked i "FILE") (putc_unlocked - i "FILE") (fread i p i i "FILE") (fwrite i p i i "FILE") (fileno i "FILE") (fseek i "FILE" n i) (ftruncate i i n) (fflush - "FILE") (fsync i i) (feof i "FILE") (fclose - "FILE") (socket i i i i) (setsockopt i i i i p i) (htons i i) (ntohs i i) (inet_ntop - i p p i) (bind i i "struct sockaddr" i) (listen i i i) (getsockname i i "struct sockaddr" "socklen_t") (getaddrinfo i p p "struct addrinfo" "struct addrinfo") (getnameinfo i "struct sockaddr" i p i p i i) (freeaddrinfo - "struct addrinfo") (accept i i "struct sockaddr" "socklen_t") (connect i i "struct sockaddr" i) (recv i i p i i) (sendto - i p i i "struct sockaddr" i) (strdup p p) (dlopen p p i) (dlsym p "void" p) (getcwd p p) (chdir i p) (opendir p p) (readdir p "DIR") (closedir - "DIR") (time - "time_t") (times - "struct tms") (usleep - i) (gmtime p "time_t") (localtime p "time_t") (printf - p) (fprintf - "FILE" p) (snprintf - p i p p) (strerror p i) (dlerror p) (exit - i) # src64/sys/emu.code.l (errno_A -) (errnoC -) (wifstoppedS_F -) (wifsignaledS_F -) (wtermsigS_A n) ) (de ccArg (P S O P2) (and (pair P) (setq P (car @))) (and (pair P2) (setq P2 (car @))) (case P (p (op.p S O)) (n (op.n S O)) (i (op.i S O)) (f (sysFun S O)) (lea (pack (and P2 (n== 'p P2) (if (num? P2) "(void*)" (pack "(" P2 "*)") ) ) (op.a S O) ) ) (T (nond (P (op.i S O)) ((num? P) (pack "(" P "*)" (op.p S O))) ((ge0 P) (pack "(void*)" (op.p S O))) (NIL (pack "argv(" @ ", (ptr)" (op.p S O) ")")) ) ) ) ) (de _genCC Body (addCode (cons (env '(Adr A Arg M Par)) '(list 'cc Adr Arg) (list 'Adr (list 'glue ", " Args) (list 'extract ''((A P) (when (lt0 (fin P)) (pack " retv(" (abs @) "," (if (pre? "argv(" A) (member " " (chop A)) (pack " " A ")") ) ";" ) ) ) Args '(cdr Par) ) ) Body ) ) ) (de _natCC (I N Typ Arg) (if (=0 N) (link (pack (need (inc I) " ") (case (car (setq Typ (reverse Typ))) (float "A.f = (*(float") (double "A.d = (*(double") (T "A.n = (*(uint64_t") ) " (*)(" (glue "," Typ) "))@1.p)(" (glue ", " (reverse Arg)) ");" ) ) (let N (dec N) (link (pack (need (inc I) " ") "if (((ptr)(S.p + " (* 16 I) "))->n == 0)" ) ) (_natCC (inc I) N (cons 'long Typ) (cons (pack "((ptr)(S.p + " (+ 8 (* 16 I)) "))->n") Arg ) ) (link (pack (need (inc I) " ") "else if (((ptr)(S.p + " (* 16 I) "))->n & 8)" ) ) (_natCC (inc I) N (cons 'float Typ) (cons (pack "(float)dbl(" (* 16 I) ")") Arg ) ) (link (pack (need (inc I) " ") "else")) (_natCC (inc I) N (cons 'double Typ) (cons (pack "dbl(" (* 16 I) ")") Arg ) ) ) ) ) (asm cc (Adr A Arg M) (if (lst? Arg) (let (Par (cdr (assoc Adr *C-Params)) Args '(let (P (cdr Par) Lea) (mapcan '((S O) (cond ((== '& S) (on Lea)) ((== 'pop S) (cons (pack "(S.p += 8, " (ccArg (pop 'P) '("S" . -8) '(NIL . 0)) ")" ) ) ) (Lea (off Lea) (cons (ccArg 'lea S O (pop 'P))) ) (T (cons (ccArg (pop 'P) S O))) ) ) Arg M ) ) ) (case (car Par) (- (_genCC "@1(@2);@3")) (p (_genCC "A.n = (uint64_t)(uintptr_t)(uint8_t*)@1(@2);@3")) (n (_genCC "A.n = (uint64_t)@1(@2);@3")) (i (_genCC "A.n = (uint64_t)(uint32_t)@1(@2);@3")) (T (quit "Unknown C function" Adr)) ) ) (addCode (cons (env '(Adr Arg)) '(list 'cc (list Adr) Arg) '(Adr Arg) (make (link "if ((tmp.p = S.p) == @2.p)") (_natCC 0 0) (for N 6 (link "else if ((tmp.p += 16) == @2.p) {") (_natCC 0 N) (link "}") ) (link "else" " A.n = (*(uint64_t (*)(long,long,long,long,long,long,long,long))Y.p)(((ptr)(S.p + 8))->n, ((ptr)(S.p + 24))->n, ((ptr)(S.p + 40))->n, ((ptr)(S.p + 56))->n, ((ptr)(S.p + 72))->n, ((ptr)(S.p + 88))->n, ((ptr)(S.p + 104))->n, ((ptr)(S.p + 120))->n);" ) ) ) ) ) ) (asm func () (genCode NIL '(func) ((directExpr "cbl1")) "E.n = (uint64_t)(unsigned long)(void(*)())cbl[(E.p-@1)/2];" ) ) (asm begin ()) (asm return () (genCode NIL '(return) NIL "return;" ) ) # Terminate 'run' # Stack Manipulations (asm push (Src S) (cond ((=T Src) (genCode NIL '(push F) NIL "S.p -= 8, ((ptr)S.p)->n = (Result & ~1) | (Result & 0xFFFFFFFF) << 1 | Carry;" ) ) ((= "S" Src) (genCode (Src S) '(push S) NIL "tmp.n = S.n, S.p -= 8, ((ptr)S.p)->n = tmp.n;" ) ) (T (genCode (Src S) (list 'push Src) ((op.n Src S)) "S.p -= 8, ((ptr)S.p)->n = @1;" ) ) ) ) (asm pop (Dst D) (if (=T Dst) (genCode NIL '(pop F) NIL "Carry = ((ptr)S.p)->n & 1, Result = ((ptr)S.p)->n & ~1, S.p += 8;" ) (genCode (Dst D) (list 'pop Dst) ((op.n Dst D)) "@1 = ((ptr)S.p)->n, S.p += 8;" ) ) ) (asm link () (genCode NIL '(link) NIL "S.p -= 8, ((ptr)S.p)->n = L.n, L.p = S.p;" ) ) (asm tuck (Src S) (genCode (Src S) (list 'tuck Src) ((op.n Src S)) "L.p = ((ptr)S.p)->p, ((ptr)S.p)->n = @1;" ) ) (asm drop () (genCode NIL '(drop) NIL "S.p = ((ptr)L.p)->p, L.p = ((ptr)S.p)->p, S.p += 8;" ) ) # Evaluation (asm eval () (genCode NIL '(eval) ((absCode "evListE_E")) "if (!(E.b[0] & 6))" " if (E.b[0] & 8)" " E = *(ptr)E.p;" " else {" " S.p -= 8, *(uint16_t**)S.p = PC;" " PC = Code + @1;" " }" ) ) (asm eval+ () (genCode NIL '(eval+) ((absCode "evListE_E")) "if (!(E.b[0] & 6))" " if (E.b[0] & 8)" " E = *(ptr)E.p;" " else {" " S.p -= 8, ((ptr)S.p)->n = L.n, L.p = S.p;" " S.p -= 8, *(uint16_t**)S.p = PC;" " S.p -= 8, *(uint16_t**)S.p = Code + 0;" # " PC = Code + @1;" " }" ) ) (asm eval/ret () (genCode NIL '(eval/ret) ((absCode "evListE_E")) "if (E.b[0] & 14) {" " if (!(E.b[0] & 6))" " E = *(ptr)E.p;" " PC = *(uint16_t**)S.p, S.p += 8;" "}" "else" " PC = Code + @1;" ) ) (asm exec (Reg) (let Ofs (case Reg (X 1) (Y 2) (Z 3)) (unless *FPic (con (cdddr (caar (tail (inc Ofs) *AsmCode))) (cons (text "goto exec@1;" Reg)) ) ) (genCode (Reg Ofs) (list 'exec Reg) ((absCode "evListE_E") Reg Ofs) "do {" " E = *(ptr)@2.p;" " if (!(E.b[0] & 14)) {" " S.p -= 8, *(uint16_t**)S.p = PC;" " S.p -= 8, *(uint16_t**)S.p = Code + 1;" # " PC = Code + @1;" " break;" " }" "exec@2:" " @2.p = ((ptr)(@2.p + 8))->p;" "} while (!(@2.b[0] & 14));" ) ) ) (asm prog (Reg) (let Ofs (case Reg (X 4) (Y 5) (Z 6)) (unless *FPic (con (cdddr (caar (tail (inc Ofs) *AsmCode))) (cons (text "goto prog@1;" Reg)) ) ) (genCode (Reg Ofs) (list 'prog Reg) ((absCode "evListE_E") Reg Ofs) "do {" " E = *(ptr)@2.p;" " if (!(E.b[0] & 6)) {" " if (E.b[0] & 8)" " E = *(ptr)E.p;" " else {" " S.p -= 8, *(uint16_t**)S.p = PC;" " S.p -= 8, *(uint16_t**)S.p = Code + @3;" # " PC = Code + @1;" " break;" " }" " }" "prog@2:" " @2.p = ((ptr)(@2.p + 8))->p;" "} while (!(@2.b[0] & 14));" ) ) ) # System (asm initData ()) (asm initCode ()) (asm initMain ()) # Done explicitly in 'main' (asm initLib () (genCode NIL '(initLib) NIL "A.n = (uint64_t)(unsigned long)*(uint8_t**)A.p;" ) ) ### Optimizer ### # Replace the the next 'cnt' elements with 'lst' (de optimize (Lst)) #> (cnt . lst) ### Decoration ### (de prolog (File) (if *FPic (in "emu.symtab" (setq *BaseData (read) *BaseCode (read) *BaseOpcodes (make (while (read) (chain @))) *OpOffs (length *BaseOpcodes) ) ) (genCode NIL '() NIL # Code + 0 "PC = *(uint16_t**)S.p, S.p += 8;" "L.p = ((ptr)S.p)->p, S.p += 8;" ) (genCode NIL '() NIL # Code + 1 "PC = *(uint16_t**)S.p, S.p += 8;" ) (genCode NIL '() NIL # Code + 2 "PC = *(uint16_t**)S.p, S.p += 8;" ) (genCode NIL '() NIL # Code + 3 "PC = *(uint16_t**)S.p, S.p += 8;" ) (genCode NIL '() NIL # Code + 4 "PC = *(uint16_t**)S.p, S.p += 8;" ) (genCode NIL '() NIL # Code + 5 "PC = *(uint16_t**)S.p, S.p += 8;" ) (genCode NIL '() NIL # Code + 6 "PC = *(uint16_t**)S.p, S.p += 8;" ) ) (mapc prinl (quote NIL "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " "#include " NIL "#define MAX8 ((uint8_t)-1)" "#define MAX64 ((uint64_t)-1)" "#define STACK (8 * 1024 * 1024)" NIL "typedef union op {" " uint64_t n;" ) ) (if (or *LittleEndian *Bits64) (prinl " uint8_t *p;") (mapc prinl (quote " struct {" " uint32_t u;" " uint8_t *p;" " };" ) ) ) (prinl " uint8_t b[8];") (if *LittleEndian (prinl " struct {uint32_t l, h;};") (prinl " struct {uint32_t h, l;};") ) (prinl " float f;") (prinl " double d;") (prinl "} op, *ptr;") (prinl) (mapc prinl (if *FPic (quote "extern uint16_t Code[];" "static uint16_t LibCode[];" NIL "extern uint16_t *PC;" "extern uint8_t *Stack;" "extern op A, C, E, X, Y, Z, L, S;" "extern uint64_t Result;" "extern int Carry;" "extern void mul2(uint64_t);" "extern void div2(uint64_t);" "extern uint64_t begin(int,long,long,long,long,long,long);" "extern void *argv(int,ptr);" "extern void retv(int,ptr);" NIL "extern op Data[];" NIL "static op LibData[] = {" ) (quote "uint16_t Code[];" NIL "uint16_t *PC;" "uint8_t *Stack;" "op A, C, E, X, Y, Z, L, S;" "uint64_t Result;" "int Carry;" NIL "void emuStkErr(void) {" " fprintf(stderr, \"Emulator stack error\\n\");" " exit(-99);" "}" NIL "static void run(int);" NIL "void mul2(uint64_t src) {" " uint32_t h = src >> 32;" " uint32_t l = (uint32_t)src;" " op a, b;" NIL " a.n = (uint64_t)A.l * l;" " b.n = (uint64_t)A.h * l;" " C.n = (uint64_t)b.h + ((a.h += b.l) < b.l);" " b.n = (uint64_t)A.l * h;" " C.n += (uint64_t)b.h + ((a.h += b.l) < b.l);" " C.n += (uint64_t)A.h * h;" " A.n = a.n;" "}" NIL "void div2(uint64_t src) {" " uint64_t vn0, vn1, q1, q0, rhat;" " int s;" NIL " if (C.n >= src)" " A.n = C.n = MAX64;" # Overflow " else {" " s = 0;" " while ((int64_t)src > 0) {" # Normalize " C.n = (C.n << 1) + ((int64_t)A.n < 0);" # Shift dividend left " A.n <<= 1;" " src <<= 1;" # and divisor " ++s;" " }" " vn1 = src >> 32;" # Split divisor into high " vn0 = (uint32_t)src;" # and low 32 bits " q1 = C.n / vn1;" # First quotient digit " rhat = C.n - q1 * vn1;" NIL " while (q1 >> 32 || q1 * vn0 > (rhat << 32) + A.h) {" " --q1;" " if ((rhat += vn1) >> 32)" " break;" " }" " C.n = (C.n << 32) + A.h - q1 * src;" " q0 = C.n / vn1;" # Second quotient digit " rhat = C.n - q0 * vn1;" NIL " while (q0 >> 32 || q0 * vn0 > (rhat << 32) + A.l) {" " --q0;" " if ((rhat += vn1) >> 32)" " break;" " }" " C.n = ((C.n << 32) + A.l - q0 * src) >> s;" # Remainder " A.n = (q1 << 32) + q0;" # Quotient " }" "}" NIL "uint64_t begin(int i, long a, long c, long e, long x, long y, long z) {" " uint64_t res;" NIL " S.p -= 8, *(uint16_t**)S.p = PC;" " S.p -= 8, ((ptr)S.p)->l = Carry;" " S.p -= 8, ((ptr)S.p)->n = Result;" " S.p -= 8, *(ptr)S.p = Z, Z.n = z;" " S.p -= 8, *(ptr)S.p = Y, Y.n = y;" " S.p -= 8, *(ptr)S.p = X, X.n = x;" " S.p -= 8, *(ptr)S.p = E, E.n = e;" " S.p -= 8, *(ptr)S.p = C, C.n = c;" " S.p -= 8, *(ptr)S.p = A, A.n = a;" " run(i);" " res = A.n;" " A = *(ptr)S.p, S.p += 8;" " C = *(ptr)S.p, S.p += 8;" " E = *(ptr)S.p, S.p += 8;" " X = *(ptr)S.p, S.p += 8;" " Y = *(ptr)S.p, S.p += 8;" " Z = *(ptr)S.p, S.p += 8;" " Result = ((ptr)S.p)->n, S.p += 8;" " Carry = ((ptr)S.p)->l, S.p += 8;" " PC = *(uint16_t**)S.p, S.p += 8;" " return res;" "}" NIL "void *argv(int i, ptr p) {" " if (p) {" " if (i == 0)" " while (((uint8_t**)p)[i] = p[i].p)" " ++i;" " else" " while (--i >= 0)" " ((uint8_t**)p)[i] = p[i].p;" " }" " return p;" "}" NIL "void retv(int i, ptr p) {" " if (p)" " while (--i >= 0)" " p[i].n = (uint64_t)(unsigned long)((uint8_t**)p)[i];" "}" NIL "op Data[] = {" ) ) ) ) (de prOpcode (I X) (prinl (align 7 X) ", // " (align 7 (dec I)) ": " (if (=0 X) "nop" (fmtInstruction (or (get *BaseOpcodes X) (get *AsmOpcodes (- X *OpOffs) 1) ) ) ) ) ) (de epilog (File) (setq *AsmData (flip *AsmData) *AsmCode (flip *AsmCode) ) (let *AsmPos 0 (for X *AsmCode (set X (job (env (caar X)) (opcode (eval (cadar X)) (mapcar eval (caddar X)) (cdddar X) ) ) ) (inc '*AsmPos) ) ) (let Bytes NIL (for D *AsmData (prin " /* " (align -10 (car D)) (align 5 (cadr D)) " */" ) (and Bytes (cddr D) (space 8)) (for (I . X) (cddr D) (cond ((pair X) (and Bytes (quit "Unaligned word" (car D))) (prin " {.n = " (car X) "},") ) ((sym? X) (and Bytes (quit "Unaligned word" (car D))) (cond ((pre? ".+" X) (let N (+ (cadr D) (format (cddr (chop X)))) (for ((J . L) (cddr D) (> I J) (cdr L)) (NIL (> I J)) # Temporary (03oct12abu) (inc 'N (if (num? (car L)) 1 8)) ) (prin " {.p = (uint8_t*)" (and *FPic "Lib") "Data+" N "}," ) ) ) ((asoq X *AsmData) (let N @ (prin " {.p = (uint8_t*)" (and *FPic "Lib") "Data+" (cadr N) "}," ) ) ) ((absCode X) (let N @ (prin " {.p = (uint8_t*)(" (and *FPic "Lib") "Code+" N ")}," ) ) ) (T (quit "No value" X)) ) ) (Bytes (prin (and (> I 1) ", ") X) (when (= 8 (inc 'Bytes)) (prin "}},") (off Bytes) ) ) (T (prin " {.b = {" X) (one Bytes) ) ) ) (and Bytes (cddr D) (prin ",")) (prinl) ) (when Bytes (space 26) (prinl "}}") ) ) (prinl "};") (prinl) (unless *FPic (for I 24 (sysFun (pack "cbl" I) T) ) ) (when *SysFun (mapc prinl (flip @)) (prinl) ) (unless *FPic (prinl "static void (*cbl[])() = {" (glue "," (make (for I 24 (link (pack "fun" (absCode (pack "cbl" I)))) ) ) ) "};" ) (prinl) (prinl "long lisp(char *p, long a, long b, long c, long d, long e) {") (prinl " return (long)begin(" (absCode "lisp") ", (long)p, a, b, c, d, e);") (prinl "}") (prinl) ) (prinl (and *FPic "static ") "uint16_t " (and *FPic "Lib") "Code[] = {" ) (for (I . X) *AsmCode (for C (cdr X) (unless (pre? "." C) # Omit local labels (prinl " // " C ":") ) ) (prOpcode I (car X)) ) (prinl "};") (prinl) (when *FPic (for S (by val sort (idx '*Labels)) (unless (pre? "." S) # Omit local labels (prinl "uint16_t *" S " = LibCode + " (val S) ";") ) ) (prinl) ) (if *FPic (mapc prinl (quote "extern void (*FirstLib)(void);" "static void (*NextLib)(void);" NIL "static void opcodes(void) {" " op i, tmp;" NIL " switch (PC[-1]) {" ) ) (mapc prinl (quote "double dbl(int i) {" " uint64_t s = ((ptr)(S.p + i))->n;" NIL " if (s & 2) {" " uint64_t m = ((ptr)(S.p + i + 8))->n;" " double d = (double)(m >> 4) / (double)(s >> 4);" " return m & 8? -d : d;" " }" ) ) (prinl " return ((ptr)(S.p + i))->p == " (directExpr "Nil") "? -INFINITY : INFINITY;" ) (mapc prinl (quote "}" NIL "void (*FirstLib)(void);" NIL "static void run(int i) {" " op tmp;" NIL " PC = Code + i;" " for (;;) {" " switch (*PC++) {" " case 0: // nop" " break;" ) ) ) (for (C . L) *AsmOpcodes (prinl (unless *FPic " ") " case " (+ *OpOffs C) ": // " (fmtInstruction (car L)) ) (for S (cdr L) (prinl (unless *FPic " ") " " S ) ) (prinl (unless *FPic " ") " break;" ) ) (prinl (unless *FPic " ") " default:" ) (if *FPic (mapc prinl (quote " if (NextLib)" " (*NextLib)();" ) ) (mapc prinl (quote " if (FirstLib)" " (*FirstLib)();" ) ) ) (for S (quote " else {" " fprintf(stderr, \"Bad instruction\\n\");" " exit(112);" " }" " }" ~(as (and *Dbg (not *FPic)) " fprintf(stderr, \" %llX %llX %llX %llX %llX %llX %d%d%d %llX %llX\\n\"," " A.n, C.n, E.n, X.n, Y.n, Z.n," " !Result, (int64_t)Result<0, Carry," " L.n, S.n );" ) ) (prinl (unless *FPic " ") S ) ) (unless *FPic (prinl " }")) (prinl "}") (when *FPic (mapc prinl (quote NIL "static void __attribute__((constructor)) linkOpcodes(void) {" " NextLib = FirstLib, FirstLib = opcodes;" "}" ) ) ) (unless *FPic (mapc prinl (quote NIL "int main(int ac, char *av[]) {" " int i;" NIL " Y.p = malloc((ac + 1) * sizeof(op));" " i = 0; do" " ((ptr)Y.p)[i].n = (uint64_t)(unsigned long)av[i];" " while (++i < ac);" " ((ptr)Y.p)[i].n = 0;" " X.p = ((ptr)Y.p)->p, Y.p += 8;" " Z.p = Y.p + (ac - 2) * sizeof(op);" " if ((Stack = malloc(STACK)) == NULL)" " emuStkErr();" " S.p = Stack + STACK;" ) ) (prinl (pack " run(" (absCode "main") ");")) (prinl " return 0;") (prinl "}") ) (if *FPic (out "+emu.symtab" (println (mapcar car *AsmOpcodes)) ) (out "emu.symtab" (println (mapcar '((D) (cons (car D) (cadr D))) *AsmData ) ) (println (make (for (I . X) *AsmCode (for Lbl (cdr X) (unless (pre? "." Lbl) (link (cons Lbl (dec I))) ) ) ) ) ) (println (mapcar car *AsmOpcodes)) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/arch/ppc64.l0000644000000000000000000013773112265263724016153 0ustar rootroot# 05jan13abu # (c) Software Lab. Alexander Burger # Byte order (off *LittleEndian) (on *AlignedCode) # Register assignments (de *Registers (A . 3) (C . 14) (E . 15) (B . -3) (D 3 . 14) (X . 16) (Y . 17) (Z . 18) (L . 19) (S . 1) (F . T) ) (de *TempRegs 27 28 29 30 ) # TOC: 2 # C arguments: 3 - 10 # NULL: 20 # ONE: 21 # Data: 22 # Code: 23 # DllToc: 24 # Nil: 25 # Reserved: 26 # Carry flag: 31 # Temporary register (de tmpReg @ (let R (pop '(`(apply circ *TempRegs))) (if (find lt0 (rest)) (- R) R ) ) ) # Machine specific (zero *DataPos *CodePos) (off *DataLabels *CodeLabels *DataIndex *CodeIndex) (redef label (Lbl Flg) (ifn *FPic (cond ((== *Section 'data) (push '*DataLabels (cons Lbl *DataPos)) ) ((== *Section 'text) (unless (pre? "." Lbl) (push '*CodeLabels (cons Lbl *CodePos)) ) ) ) (when (and Flg (== *Section 'text) (n0 *CodePos) (upp? Lbl)) (prinst ".quad" ".TOC.@tocbase") ) ) (label Lbl Flg) (when (and *FPic Flg (== *Section 'text) (n0 *CodePos) (upp? Lbl)) (prinst "mfctr" 11) (prinst "subi" 11 11 2) (prinst "ld" 24 "-8(11)") ) ) (de asciiLen (Str) (- (size (pack (replace (chop Str) "\\"))) 2) ) # Don't count double quotes (redef prinst (Name . @) (pass prinst Name) (cond ((== *Section 'data) (inc '*DataPos (case Name (".balign" (if (gt0 (% *DataPos (next))) (- (arg) @) 0 ) ) (".quad" 8) (".byte" (if (num? (next)) 1 (length (split (chop (arg)) ",")) ) ) (".short" (if (num? (next)) 2 (* 2 (length (split (chop (arg)) ","))) ) ) (".space" (next)) (".ascii" (asciiLen (next))) (".asciz" (inc (asciiLen (next)))) (T (quit "Unknown data directive")) ) ) ) ((== *Section 'text) (inc '*CodePos (case Name (".quad" 24) # Function headers (".balign" (if (gt0 (% *CodePos (next))) (- (arg) @) 0 ) ) (T 4) ) ) ) ) ) (de dataOffset (Sym) (if (lup *DataIndex Sym) (cdr @) (pack Sym "-Data") ) ) (de dataGot (Reg Sym) (cond ((lup *DataIndex Sym) (prinst "la" Reg (pack (cdr @) "(22)")) ) (*FPic (prinst "ld" Reg (pack Sym "@got(24)"))) (T (prinst "ld" Reg (pack Sym "@got(2)"))) ) ) (de codeCall (Sym) (if (lup *CodeIndex Sym) (prog (prinst "mtctr" 23) (prinst "bctrl") (prinst ".int" (cdr @)) ) (prinst "bl" "callRel") (prinst ".int" (pack Sym "-.")) ) ) # Addressing modes (de checkOp (Fun) (unless (Fun Op) (quit "Illegal operation" *Statement) ) ) (de opReg (Op Reg Ofs R) (let Adr (pack Ofs "(" R ")") (cond ((lt0 Reg) (checkOp bool) (cond ((=0 Op) (if (= -3 Reg) (let Byte (tmpReg) (prinst "lbz" Byte Adr) (prinst "insrdi" 3 Byte 8 56) ) (prinst "lbz" (abs Reg) Adr) ) ) ((=T Op) (prinst "stb" (abs Reg) Adr)) (T (prinst Op (abs Reg) Adr)) ) ) ((not Op) (unless (and (=0 Ofs) (= Reg R)) (prinst "la" Reg Adr) ) ) ((=0 Op) (prinst "ld" Reg Adr)) ((=T Op) (prinst "std" Reg Adr)) (T (prinst Op Reg Adr)) ) (cons Adr) ) ) (de opxReg (Op Reg R R2) (let Adr (pack R ", " R2) (cond ((lt0 Reg) (checkOp bool) (cond ((=0 Op) (if (= -3 Reg) (let Byte (tmpReg) (prinst "lbzx" Byte Adr) (prinst "insrdi" 3 Byte 8 56) ) (prinst "lbzx" (abs Reg) Adr) ) ) ((=T Op) (prinst "stbx" (abs Reg) Adr)) (T (prinst (pack Op "x") (abs Reg) Adr)) ) ) ((not Op) (prinst "add" Reg Adr)) ((=0 Op) (prinst "ldx" Reg R R2)) ((=T Op) (prinst "stdx" Reg Adr)) (T (prinst (pack Op "x") Reg Adr)) ) (cons Adr "x") ) ) (de mvReg (Dst Src) (if (or (lt0 Dst) (lt0 Src)) (prinst "insrdi" (abs Dst) (abs Src) 8 56) (prinst "mr" Dst Src) ) ) # Operation 'Op': # NIL Lea # 0 Fetch # T Store (de memory (Mem M Reg Op Tmp) #> ([adr [. "x"]]) (cond ((=0 M) # Immediate (checkOp =0) (if (= "0" Mem) (if (lt0 Reg) (prinst "insrdi" (abs Reg) 20 8 56) (prinst "li" Reg 0) ) (setq Mem (if (pre? "~" Mem) (x| `(hex "FFFFFFFFFFFFFFFF") (format (cdr (chop Mem)))) (format Mem) ) ) (cond ((lt0 Reg) (prinst "insrdi" (abs Reg) 20 8 56) (prinst "ori" (abs Reg) (abs Reg) (& 255 Mem)) ) ((>= 32767 Mem -32768) (prinst "li" Reg Mem) ) ((>= 2147483647 Mem -2147483648) (prinst "lis" Reg (>> 16 Mem)) (unless (=0 (setq Mem (& 65535 Mem))) (prinst "ori" Reg Reg Mem) ) ) (T (let (A (>> 48 Mem) B (& 65535 (>> 32 Mem)) C (& 65535 (>> 16 Mem)) D (& 65535 Mem) ) (prinst "lis" Reg A) (unless (=0 B) (prinst "ori" Reg Reg B) ) (if (=0 C) (prinst "sldi" Reg Reg 32) (prinst "sldi" Reg Reg 16) (prinst "ori" Reg Reg C) (prinst "sldi" Reg Reg 16) ) (unless (=0 D) (prinst "ori" Reg Reg D) ) ) ) ) ) NIL ) ((not M) # Register (cond ((not Reg) (setq Reg Mem)) ((= Mem Reg)) ((not Op) (prinst "mr" Reg Mem)) ((=0 Op) (mvReg Reg Mem)) ((=T Op) (mvReg Mem Reg)) (T (prinst Op Reg Mem)) ) NIL ) ((=T M) # Direct (cond ((sub? "-" Mem) # Label difference (checkOp =0) (prinst "li" Reg Mem) NIL ) ((== 'Nil Mem) (prinst "mr" Reg 25)) ((or *FPic (low? Mem)) # -fpic or code label (dataGot Reg Mem) ) (T (opReg NIL Reg (dataOffset Mem) 22)) ) ) ((not (car M)) # Indexed (cond ((not (cdr M)) (opReg Op Reg 0 (car Mem))) ((=0 (cdr M)) (if (>= 32767 (cdr Mem) -32768) (opReg Op Reg (cdr Mem) (car Mem)) (let R (or Tmp (tmpReg)) (prinst "lis" R (>> 16 (cdr Mem))) (unless (=0 (& 65535 (cdr Mem))) (prinst "ori" R R (& 65535 (cdr Mem))) ) (opxReg Op Reg R (car Mem)) ) ) ) ((=T (cdr M)) (cond ((sub? "-" (cdr Mem)) # Label difference (opReg Op Reg (cdr Mem) (car Mem)) ) ((or *FPic (low? (cdr Mem))) # -fpic or code label (let R (tmpReg) (dataGot R (cdr Mem)) (opxReg Op Reg R (car Mem)) ) ) (T (let R (tmpReg) (prinst "la" R (pack (dataOffset (cdr Mem)) "(22)")) (opxReg Op Reg R (car Mem)) ) ) ) ) ) ) ((=T (car M)) # Indirect (if (or *FPic (low? (car Mem))) # -fpic or code label (let R (tmpReg) (dataGot R (car Mem)) (opReg Op Reg 0 R) ) (opReg Op Reg (pack (and (cdr M) (pack (cdr Mem) "+")) (dataOffset (car Mem)) ) 22 ) ) ) (T # Combined (let R (or Tmp (tmpReg)) (memory (car Mem) (car M) R 0 R) (opReg Op Reg (or (cdr Mem) 0) R) ) ) ) ) (de memory2 (Cmd Reg Ref Ofs) (prinst (pack (if (lt0 Reg) "stb" Cmd) (cdr Ref)) (abs Reg) (if Ofs (pack @ "+" (car Ref)) (car Ref) ) ) ) (de srcReg (Src S Tmp) #> reg (cond ((not S) (ifn Tmp Src (prinst "mr" Tmp Src) Tmp ) ) ((= "0" Src) (ifn Tmp 20 (prinst "li" Tmp 0) Tmp ) ) ((= "1" Src) (ifn Tmp 21 (prinst "li" Tmp 1) Tmp ) ) ((== 'Nil Src) (ifn Tmp 25 (prinst "mr" Tmp 25) Tmp ) ) (T (prog1 (or Tmp (tmpReg)) (memory Src S @ 0) ) ) ) ) (de srcByteReg (Src S) #> reg (cond ((not S) (prog1 (tmpReg) (prinst "extrdi" @ (abs Src) 8 56) ) ) ((n0 S) (prog1 (tmpReg) (memory Src S @ "lbz") ) ) ((= "0" Src) 20) ((= "1" Src) 21) (T (prog1 (tmpReg) (prinst "li" @ (if (pre? "~" Src) (x| `(hex "FF") (format (cdr (chop Src)))) (format Src) ) ) ) ) ) ) (de dstReg (Dst D) #> (NIL dst adr [. "x"]) (cond (D (let R (tmpReg) (cons NIL R (memory Dst D R 0)) ) ) ((= -3 Dst) (let R (tmpReg) (prinst "extrdi" R 3 8 56) (cons NIL R -3) ) ) (T (list NIL Dst)) ) ) (de dstByteReg (Dst D) #> (T dst adr [. "x"]) (cond (D (let R (tmpReg) (cons T R (memory Dst D R "lbz")) ) ) ((= -3 Dst) (let R (tmpReg) (prinst "extrdi" R 3 8 56) (cons T R -3) ) ) (T (list T Dst)) ) ) (de dstSrcReg (Dst D Src S) #> (src flg dst adr [. "x"]) (if (or (= -3 Dst) (= -3 Src)) (cons (srcByteReg Src S) (dstByteReg Dst D) ) (cons (srcReg Src S) (dstReg Dst D) ) ) ) (de regDst (RegRef) (cond ((= -3 (cddr RegRef)) (prinst "insrdi" 3 (cadr RegRef) 8 56) ) ((car RegRef) # byte-flg (when (cddr RegRef) (memory2 "stb" (cadr RegRef) (cddr RegRef)) ) ) ((cddr RegRef) (memory2 "std" (cadr RegRef) (cddr RegRef)) ) ) ) ### Instruction set ### (de alignSection (Align) (if (== *Section 'text) (prinst ".balign" 8) (prinst ".balign" 16) (or (=0 Align) (prinst ".space" Align)) ) ) (asm nop () (prinst "nop") ) (asm align (N) (prinst ".balign" N) ) (asm skip (N) (if (== 'data *Section) (or (=0 N) (prinst ".space" N)) (do (/ N 2) (prinst "nop")) ) ) (asm ld (Dst D Src S) (cond ((not D) (ifn (= (3 . 14) Dst) (memory Src S Dst 0) (let A (memory Src S 3 0) # D (prinst "ld" 14 (pack "8+" (car A))) ) ) ) ((not S) (ifn (= (3 . 14) Src) (memory Dst D Src T) (let A (memory Dst D 3 T) # D (prinst "std" 14 (pack "8+" (car A))) ) ) ) ((= "0" Src) (memory Dst D 20 T)) ((= "1" Src) (memory Dst D 21 T)) ((== 'Nil Src) (memory Dst D 25 T)) (T (let R (tmpReg) (memory Src S R 0) (memory Dst D R T) ) ) ) ) (asm ld2 (Src S) (memory Src S 3 "lhz") ) (asm ld4 (Src S) (memory Src S 3 "lwz") ) (asm ldc (Dst D Src S) (prinst "cmpdi" "cr1" 31 -2) (prinst "beq-" "cr1" "1f") (memory Src S Dst 0) (prinl "1:") ) (asm ldnc (Dst D Src S) (prinst "cmpdi" "cr1" 31 -2) (prinst "bne-" "cr1" "1f") (memory Src S Dst 0) (prinl "1:") ) (asm ldz (Dst D Src S) (prinst "bne-" "1f") (memory Src S Dst 0) (prinl "1:") ) (asm ldnz (Dst D Src S) (prinst "beq-" "1f") (memory Src S Dst 0) (prinl "1:") ) (asm lea (Dst D Src S) (ifn D (memory Src S Dst) (let R (tmpReg) (memory Src S R) (memory Dst D R T) ) ) ) (asm st2 (Dst D) (memory Dst D 3 "sth") ) (asm st4 (Dst D) (memory Dst D 3 "stw") ) (asm xchg (Dst D Dst2 D2) (let (Tmp (tmpReg Dst Dst2) A (memory Dst D Tmp 0)) # Tmp = Dst (nond (D (if (memory Dst2 D2 Dst 0) # Dst = Dst2 (memory2 "std" Tmp @) # Dst2 = Tmp (mvReg Dst2 Tmp) ) ) (D2 (memory2 "std" Dst2 A) (mvReg Dst2 Tmp) ) (NIL (let (R (tmpReg) B (memory Dst2 D2 R 0)) (memory2 "std" R A) (memory2 "std" Tmp B) ) ) ) ) ) (asm movn (Dst D Src S Cnt C) (memory Dst D 4) (memory Src S 5) (memory Cnt C 6 0) (codeCall "movn") ) (asm mset (Dst D Cnt C) (memory Dst D 4) (memory Cnt C 5 0) (codeCall "mset") ) (asm movm (Dst D Src S End E) (memory Dst D 6) (memory Src S 4) (memory End E 5) (codeCall "save") ) (asm save (Src S End E Dst D) (memory Src S 4) (memory End E 5) (memory Dst D 6) (codeCall "save") ) (asm load (Dst D End E Src S) (memory Dst D 4) (memory End E 5) (memory Src S 6) (codeCall "load") ) # Arithmetics (asm add (Dst D Src S) (ifn (= (3 . 14) Dst) (if (and (=0 S) (>= 32767 (format Src) -32768)) (let A (dstReg Dst D) (prinst "addic." (cadr A) (cadr A) Src) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "addc." (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) (if (and (=0 S) (>= 32767 (format Src) -32768)) (prinst "addic" 3 3 Src) (prinst "addc" 3 3 (srcReg Src S)) ) (prinst "addze." 14 14) ) (prinst "subfze" 31 21) ) # Set carry (asmNoCC add (Dst D Src S) (ifn (= (3 . 14) Dst) (if (and (=0 S) (>= 32767 (format Src) -32768)) (let A (dstReg Dst D) (prinst "addi" (cadr A) (cadr A) Src) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "add" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) (if (and (=0 S) (>= 32767 (format Src) -32768)) (prinst "addic" 3 3 Src) (prinst "addc" 3 3 (srcReg Src S)) ) (prinst "addze" 14 14) ) ) (asm addc (Dst D Src S) (prinst "sradi" 0 31 1) # Get carry (ifn (= (3 . 14) Dst) (let A (dstSrcReg Dst D Src S) (prinst "adde." (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) (prinst "adde" 3 3 (srcReg Src S)) (prinst "addze." 14 14) ) (prinst "subfze" 31 21) ) # Set carry (asmNoCC addc (Dst D Src S) (prinst "sradi" 0 31 1) # Get carry (ifn (= (3 . 14) Dst) (let A (dstSrcReg Dst D Src S) (prinst "adde" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) (prinst "adde" 3 3 (srcReg Src S)) (prinst "adde" 14 14 20) ) ) (asm sub (Dst D Src S) (ifn (= (3 . 14) Dst) (if (and (=0 S) (>= 32767 (format Src) -32768)) (let A (dstReg Dst D) (prinst "subic." (cadr A) (cadr A) Src) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "subc." (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) (if (and (=0 S) (>= 32767 (format Src) -32768)) (prinst "subic" 3 3 Src) (prinst "subc" 3 3 (srcReg Src S)) ) (prinst "subfze." 14 14) ) (prinst "subfme" 31 21) ) # Set inverted carry (asmNoCC sub (Dst D Src S) (ifn (= (3 . 14) Dst) (if (and (=0 S) (>= 32767 (format Src) -32768)) (let A (dstReg Dst D) (prinst "subi" (cadr A) (cadr A) Src) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "sub" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) (if (and (=0 S) (>= 32767 (format Src) -32768)) (prinst "subic" 3 3 Src) (prinst "subc" 3 3 (srcReg Src S)) ) (prinst "subfze" 14 14) ) ) (asm subc (Dst D Src S) (prinst "xori" 0 31 1) # Get inverted carry (prinst "sradi" 0 0 1) (ifn (= (3 . 14) Dst) (let A (dstSrcReg Dst D Src S) (prinst "subfe." (caddr A) (car A) (caddr A)) (regDst (cdr A)) ) (prinst "sube" 3 3 (srcReg Src S)) (prinst "subfze." 14 14) ) (prinst "subfme" 31 21) ) # Set inverted carry (asmNoCC subc (Dst D Src S) (prinst "xori" 0 31 1) # Get inverted carry (prinst "sradi" 0 0 1) (ifn (= (3 . 14) Dst) (let A (dstSrcReg Dst D Src S) (prinst "subfe" (caddr A) (car A) (caddr A)) (regDst (cdr A)) ) (prinst "sube" 3 3 (srcReg Src S)) (prinst "sube" 14 14 20) ) ) (asm inc (Dst D) (let A (dstReg Dst D) (prinst "addic." (cadr A) (cadr A) 1) (regDst A) ) ) (asmNoCC inc (Dst D) (let A (dstReg Dst D) (prinst "addi" (cadr A) (cadr A) 1) (regDst A) ) ) (asm dec (Dst D) (let A (dstReg Dst D) (prinst "subic." (cadr A) (cadr A) 1) (regDst A) ) ) (asmNoCC dec (Dst D) (let A (dstReg Dst D) (prinst "subi" (cadr A) (cadr A) 1) (regDst A) ) ) (asm not (Dst D) (let A (dstReg Dst D) (prinst "not." (cadr A) (cadr A)) (regDst A) ) ) (asmNoCC not (Dst D) (let A (dstReg Dst D) (prinst "not" (cadr A) (cadr A)) (regDst A) ) ) (asm neg (Dst D) (let A (dstReg Dst D) (prinst "neg." (cadr A) (cadr A)) (regDst A) ) ) (asmNoCC neg (Dst D) (let A (dstReg Dst D) (prinst "neg" (cadr A) (cadr A)) (regDst A) ) ) (asm and (Dst D Src S) (if (and (=0 S) (>= 65535 (format Src) 0)) (let A (dstReg Dst D) (prinst "andi." (cadr A) (cadr A) (format Src)) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "and." (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) ) (asmNoCC and (Dst D Src S) (if (and (=0 S) (>= 65535 (format Src) 0)) (let A (dstReg Dst D) (prinst "andi." (cadr A) (cadr A) (format Src)) # 'and' doesn't exist (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "and" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) ) (asm or (Dst D Src S) (let A (dstSrcReg Dst D Src S) (prinst "or." (caddr A) (caddr A) (car A)) # 'ori.' doesn't exist (regDst (cdr A)) ) ) (asmNoCC or (Dst D Src S) (if (and (=0 S) (>= 65535 (format Src) 0)) (let A (dstReg Dst D) (prinst "ori" (cadr A) (cadr A) (format Src)) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "or" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) ) (asm xor (Dst D Src S) (let A (dstSrcReg Dst D Src S) (prinst "xor." (caddr A) (caddr A) (car A)) # 'xori.' doesn't exist (regDst (cdr A)) ) ) (asmNoCC xor (Dst D Src S) (if (and (=0 S) (>= 65535 (format Src) 0)) (let A (dstReg Dst D) (prinst "xori" (cadr A) (cadr A) (format Src)) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "xor" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) ) (asm off (Dst D Src S) (let (A (dstReg Dst D) R (tmpReg)) (prinst "li" R Src) (prinst "and." (cadr A) (cadr A) R) (regDst A) ) ) (asm test (Dst D Src S) (prinst "li" 31 -2) # Clear carry (if (and (=0 S) (>= 65535 (format Src) 0)) (let A (dstReg Dst D) (prinst "andi." 0 (cadr A) (format Src)) ) (let A (dstSrcReg Dst D Src S) (prinst "and." 0 (caddr A) (car A)) ) ) ) (asm shl (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (when (gt0 (dec (format Src))) (prinst "sldi" (cadr A) (cadr A) @) ) (prinst "addc." (cadr A) (cadr A) (cadr A)) (regDst A) (prinst "subfze" 31 21) ) # Set carry from MSB (let A (dstSrcReg Dst D Src S) (prinst "sld." (caddr A) (caddr A) (car A)) # Ignore carry (regDst (cdr A)) ) ) ) (asmNoCC shl (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (prinst "sldi" (cadr A) (cadr A) (format Src)) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "sld" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) ) (asm shr (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (when (gt0 (dec (format Src))) (prinst "srdi" (cadr A) (cadr A) @) ) (prinst "li" 31 -2) # Set carry from LSB (prinst "insrdi" 31 (cadr A) 1 63) (prinst "srdi." (cadr A) (cadr A) 1) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "srd." (caddr A) (caddr A) (car A)) # Ignore carry (regDst (cdr A)) ) ) ) (asmNoCC shr (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (prinst "srdi" (cadr A) (cadr A) (format Src)) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "srd" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) ) (asm rol (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (prinst "rotldi" (cadr A) (cadr A) (format Src)) (regDst A) ) (let A (dstSrcReg Dst D Src S) (prinst "rotld" (caddr A) (caddr A) (car A)) (regDst (cdr A)) ) ) ) (asm ror (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (prinst "rotrdi" (cadr A) (cadr A) (format Src)) (regDst A) ) (quit "Non-immediate 'ror' not available") ) ) (asm rcl (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (prinst "sradi" 0 31 1) # Get carry (do (format Src) (prinst "adde." (cadr A) (cadr A) (cadr A)) ) (regDst A) (prinst "subfze" 31 21) ) # Set carry (quit "Non-immediate 'rcl' not available") ) ) (asmNoCC rcl (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (prinst "sradi" 0 31 1) # Get carry (do (format Src) (prinst "adde" (cadr A) (cadr A) (cadr A)) ) (regDst A) ) (quit "Non-immediate 'rcl' not available") ) ) (asm rcr (Dst D Src S) (if (=0 S) (let A (dstReg Dst D) (do (setq Src (format Src)) (prinst "mr" 0 (cadr A)) (prinst "rotrdi" (cadr A) (cadr A) 1) (prinst "insrdi" (cadr A) 31 1 0) (prinst "insrdi" 31 0 1 63) ) (regDst A) ) (quit "Non-immediate 'rcr' not available") ) ) (asm mul (Src S) (let R (srcReg Src S) (prinst "mulhdu" 14 3 R) (prinst "mulld" 3 3 R) ) ) (asm div (Src S) (srcReg Src S 4) (codeCall "div") ) (asm zxt () # 8 bit -> 64 bit (prinst "andi." 3 3 255) ) # 'and' doesn't exist (asm setz () (prinst "addic." 0 20 0) ) # Add zero to null (asm clrz () (prinst "cmpdi" 1 0) ) # Compare stack pointer to zero (asm setc () (prinst "li" 31 -1) ) (asm clrc () (prinst "li" 31 -2) ) # Comparisons (asm cmp (Dst D Src S) (if (and (=0 S) (>= 32767 (format Src) -32768)) (let A (dstReg Dst D) (prinst "subic." 0 (cadr A) Src) ) (let A (dstSrcReg Dst D Src S) (prinst "subc." 0 (caddr A) (car A)) ) ) (prinst "subfme" 31 21) ) # Set inverted carry (asm cmpn (Dst D Src S Cnt C) (memory Dst D 4) (memory Src S 5) (memory Cnt C 6 0) (codeCall "cmpn") ) (asm slen (Dst D Src S) (memory Src S 5) (codeCall "slen") (memory Dst D 4 T) ) (asm memb (Src S Cnt C) (memory Src S 4) (memory Cnt C 5 0) (codeCall "memb") (unless S (prinst "mr" Src 4)) (unless C (prinst "mr" Cnt 5)) ) (asm null (Src S) ##? (prinst "li" 31 -2) # Clear carry (prinst "cmpdi" (srcReg Src S) 0) ) (asm nulp (Src S) (prinst "cmpdi" (srcReg Src S) 0) ) (asm nul4 () ##? (prinst "li" 31 -2) # Clear carry (prinst "sldi" 3 3 32) (prinst "sradi." 3 3 32) ) # Byte addressing (asm set (Dst D Src S) (memory Dst D (srcByteReg Src S) "stb") ) (asm nul (Src S) ##? (prinst "li" 31 -2) # Clear carry (prinst "cmpdi" (srcByteReg Src S) 0) ) # Types (asm cnt (Src S) (prinst "andi." 0 (srcReg Src S) "0x02") ) (asm big (Src S) (prinst "andi." 0 (srcReg Src S) "0x04") ) (asm num (Src S) (prinst "andi." 0 (srcReg Src S) "0x06") ) (asm sym (Src S) (prinst "andi." 0 (srcReg Src S) "0x08") ) (asm atom (Src S) (prinst "andi." 0 (srcReg Src S) "0x0E") ) # Flow Control (asm call (Adr A) (nond (A # Absolute (codeCall Adr) ) ((=T A) # Indexed: Ignore SUBR (prinst "mtctr" Adr) (prinst "bl" "callCtr") ) (NIL # Indirect (prinst "ld" 11 (pack (dataOffset Adr) "(22)")) (prinst "mtctr" 11) (prinst "bl" "callCtr") ) ) ) (de _jmp Args (nond (A (let @Lbl Adr (cond ((lup *CodeIndex Adr) (let Ofs (cdr @) (if (>= 32767 Ofs) (prinst "addi" 11 23 Ofs) (prinst "lis" 11 (>> 16 Ofs)) (unless (=0 (setq Ofs (& 65535 Ofs))) (prinst "ori" 11 11 Ofs) ) (prinst "add" 11 11 23) ) (prinst "mtctr" 11) (for E (caddr Args) (apply prinst (cons (pack (pop 'E) (pop 'E)) E)) ) ) ) ((not (cadr Args)) (for E (fill (car Args)) # b (apply prinst (cons (pack (pop 'E) (pop 'E)) E)) ) ) (T (let Back (for (P *Program (n== *Statement (car P)) (cdr P)) (T (and (== ': (caar P)) (= Adr (cdar P))) T) ) (for E (fill ((if (or (= `(char ".") (char Adr)) # Local label (and (cdr (split (chop Adr) "_")) (format (last @)) ) ) car cadr ) Args ) ) (apply prinst (cons (pack (pop 'E) (case (pop 'E) ("+" (if Back "-" "+")) ("-" (if Back "+" "-")) ) ) E ) ) ) ) ) ) ) ) ((=T A) # Ignore SUBR (prinst "mtctr" Adr) (for E (fill (caddr Args)) (apply prinst (cons (pack (pop 'E) (pop 'E)) E)) ) ) (NIL # Indirect (prinst "ld" 11 (pack (dataOffset Adr) "(22)")) (prinst "mtctr" 11) (for E (caddr Args) (apply prinst (cons (pack (pop 'E) (pop 'E)) E)) ) ) ) ) (asm jmp (Adr A) (_jmp (("b" NIL @Lbl)) NIL (("bctr" NIL)) ) ) (asm jz (Adr A) (_jmp (("beq" - @Lbl)) (("bne" + ".+8") ("b" NIL @Lbl)) (("beqctr" -)) ) ) (asm jeq (Adr A) (_jmp (("beq" - @Lbl)) (("bne" + ".+8") ("b" NIL @Lbl)) (("beqctr" -)) ) ) (asm jnz (Adr A) (_jmp (("bne" - @Lbl)) (("beq" + ".+8") ("b" NIL @Lbl)) (("bnectr" -)) ) ) (asm jne (Adr A) (_jmp (("bne" - @Lbl)) (("beq" + ".+8") ("b" NIL @Lbl)) (("bnectr" -)) ) ) (asm js (Adr A) (_jmp (("blt" - @Lbl)) (("bge" + ".+8") ("b" NIL @Lbl)) (("bltctr" -)) ) ) (asm jns (Adr A) (_jmp (("bge" - @Lbl)) (("blt" + ".+8") ("b" NIL @Lbl)) (("bgectr" -)) ) ) (asm jsz (Adr A) (_jmp (("ble" - @Lbl)) (("bgt" + ".+8") ("b" NIL @Lbl)) (("blectr" -)) ) ) (asm jnsz (Adr A) (_jmp (("bgt" - @Lbl)) (("ble" + ".+8") ("b" NIL @Lbl)) (("bgtctr" -)) ) ) (asm jc (Adr A) (prinst "cmpdi" "cr1" 31 -2) (_jmp (("bne" - "cr1" @Lbl)) (("beq" + "cr1" ".+8") ("b" NIL @Lbl)) (("bnectr" - "cr1")) ) ) (asm jlt (Adr A) (prinst "cmpdi" "cr1" 31 -2) (_jmp (("bne" - "cr1" @Lbl)) (("beq" + "cr1" ".+8") ("b" NIL @Lbl)) (("bnectr" - "cr1")) ) ) (asm jnc (Adr A) (prinst "cmpdi" "cr1" 31 -2) (_jmp (("beq" - "cr1" @Lbl)) (("bne" + "cr1" ".+8") ("b" NIL @Lbl)) (("beqctr" - "cr1")) ) ) (asm jge (Adr A) (prinst "cmpdi" "cr1" 31 -2) (_jmp (("beq" - "cr1" @Lbl)) (("bne" + "cr1" ".+8") ("b" NIL @Lbl)) (("beqctr" - "cr1")) ) ) (asm jcz (Adr A) (prinst "cmpdi" "cr1" 31 -2) (_jmp (("bne" - "cr1" @Lbl) ("beq" - @Lbl)) (("beq" - "cr1" ".+12") ("bne" + ".+8") ("b" NIL @Lbl)) (("bnectr" - "cr1") ("beqctr" -) ) ) ) (asm jle (Adr A) (prinst "cmpdi" "cr1" 31 -2) (_jmp (("bne" - "cr1" @Lbl) ("beq" - @Lbl)) (("beq" - "cr1" ".+12") ("bne" + ".+8") ("b" NIL @Lbl)) (("bnectr" - "cr1") ("beqctr" -) ) ) ) (asm jncz (Adr A) (prinst "cmpdi" "cr1" 31 -2) (_jmp (("bne" + "cr1" ".+8") ("bne" - @Lbl)) (("bne" + "cr1" ".+12") ("beq" + ".+8") ("b" NIL @Lbl)) (("bne" + "cr1" ".+8") ("bnectr" -)) ) ) (asm jgt (Adr A) (prinst "cmpdi" "cr1" 31 -2) (_jmp (("bne" + "cr1" ".+8") ("bne" - @Lbl)) (("bne" + "cr1" ".+12") ("beq" + ".+8") ("b" NIL @Lbl)) (("bne" + "cr1" ".+8") ("bnectr" NIL)) ) ) (asm ret () (prinst "blr") ) # Floating point (asm ldd () (prinst "lfd" 1 "0(14)") ) (asm ldf () (prinst "lfs" 1 "0(14)") ) (asm fixnum () (prinst "srdi" 0 15 4) # Normalize scale (ignore sign) (prinst "std" 0 "-8(1)") (prinst "lfd" 0 "-8(1)") # Get scale in f13 (prinst "fcfid" 13 0) (prinst "fmul" 1 1 13) # Multiply with value (prinst "fctid" 0 1) # Convert to integer (prinst "stfd" 0 "-8(1)") (prinst "ld" 15 "-8(1)") # In E (prinst "or." 15 15 15) # Sign? (prinst "blt-" "1f") # Yes (prinst "extrdi." 0 15 4 0) # Overflow? (prinst "beq+" "3f") # No (prinst "la" 15 "TSym-Data(22)") (prinst "b" "4f") (prinl "1:") (prinst "extrdi" 0 15 4 0) # Underflow? (prinst "neg" 15 15) # Negate (prinst "cmpdi" 0 0 15) (prinst "beq+" "2f") # No (prinst "mr" 15 25) # Nil (prinst "b" "4f") (prinl "2:") (prinst "sldi" 15 15 4) # Make negative short number (prinst "ori" 15 15 10) (prinst "b" "4f") (prinl "3:") (prinst "sldi" 15 15 4) # Make short number (prinst "ori" 15 15 2) (prinl "4:") ) (asm float () #{!}# ) (asm std () (prinst "stfd" 1 "0(14)") ) (asm stf () (prinst "stfs" 1 "0(14)") ) # C-Calls (asm cc (Adr A Arg M) (let Reg (3 4 5 6 7 8 9 10) # Support only max. 8 parameters (if (lst? Arg) (let (Lea NIL Tmp NIL) (when (fish '((X) (= 3 X)) (cdr Arg)) (prinst "mr" (setq Tmp 11) 3) ) (mapc '((Src S) (if (== '& Src) (on Lea) (setq Src (recur (Src) (cond ((= 3 Src) (or Tmp 3)) ((atom Src) Src) (T (cons (recurse (car Src)) (recurse (cdr Src)))) ) ) ) (cond ((not Reg) # 'Src' not stack-relative here! #{MADA}# ) ((and (=T S) (== 'pop Src)) (prinst "ld" (pop 'Reg) "0(1)") (prinst "addi" 1 1 8) ) (Lea (memory Src S (pop 'Reg))) ((= 3 Src) (pop 'Reg)) (T (srcReg Src S (pop 'Reg))) ) (off Lea) ) ) Arg M ) ) (prinst "mr" 27 1) # 27 on arguments (prinst "ld" 11 "flt1@got(2)") (for R Reg (prinst "cmpd" Arg 27) (prinst "beq-" "2f") (prinst "ld" 0 "0(27)") (prinst "cmpdi" 0 0) # Float? (prinst "beq-" "1f") # No (prinst "mtctr" 11) # Else call float conversion (prinst "bctrl") (prinl "1:") (prinst "ld" R "8(27)") # Get value (prinst "addi" 27 27 16) ) (prinl "2:") ) ) (nond (A # Absolute (unless (= Adr "exit") (prinst "mflr" 27) (prinst "stdu" 1 "-112(1)") ) (prinst "bl" Adr) (prinst "nop") (unless (= Adr "exit") (prinst "addi" 1 1 112) (prinst "mtlr" 27) ) ) ((=T A) # Indexed (prinst "mflr" 0) (prinst "stdu" 1 "-120(1)") (prinst "std" 0 "112(1)") (prinst "std" 2 "40(1)") (prinst "ld" 0 (pack "0(" Adr ")")) (prinst "ld" 11 (pack "16(" Adr ")")) (prinst "ld" 2 (pack "8(" Adr ")")) (prinst "mtctr" 0) (prinst "bctrl") (prinst "ld" 2 "40(1)") (prinst "ld" 0 "112(1)") (prinst "addi" 1 1 120) (prinst "mtlr" 0) ) ) (and (lst? Arg) (gt0 (- (length Arg) 8)) (prinst "addi" 1 1 (* @ 8)) ) ) (asm func ()) (asm begin () (prinst ".quad" ".+24" ".TOC.@tocbase" 0) (prinst "mflr" 0) (prinst "bl" "begin") ) (asm return () (prinst "b" "return") ) # Stack Manipulations (asm push (Src S) (ifn (=T Src) (prinst "stdu" (srcReg Src S) "-8(1)") (let R (tmpReg) (prinst "mfocrf" R 128) # Get CR[0] (prinst "insrdi" R 31 1 63) # Carry into LSB (prinst "stdu" R "-8(1)") ) ) ) (asm pop (Dst D) (cond (D (let R (tmpReg) (prinst "ld" R "0(1)") (memory Dst D R T) ) ) ((=T Dst) (let R (tmpReg) (prinst "ld" R "0(1)") (prinst "insrdi" 31 R 1 63) # Set carry from LSB (prinst "mtocrf" 128 R) ) ) # Set CR[0] (LT, GT, EQ, SO) (T (prinst "ld" Dst "0(1)")) ) (prinst "addi" 1 1 8) ) (asm link () (prinst "stdu" 19 "-8(1)") # Push L (prinst "mr" 19 1) ) (asm tuck (Src S) (prinst "ld" 19 "0(1)") # Get L (prinst "std" (srcReg Src S) "0(1)") ) (asm drop () (prinst "ld" 1 "0(19)") # Restore S (prinst "ld" 19 "0(1)") # and L (prinst "addi" 1 1 8) ) # Evaluation (asm eval () (prinst "andi." 0 15 "0x06") # Number? (prinst "bne-" "2f") # Yes: Skip (prinst "andi." 0 15 "0x08") # Symbol? (prinst "beq-" "1f") # Yes: Get value (prinst "ld" 15 "0(15)") (prinst "b" "2f") # and skip (prinl "1:") (codeCall "evListE_E") # Else evaluate list (prinl "2:") ) (asm eval+ () (prinst "andi." 0 15 "0x06") # Number? (prinst "bne-" "2f") # Yes: Skip (prinst "andi." 0 15 "0x08") # Symbol? (prinst "beq-" "1f") # Yes: Get value (prinst "ld" 15 "0(15)") (prinst "b" "2f") # and skip (prinl "1:") (prinst "stdu" 19 "-8(1)") # Else 'link' (prinst "mr" 19 1) (codeCall "evListE_E") # Evaluate list (prinst "ld" 19 "0(1)") # Pop L (prinst "addi" 1 1 8) (prinl "2:") ) (asm eval/ret () (prinst "andi." 0 15 "0x06") # Number? (prinst "bnelr-") # Yes: Return (prinst "andi." 0 15 "0x08") # Symbol? (prinst "beq-" "1f") # No: Evaluate list (prinst "ld" 15 "0(15)") # Get value (prinst "blr") (prinl "1:") (prinst "b" "evListE_E") ) (asm exec (Reg) (prinl "1:") # do (prinst "ld" 15 (pack "0(" Reg ")")) # ld E (R) (prinst "andi." 0 15 "0x0E") # atom E (prinst "bne+" "2f") (codeCall "evListE_E") # Evaluate list (prinl "2:") (prinst "ld" Reg (pack "8(" Reg ")")) # ld R (R CDR) (prinst "andi." 0 Reg "0x0E") # atom R (prinst "beq+" "1b") ) # until nz (asm prog (Reg) (prinl "1:") # do (prinst "ld" 15 (pack "0(" Reg ")")) # ld E (R) (prinst "andi." 0 15 "0x06") # eval (prinst "bne-" "2f") (prinst "andi." 0 15 "0x08") (prinst "beq-" ".+12") (prinst "ld" 15 "0(15)") (prinst "b" "2f") (codeCall "evListE_E") # Evaluate list (prinl "2:") (prinst "ld" Reg (pack "8(" Reg ")")) # ld R (R CDR) (prinst "andi." 0 Reg "0x0E") # atom R (prinst "beq+" "1b") ) # until nz # System (asm initData ()) (asm initCode () (unless *FPic (prinst "mflr" 11) # Get return address (prinst "lwa" 0 "0(11)") # Target offset (prinst "add" 0 0 23) # Code-relative (prinst "mtlr" 0) # Set target address (prinst "addi" 0 11 4) # Update return address (prinst "stdu" 0 "-8(1)") # Save it (prinst "blrl") # Call target (prinst "ld" 0 "0(1)") # Pop return address (prinst "addi" 1 1 8) (prinst "mtctr" 0) # Return (prinst "bctr") (prinl) ) (label "callRel") (prinst "mflr" 11) # Get return address (prinst "lwa" 0 "0(11)") # Target offset (prinst "add" 0 0 11) # PC-relative (prinst "mtlr" 0) # Set target address (prinst "addi" 0 11 4) # Update return address (prinst "stdu" 0 "-8(1)") # Save it (prinst "blrl") # Call target (prinst "ld" 0 "0(1)") # Pop return address (prinst "addi" 1 1 8) (prinst "mtctr" 0) # Return (prinst "bctr") (prinl) (label "callCtr") (prinst "mflr" 11) # Get return address (prinst "stdu" 11 "-8(1)") # Save it (prinst "bctrl") # Call target (prinst "ld" 0 "0(1)") # Pop return address (prinst "addi" 1 1 8) (prinst "mtctr" 0) # Return (prinst "bctr") (prinl) (unless *FPic (prinl "# movn dst src cnt") (label "movn") (prinst "subi" 4 4 1) # Adjust 'dst' (prinst "subi" 5 5 1) # and 'src' (prinl "1:") (prinst "subic." 6 6 1) # Decrement 'cnt' (prinst "bltlr") # Return if done (prinst "lbzu" 7 "1(5)") # Next byte from 'src' (prinst "stbu" 7 "1(4)") # Write to 'dst' (prinst "b" "1b") (prinl) (prinl "# mset dst src cnt") (label "mset") (prinst "subi" 4 4 1) # Adjust 'dst' (prinl "1:") (prinst "subic." 5 5 1) # Decrement 'cnt' (prinst "bltlr") # Return if done (prinst "stbu" 3 "1(4)") # Write B to 'dst' (prinst "b" "1b") (prinl) (prinl "# save src end dst") (label "save") (prinst "ld" 7 "0(4)") # First word from 'src' (prinst "std" 7 "0(6)") # Write to 'dst' (prinl "1:") (prinst "ldu" 7 "8(4)") # Next word from 'src' (prinst "cmpd" 4 5) # Done? (prinst "beqlr-") # Yes: Return (prinst "stdu" 7 "8(6)") # Write to 'dst' (prinst "b" "1b") (prinl) (prinl "# load dst end src") (label "load") (prinst "ld" 7 "0(6)") # First word from 'src' (prinst "std" 7 "0(4)") # Write to 'dst' (prinst "subi" 5 5 8) # Adjust 'end' (prinl "1:") (prinst "ldu" 7 "8(6)") # Next word from 'src' (prinst "stdu" 7 "8(4)") # Write to 'dst' (prinst "cmpd" 4 5) # Done? (prinst "bne+" "1b") # No (prinst "blr") (prinl) (prinl "# cmpn dst src cnt") (label "cmpn") (prinst "lbz" 7 "0(4)") # First byte from 'dst' (prinst "lbz" 8 "0(5)") # First byte from 'src' (prinl "1:") (prinst "subc." 0 7 8) # Same bytes? (prinst "bnelr-") # No: Return 'ne' (prinst "subic." 6 6 1) # Decrement 'cnt' (prinst "beqlr-") # Return 'eq' if done (prinst "lbzu" 7 "1(4)") # Next bytes (prinst "lbzu" 8 "1(5)") (prinst "b" "1b") (prinl) (prinl "# slen dst src") (label "slen") (prinst "li" 4 0) # Init 'dst' counter (prinst "lbz" 7 "0(5)") # First byte from 'src' (prinl "1:") (prinst "cmpdi" 7 0) # Done? (prinst "beqlr-") # Yes: Return (prinst "addi" 4 4 1) # Increment 'cnt' (prinst "lbzu" 7 "1(5)") # Next byte (prinst "b" "1b") (prinl) (prinl "# memb src cnt") (label "memb") (prinst "mr" 6 4) # Get 'src' (prinst "extrdi" 7 3 8 56) # and B (prinl "1:") (prinst "subic." 5 5 1) # Decrement 'cnt' (prinst "bltlr-") # Return 'ne' if done (prinst "lbz" 8 "0(6)") # Next byte from 'src' (prinst "addi" 6 6 1) # Increment 'src' (prinst "cmpd" 8 7) # Found? (prinst "bne+" "1b") # No (prinst "mr" 4 6) # Else return 'eq' (prinst "blr") (prinl) (prinl "# div src") # From: http://hackers-delight.org.ua (label "div") # 14:3 / 4 (let (@u1 14 @u0 3 @v 4 @s 5 # un21 = un32 = u1 @un1 6 @un0 7 @vn1 8 @vn0 9 @q1 27 @q0 28 @rhat 29 @tmp 30 ) (macro (prinst "cmpld" @u1 @v) # u1 >= v? (prinst "bge-" "divOvfl") # Yes: Overflow (prinst "li" @s 0) # Init 's' (prinst "cmpdi" @v 0) # Normalize (prinst "blt" "div2") (prinl "div1:") (prinst "addi" @s @s 1) # Increment 's' (prinst "addc" @u0 @u0 @u0) # Shift dividend left (prinst "adde" @u1 @u1 @u1) (prinst "add." @v @v @v) # and divisor (prinst "bge" "div1") (prinl "div2:") (prinst "extrdi" @vn1 @v 32 0) # Split divisor into high 32 bits (prinst "extrdi" @vn0 @v 32 32) # and low 32 bits (prinst "extrdi" @un1 @u0 32 0) # Split 'u0' into high 32 bits (prinst "extrdi" @un0 @u0 32 32) # and low 32 bits (prinst "divdu" @q1 @u1 @vn1) # First quotient digit (prinst "mulld" 0 @q1 @vn1) (prinst "sub" @rhat @u1 0) (prinl "div3:") (prinst "extrdi." 0 @q1 32 0) # q1 >= b? (prinst "bne-" "div4") # Yes (prinst "sldi" @tmp @rhat 32) # b*rhat + un1 (prinst "add" @tmp @tmp @un1) (prinst "mulld" 0 @q1 @vn0) (prinst "cmpld" 0 @tmp) # q1 * vn0 > b*rhat + un1? (prinst "ble+" "div5") # No (prinl "div4:") (prinst "subi" @q1 @q1 1) # Else decrement 'q1' (prinst "add" @rhat @rhat @vn1) # Increment 'rhat' (prinst "extrdi." 0 @rhat 32 0) # Less than 'b'? (prinst "beq-" "div3") # Yes (prinl "div5:") (prinst "sldi" @u1 @u1 32) # (un32*b) (prinst "add" @u1 @u1 @un1) # (un1 + un32*b) (prinst "mulld" 0 @q1 @v) (prinst "sub" @u1 @u1 0) # un21 = un1 + un32*b - q1*v (prinst "divdu" @q0 @u1 @vn1) # Second quotient digit (prinst "mulld" 0 @q0 @vn1) (prinst "sub" @rhat @u1 0) (prinl "div6:") (prinst "extrdi." 0 @q0 32 0) # q0 >= b? (prinst "bne-" "div7") # Yes (prinst "sldi" @tmp @rhat 32) # b*rhat + un0 (prinst "add" @tmp @tmp @un0) (prinst "mulld" 0 @q0 @vn0) (prinst "cmpld" 0 @tmp) # q0 * vn0 > b*rhat + un0? (prinst "ble+" "div8") # No (prinl "div7:") (prinst "subi" @q0 @q0 1) # Else decrement 'q0' (prinst "add" @rhat @rhat @vn1) # Increment 'rhat' (prinst "extrdi." 0 @rhat 32 0) # Less than 'b'? (prinst "beq-" "div6") # Yes (prinl "div8:") (prinst "sldi" @u0 @q1 32) # Quotient (prinst "add" @u0 @u0 @q0) (prinst "sldi" @u1 @u1 32) # Remainder: u1 = (un0 + un21*b - q0*v) >> s (prinst "add" @u1 @u1 @un0) (prinst "mulld" 0 @q0 @v) (prinst "sub" @u1 @u1 0) (prinst "srd" @u1 @u1 @s) (prinst "blr") (prinl "divOvfl:") (prinst "li" @u0 -1) # Overflow (prinst "li" @u1 -1) (prinst "blr") ) ) (prinl) (let R 28 # 'cc' uses 27 as argument pointer (for F 8 (label (pack "flt" F)) (unless (= 8 F) (prinst "addi" 11 11 (pack "flt" (inc F) "-flt" F)) ) (prinst "srdi" 0 0 4) # Scale (ignore sign) (prinst "std" 0 "0(27)") (prinst "ld" R "8(27)") # Value (prinst "andi." 0 R "0x02") # Short? (prinst "beq-" "2f") # No (prinst "lfd" 0 "0(27)") # Get scale in f13 (prinst "fcfid" 13 0) (prinst "andi." 0 R "0x08") # Value negative? (prinst "srdi" R R 4) # Scale value (prinst "beq-" "1f") (prinst "neg" R R) # Negate (prinl "1:") (prinst "std" R "8(27)") # Get value (prinst "lfd" 0 "8(27)") (prinst "fcfid" F 0) (prinst "fdiv" F F 13) # Divide by scale (prinst "stfd" F "8(27)") (prinst "blr") (prinl "2:") # T or NIL (prinst "cmpd" 25 R) # Nil? (prinst "li" R (hex "7FF")) # inf (prinst "bne-" ".+8") (prinst "li" R (hex "FFF")) # -inf (prinst "rotrdi" R R 12) (prinst "std" R "8(27)") # Get value (prinst "lfd" 0 "8(27)") (prinst "blr") ) ) (prinl) (label "begin") (prinst "std" 14 "-144(1)") (prinst "std" 15 "-136(1)") (prinst "std" 16 "-128(1)") (prinst "std" 17 "-120(1)") (prinst "std" 18 "-112(1)") (prinst "std" 19 "-104(1)") (prinst "std" 20 "-96(1)") (prinst "std" 21 "-88(1)") (prinst "std" 22 "-80(1)") (prinst "std" 23 "-72(1)") (prinst "std" 24 "-64(1)") (prinst "std" 25 "-56(1)") (prinst "std" 26 "-48(1)") (prinst "std" 27 "-40(1)") (prinst "std" 28 "-32(1)") (prinst "std" 29 "-24(1)") (prinst "std" 30 "-16(1)") (prinst "std" 31 "-8(1)") (prinst "std" 0 "16(1)") (prinst "stdu" 1 "-256(1)") (prinst "li" 20 0) # Init NULL register (prinst "li" 21 1) # Init ONE register (prinst "ld" 22 "Data@got(2)") # Globals bases (prinst "ld" 23 "Code@got(2)") (prinst "la" 25 "Nil-Data(22)") # Nil (prinst "mr" 18 8) # Z (prinst "mr" 17 7) # Y (prinst "mr" 16 6) # X (prinst "mr" 15 5) # E (prinst "mr" 14 4) # C (prinst "blr") (prinl) (label "return") (prinst "addi" 1 1 256) (prinst "ld" 14 "-144(1)") (prinst "ld" 15 "-136(1)") (prinst "ld" 16 "-128(1)") (prinst "ld" 17 "-120(1)") (prinst "ld" 18 "-112(1)") (prinst "ld" 19 "-104(1)") (prinst "ld" 20 "-96(1)") (prinst "ld" 21 "-88(1)") (prinst "ld" 22 "-80(1)") (prinst "ld" 23 "-72(1)") (prinst "ld" 24 "-64(1)") (prinst "ld" 25 "-56(1)") (prinst "ld" 26 "-48(1)") (prinst "ld" 27 "-40(1)") (prinst "ld" 28 "-32(1)") (prinst "ld" 29 "-24(1)") (prinst "ld" 30 "-16(1)") (prinst "ld" 31 "-8(1)") (prinst "ld" 0 "16(1)") (prinst "mtlr" 0) (prinst "blr") ) ) (asm initMain () (prinst ".quad" ".+24" ".TOC.@tocbase" 0) (prinst "li" 20 0) # Init NULL register (prinst "li" 21 1) # Init ONE register (prinst "ld" 22 "Data@got(2)") # Globals bases (prinst "ld" 23 "Code@got(2)") (prinst "la" 25 "Nil-Data(22)") # Nil (prinst "ld" 16 "0(4)") # Get command in X (prinst "la" 17 "8(4)") # argument vector in Y (prinst "subi" 3 3 1) # and pointer to last argument in Z (prinst "sldi" 3 3 3) (prinst "add" 18 4 3) ) (asm initLib ()) ### Optimizer ### # Replace the the next 'cnt' elements with 'lst' (de optimize (Lst) #> (cnt . lst) (when (noCC L) (cons 1 (cons (cons @ (cdar L)))) ) ) ### Decoration ### (de prolog (File) (when *FPic (in "ppc64.symtab" (balance '*DataIndex (read)) (balance '*CodeIndex (read)) ) ) ) (de epilog (File) (unless *FPic (out "ppc64.symtab" (println (sort *DataLabels)) (println (sort *CodeLabels)) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/arch/x86-64.l0000644000000000000000000007075312265263724016073 0ustar rootroot# 05jan13abu # (c) Software Lab. Alexander Burger # Byte order (on *LittleEndian) (off *AlignedCode) # Register assignments (de *Registers (A . "%rax") (C . "%rdx") (E . "%rbx") (B . "%al") (D "%rax" . "%rdx") (X . "%r13") (Y . "%r14") (Z . "%r15") (L . "%rbp") (S . "%rsp") (F . T) ) # NULL: %r12 # Temporary: %r10 %r11 # Block operations: %rcx %rsi %rdi # C arguments: %rdi %rsi %rdx %rcx %r8 %r9 # Addressing modes (de byteReg (Reg) (cdr (assoc Reg (quote ("%rax" . "%al") ("%al" . "%al") ("%rdx" . "%dl") ("%rbx" . "%bl") ("%r12" . "%r12b") ("%r13" . "%r13b") ("%r14" . "%r14b") ("%r15" . "%r15b") ("%rbp" . "%bpl") ("%rsp" . "%spl") ) ) ) ) (de byteVal (Adr) (if (= "%r12" Adr) "$0" # %r12b needs 3 bytes (or (byteReg Adr) # Register Adr ) ) ) # Byte address (de lowByte (Adr) (or (byteReg Adr) # Register Adr ) ) # Word address (de highWord (S) (cond ((= `(char "(") (char S)) (pack "8" S) ) ((>= `(char "9") (char S) `(char "0")) (pack "8+" S) ) (T (pack S "+8")) ) ) (de immediate (Src) (setq Src (chop Src)) (when (= "$" (pop 'Src)) (and (= "~" (car Src)) (pop 'Src)) (format Src) ) ) (de target (Adr F) (if (or (not *FPic) (= `(char ".") (char Adr)) # Local label ".1" (let A (split (chop Adr) "_") # Local jump "foo_22" (and (cdr A) (= *Label (pack (glue "_" (head -1 A)))) (format (last A)) ) ) ) Adr (ifn F (pack Adr "@plt") (prinst "mov" (pack Adr "@GOTPCREL(%rip)") "%r10") "(%r10)") ) ) (de src (Src S) (cond ((=0 S) (if (= "0" Src) "%r12" (pack "$" Src))) # Immediate ((not S) Src) # Register ((=T S) # Direct (if (and *FPic (not (pre? "(" Src))) (pack Src "@GOTPCREL(%rip)") (pack "$" Src) ) ) ((not (car S)) (ifn (and *FPic (=T (cdr S))) (pack (cdr Src) "(" (car Src) ")") (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") (car Src)) (pack "(" (car Src) ")") ) ) ((=T (car S)) (ifn *FPic (if (cdr S) (pack (car Src) "+" (cdr Src)) (car Src) ) (prinst "mov" (pack (car Src) "@GOTPCREL(%rip)") "%r10") (pack (cdr Src) "(%r10)") ) ) (T (prinst "mov" (src (car Src) (car S)) "%r10") (ifn (and *FPic (=T (cdr S))) (pack (cdr Src) "(%r10)") (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") "%r10") "(%r10)" ) ) ) ) (de lea (Src S Reg) (cond ((not S) (prinst "mov" Src Reg)) # Register ((=T S) (prinst "mov" (src Src T) Reg)) # Direct ((not (car S)) (cond ((and *FPic (=T (cdr S))) (prinst "add" (pack (cdr Src) "@GOTPCREL(%rip)") (car Src)) (prinst "mov" (pack "(" (car Src) ")") Reg) ) ((cdr Src) (prinst "lea" (pack (cdr Src) "(" (car Src) ")") Reg) ) (T (prinst "mov" (car Src) Reg)) ) ) ((=T (car S)) (ifn *FPic (prinst "lea" (if (cdr S) (pack (car Src) "+" (cdr Src)) (car Src) ) Reg ) (prinst "mov" (pack (car Src) "@GOTPCREL(%rip)") Reg) (prinst "lea" (pack (cdr Src) "(%r10)") Reg) ) ) (T (if (cdr S) (prinst "lea" (src Src S) Reg) (prinst "mov" (src (car Src) (car S)) Reg) ) ) ) ) (de dst (Dst D) (cond ((not D) Dst) # Register ((not (car D)) (ifn (and *FPic (=T (cdr D))) (pack (cdr Dst) "(" (car Dst) ")") (prinst "add" (pack (cdr Dst) "@GOTPCREL(%rip)") (car Dst)) (pack "(" (car Dst) ")") ) ) ((=T (car D)) (ifn *FPic (if (cdr D) (pack (car Dst) "+" (cdr Dst)) (car Dst) ) (prinst "mov" (pack (car Dst) "@GOTPCREL(%rip)") "%r11") (pack (cdr Dst) "(%r11)") ) ) (T (prinst "mov" (dst (car Dst) (car D)) "%r11") (ifn (and *FPic (=T (cdr D))) (pack (cdr Dst) "(%r11)") (prinst "add" (pack (cdr Dst) "@GOTPCREL(%rip)") "%r11") "(%r11)" ) ) ) ) (de dstSrc (Cmd Dst Src) (cond ((= "%al" Dst) (prinst Cmd (byteVal Src) "%al") ) ((= "%al" Src) (prinst Cmd "%al" (byteVal Dst)) ) ((and (immediate Src) (not (>= 2147483647 @ -2147483648))) (prinst "mov" Src "%r10") (prinst Cmd "%r10" Dst) ) ((or (pre? "%" Src) (pre? "%" Dst)) (prinst Cmd Src Dst) ) ((pre? "$" Src) (prinst (pack Cmd "q") Src Dst) ) (T (prinst "mov" Src "%r10") (prinst Cmd "%r10" Dst) ) ) ) (de dstSrcByte (Cmd Dst Src) (if (>= 255 (immediate Src) 0) (prinst (pack Cmd "b") Src (lowByte Dst)) (dstSrc Cmd Dst Src) ) ) (de dstDst (Cmd Dst Dst2) (cond ((= "%al" Dst) (prinst Cmd (byteVal Dst2) "%al") ) ((= "%al" Dst2) (prinst Cmd "%al" (byteVal Dst)) ) ((or (pre? "%" Dst) (pre? "%" Dst2)) (prinst Cmd Dst2 Dst) ) ((sub? "%r10" Dst2) (prinst "mov" Dst "%r11") (prinst Cmd "%r11" Dst2) (prinst "mov" "%r11" Dst) ) (T (prinst "mov" Dst "%r10") (prinst Cmd "%r10" Dst2) (prinst "mov" "%r10" Dst) ) ) ) (de dstShift (Cmd Dst Src) (if (pre? "$" Src) (prinst (pack Cmd (unless (pre? "%" Dst) "q")) Src Dst) (prinst "mov" (byteVal Src) "%cl") (prinst (pack Cmd (unless (pre? "%" Dst) "q")) "%cl" Dst) ) ) ### Instruction set ### (de alignSection (Align) (prinst ".balign" 16) ((; 'skip asm) Align) ) (asm nop () (prinst "nop") ) (asm align (N) (prinst ".balign" N) ) (asm skip (N) (if (== 'data *Section) (or (=0 N) (prinst ".space" N)) (do N (prinst "nop")) ) ) # Move data (asm ld (Dst D Src S) (setq Dst (dst Dst D) Src (src Src S)) (cond ((= "%al" Dst) (prinst "mov" (byteVal Src) "%al") ) ((= "%al" Src) (prinst "mov" "%al" (byteVal Dst)) ) ((pair Dst) (prinst "mov" Src (car Dst)) (prinst "mov" (if (=0 S) "%r12" (highWord Src)) (cdr Dst)) ) ((pair Src) (prinst "mov" (car Src) Dst) (prinst "mov" (cdr Src) (highWord Dst)) ) ((or (pre? "%" Src) (pre? "%" Dst)) (prinst "mov" Src Dst) ) ((pre? "$" Src) (prinst "movq" Src Dst) ) (T (prinst "mov" Src "%r10") (prinst "mov" "%r10" Dst) ) ) ) (asm ld2 (Src S) (prinst "movzwq" (src Src S) "%rax") ) (asm ld4 (Src S) (prinst "mov" (src Src S) "%eax") ) # Clears upper word of %rax (de _cmov (Cmd Jmp) (setq Dst (dst Dst D) Src (src Src S)) (when (pre? "$" Src) (prinst "mov" Src "%r10") (setq Src "%r10") ) (if (pre? "%" Dst) (prinst Cmd Src Dst) (warn "Using suboptimal emulation code") (prinst Jmp "1f") (if (pre? "%" Src) (prinst "mov" Src Dst) (prinst "mov" Src "%r10") (prinst "mov" "%r10" Dst) ) (prinl "1:") ) ) (asm ldc (Dst D Src S) (_cmov "cmovcq" "jnc") ) (asm ldnc (Dst D Src S) (_cmov "cmovncq" "jc") ) (asm ldz (Dst D Src S) (_cmov "cmovzq" "jnz") ) (asm ldnz (Dst D Src S) (_cmov "cmovnzq" "jz") ) (asm lea (Dst D Src S) (setq Dst (dst Dst D) Src (src Src S)) (if (pre? "%" Dst) (prinst "lea" Src Dst) (prinst "lea" Src "%r10") (prinst "mov" "%r10" Dst) ) ) (asm st2 (Dst D) (prinst "mov" "%ax" (dst Dst D)) ) (asm st4 (Dst D) (prinst "mov" "%eax" (dst Dst D)) ) (asm xchg (Dst D Dst2 D2) (dstDst "xchg" (dst Dst D) (src Dst2 D2)) ) (asm movn (Dst D Src S Cnt C) (lea Dst D "%rdi") (lea Src S "%rsi") (prinst "mov" (src Cnt C) "%rcx") (prinst "cld") (prinst "rep movsb") ) (asm mset (Dst D Cnt C) (setq Dst (dst Dst D)) (prinst (if (pre? "%" Dst) "mov" "lea") Dst "%rdi") (prinst "mov" (src Cnt C) "%rcx") (prinst "cld") (prinst "rep stosb") ) (asm movm (Dst D Src S End E) (lea Dst D "%rdi") (lea Src S "%rsi") (lea End E "%rcx") (prinst "sub" "%rsi" "%rcx") (prinst "shr" "$3" "%rcx") (prinst "cld") (prinst "rep movsq") ) (asm save (Src S End E Dst D) (lea Src S "%rsi") (lea End E "%rcx") (lea Dst D "%rdi") (prinst "sub" "%rsi" "%rcx") (prinst "shr" "$3" "%rcx") (prinst "cld") (prinst "rep movsq") ) (asm load (Dst D End E Src S) (lea Dst D "%rdi") (lea End E "%rcx") (lea Src S "%rsi") (prinst "sub" "%rdi" "%rcx") (prinst "shr" "$3" "%rcx") (prinst "cld") (prinst "rep movsq") ) # Arithmetics (asm add (Dst D Src S) (setq Dst (dst Dst D) Src (src Src S)) (ifn (pair Dst) (dstSrc "add" Dst Src) (prinst "add" Src (car Dst)) (prinst "adc" "%r12" (cdr Dst)) ) ) (asm addc (Dst D Src S) (setq Dst (dst Dst D) Src (src Src S)) (ifn (pair Dst) (dstSrc "adc" Dst Src) (prinst "adc" Src (car Dst)) (prinst "adc" "%r12" (cdr Dst)) ) ) (asm sub (Dst D Src S) (setq Dst (dst Dst D) Src (src Src S)) (ifn (pair Dst) (dstSrc "sub" Dst Src) (prinst "sub" Src (car Dst)) (prinst "sbb" "%r12" (cdr Dst)) ) ) (asm subc (Dst D Src S) (setq Dst (dst Dst D) Src (src Src S)) (ifn (pair Dst) (dstSrc "sbb" Dst Src) (prinst "sbb" Src (car Dst)) (prinst "sbb" "%r12" (cdr Dst)) ) ) (asm inc (Dst D) (if (pre? "%" (setq Dst (dst Dst D))) (prinst "inc" Dst) (prinst "incq" Dst) ) ) (asm dec (Dst D) (if (pre? "%" (setq Dst (dst Dst D))) (prinst "dec" Dst) (prinst "decq" Dst) ) ) (asm not (Dst D) (if (pre? "%" (setq Dst (dst Dst D))) (prinst "not" Dst) (prinst "notq" Dst) ) ) (asm neg (Dst D) (if (pre? "%" (setq Dst (dst Dst D))) (prinst "neg" Dst) (prinst "negq" Dst) ) ) (asm and (Dst D Src S) (dstSrc "and" (dst Dst D) (src Src S)) ) (asm or (Dst D Src S) (dstSrcByte "or" (dst Dst D) (src Src S)) ) (asm xor (Dst D Src S) (dstSrcByte "xor" (dst Dst D) (src Src S)) ) (asm off (Dst D Src S) (dstSrcByte "and" (dst Dst D) (src Src S)) ) (asm test (Dst D Src S) (dstSrcByte "test" (dst Dst D) (src Src S)) ) (asm shl (Dst D Src S) (dstShift "shl" (dst Dst D) (src Src S)) ) (asm shr (Dst D Src S) (dstShift "shr" (dst Dst D) (src Src S)) ) (asm rol (Dst D Src S) (dstShift "rol" (dst Dst D) (src Src S)) ) (asm ror (Dst D Src S) (dstShift "ror" (dst Dst D) (src Src S)) ) (asm rcl (Dst D Src S) (dstShift "rcl" (dst Dst D) (src Src S)) ) (asm rcr (Dst D Src S) (dstShift "rcr" (dst Dst D) (src Src S)) ) (asm mul (Src S) (ifn (pre? "$" (setq Src (src Src S))) (prinst "mulq" Src) (prinst "mov" Src "%r10") (prinst "mul" "%r10") ) ) (asm div (Src S) (ifn (pre? "$" (setq Src (src Src S))) (prinst "divq" Src) (prinst "mov" Src "%r10") (prinst "div" "%r10") ) ) (asm zxt () # 8 bit -> 64 bit (prinst "movzx" "%al" "%rax") ) (asm setz () (prinst "or" "%r12" "%r12") ) (asm clrz () (prinst "cmp" "%rsp" "%r12") ) (asm setc () (prinst "stc") ) (asm clrc () (prinst "clc") ) # Comparisons (asm cmp (Dst D Src S) (dstSrc "cmp" (dst Dst D) (src Src S)) ) (asm cmpn (Dst D Src S Cnt C) (setq Dst (dst Dst D)) (prinst (if (pre? "%" Dst) "mov" "lea") Dst "%rsi") (lea Src S "%rdi") (prinst "mov" (src Cnt C) "%rcx") (prinst "cld") (prinst "repnz cmpsb") ) (asm slen (Dst D Src S) (setq Dst (dst Dst D)) (prinst "cld") (prinst "xor" "%rcx" "%rcx") (prinst "not" "%rcx") (lea Src S "%rdi") (prinst "xchg" "%al" "%r12b") (prinst "repnz scasb") (prinst "xchg" "%al" "%r12b") (prinst "not" "%rcx") (prinst "dec" "%rcx") (prinst "mov" "%rcx" Dst) ) (asm memb (Src S Cnt C) (prinst "cld") (lea Src S "%rdi") (setq Cnt (src Cnt C)) (prinst "mov" Cnt "%rcx") (prinst "repnz scasb") (unless S (prinst "cmovzq" "%rdi" Src)) (unless C (prinst "cmovzq" "%rcx" Cnt)) ) (asm null (Src S) (prinst "cmp" "%r12" (src Src S)) ) (asm nulp (Src S) (prinst "cmp" "%r12" (src Src S)) ) (asm nul4 () (prinst "cmp" "%r12d" "%eax") ) # Byte addressing (asm set (Dst D Src S) (setq Dst (dst Dst D) Src (src Src S)) (cond ((= "%r12" Src) (prinst "mov" "%r12b" (lowByte Dst)) ) ((or (pre? "$" Src) (pre? "%" Src) (pre? "%" Dst)) (prinst "movb" Src Dst) ) (T (prinst "mov" Src "%r10b") (prinst "mov" "%r10b" Dst) ) ) ) (asm nul (Src S) (prinst "cmp" "%r12b" (src Src S)) ) # Types (asm cnt (Src S) (prinst "testb" "$0x02" (lowByte (src Src S))) ) (asm big (Src S) (prinst "testb" "$0x04" (lowByte (src Src S))) ) (asm num (Src S) (prinst "testb" "$0x06" (lowByte (src Src S))) ) (asm sym (Src S) (prinst "testb" "$0x08" (lowByte (src Src S))) ) (asm atom (Src S) (prinst "testb" "$0x0E" (lowByte (src Src S))) ) # Flow Control (asm call (Adr A) (nond (A # Absolute (prinst "call" (target Adr)) ) ((=T A) # Ignore SUBR (prinst "call" (pack "*" Adr)) ) (NIL # Indirect (prinst "mov" (target Adr T) "%r10") (prinst "call" "*%r10") ) ) ) (asm jmp (Adr A) (nond (A (prinst "jmp" (target Adr))) ((=T A) # Ignore SUBR (prinst "jmp" (pack "*" Adr)) ) (NIL (prinst "mov" (target Adr T) "%r10") (prinst "jmp" "*%r10") ) ) ) (de _jmp (Opc Opc2) (ifn A (prinst Opc (target Adr)) (prinst Opc2 "1f") (ifn (=T A) # Ignore SUBR (prinst "jmp" (pack "*" Adr)) (prinst "mov" (target Adr T) "%r10") (prinst "jmp" "*%r10") ) (prinl "1:") ) ) (asm jz (Adr A) (_jmp "jz" "jnz") ) (asm jeq (Adr A) (_jmp "jz" "jnz") ) (asm jnz (Adr A) (_jmp "jnz" "jz") ) (asm jne (Adr A) (_jmp "jnz" "jz") ) (asm js (Adr A) (_jmp "js" "jns") ) (asm jns (Adr A) (_jmp "jns" "js") ) (asm jsz (Adr A) (_jmp "jle" "jg") ) (asm jnsz (Adr A) (_jmp "jg" "jle") ) (asm jc (Adr A) (_jmp "jc" "jnc") ) (asm jlt (Adr A) (_jmp "jc" "jnc") ) (asm jnc (Adr A) (_jmp "jnc" "jc") ) (asm jge (Adr A) (_jmp "jnc" "jc") ) (asm jcz (Adr A) (_jmp "jbe" "ja") ) (asm jle (Adr A) (_jmp "jbe" "ja") ) (asm jncz (Adr A) (_jmp "ja" "jbe") ) (asm jgt (Adr A) (_jmp "ja" "jbe") ) (asm ret () (unless (and (seek '((L) (== (cadr L) *Statement)) *Program) (not (memq (caar @) '`(cons ': (cdr *Transfers)))) ) (prinst "rep") ) (prinst "ret") ) # Floating point (asm ldd () (prinst "movsd" "(%rdx)" "%xmm0") ) (asm ldf () (prinst "movss" "(%rdx)" "%xmm0") ) (asm fixnum () (prinst "shr" "$4" "%rbx") # Normalize scale (prinst "jc" "1f") # Jump if negative (prinst "cvtsi2sd" "%rbx" "%xmm7") # Mulitply double with scale (prinst "mulsd" "%xmm7" "%xmm0") (prinst "cvtsd2si" "%xmm0" "%rbx") # Convert to integer (prinst "jmp" "2f") (prinl "1:") (prinst "cvtsi2ss" "%rbx" "%xmm7") # Mulitply float with scale (prinst "mulss" "%xmm7" "%xmm0") (prinst "cvtss2si" "%xmm0" "%rbx") # Convert to integer (prinl "2:") (prinst "or" "%rbx" "%rbx") # Negative? (prinst "js" "3f") # Yes: Skip (prinst "shl" "$4" "%rbx") # Make positive short (prinst "orb" "$2" "%bl") (prinst "jmp" "5f") (prinl "3:") (prinst "neg" "%rbx") # Negate (prinst "js" "4f") # Still negative: Overflow (prinst "shl" "$4" "%rbx") # Make negative short (prinst "orb" "$10" "%bl") (prinst "jmp" "5f") (prinl "4:") # Infinite/NaN (prinst "mov" "$Nil" "%rbx") # Preload NIL (prinst "xorpd" "%xmm7" "%xmm7") # Float value negative? (prinst "ucomisd" "%xmm7" "%xmm0") (prinst "jc" "5f") # Yes: Skip (prinst "mov" "$TSym" "%rbx") # Load T (prinl "5:") ) (asm float () (prinst "mov" "%rax" "%r10") # Normalize scale (prinst "shr" "$4" "%r10") # Negative? (prinst "jc" "3f") # Yes: Skip (prinst "testb" "$0x02" "(%r13)") # Short fixnum? (prinst "jz" "2f") # No: Skip (prinst "cvtsi2sd" "%r10" "%xmm7") # Convert scale (prinst "mov" "(%r13)" "%r10") # Normalize fixnum (prinst "shr" "$4" "%r10") # Negative? (prinst "jnc" "1f") # No: Skip (prinst "neg" "%r10") # Else negate (prinl "1:") (prinst "cvtsi2sd" "%r10" "%xmm0") # Convert fixnum to double (prinst "divsd" "%xmm7" "%xmm0") # Divide by scale (prinst "jmp" "4f") # Done (prinl "2:") (prinst "cmpq" "$Nil" "(%r13)") # Minus infinite? (prinst "mov" "$0x7FF0000000000000" "%r10") (prinst "jnz" "1f") # No: Skip (prinst "mov" "$0xFFF0000000000000" "%r10") (prinl "1:") (prinst "push" "%r10") (prinst "movsd" "(%rsp)" "%xmm0") (prinst "add" "$8" "%rsp") (prinst "jmp" "4f") # Done (prinl "3:") (prinst "testb" "$0x02" "(%r13)") # Short fixnum? (prinst "jz" "2f") # No: Skip (prinst "cvtsi2ss" "%r10" "%xmm7") # Convert scale (prinst "mov" "(%r13)" "%r10") # Normalize fixnum (prinst "shr" "$4" "%r10") # Negative? (prinst "jnc" "1f") # No: Skip (prinst "neg" "%r10") # Else negate (prinl "1:") (prinst "cvtsi2ss" "%r10" "%xmm0") # Convert fixnum to float (prinst "divss" "%xmm7" "%xmm0") # Divide by scale (prinst "jmp" "4f") # Done (prinl "2:") (prinst "cmpq" "$Nil" "(%r13)") # Minus infinite? (prinst "mov" "$0x7F800000" "%r10") (prinst "jnz" "1f") (prinst "mov" "$0xFF800000" "%r10") (prinl "1:") (prinst "push" "%r10") (prinst "movss" "(%rsp)" "%xmm0") (prinst "add" "$8" "%rsp") (prinl "4:") ) (asm std () (prinst "movsd" "%xmm0" "(%r15)") ) (asm stf () (prinst "movss" "%xmm0" "(%r15)") ) # C-Calls (asm cc (Adr A Arg M) (unless (== 'cc (caar (seek '((L) (== (cadr L) *Statement)) *Program))) (prinst "mov" "%rdx" "%r12") ) (let Reg '("%rdi" "%rsi" "%rdx" "%rcx" "%r8" "%r9") (if (lst? Arg) (let Lea NIL (mapc '((Src S) (if (== '& Src) (on Lea) (unless (and (=0 S) (= "0" Src)) # Keep for 'xor' later (setq Src (src (recur (Src) (cond ((= "%rdx" Src) "%r12") ((atom Src) Src) (T (cons (recurse (car Src)) (recurse (cdr Src)))) ) ) S ) ) ) (cond ((and (=0 S) (= "0" Src)) (prinst "xor" (car Reg) (pop 'Reg)) ) ((= "$pop" Src) (prinst "pop" (pop 'Reg)) ) (T (prinst (if Lea "lea" "mov") Src (pop 'Reg))) ) (off Lea) ) ) (head 6 Arg) (head 6 M) ) (prinst "push" "%rbp") (prinst "mov" "%rsp" "%rbp") (when (nth Arg 7) # Maximally 6 args in registers (prinst "sub" (pack "$" (* 8 (length @))) "%rsp") ) (prinst "andb" "$~15" "%spl") # Align stack (let Ofs 0 (mapc # 'Src' not lea or stack-relative here! '((Src S) (unless (and (=0 S) (= "0" Src)) # Keep for 'xor' later (setq Src (src (recur (Src) (cond ((= "%rdx" Src) "%r12") ((atom Src) Src) (T (cons (recurse (car Src)) (recurse (cdr Src)))) ) ) S ) ) ) (ifn (and (=0 S) (= "0" Src)) (prinst "movq" Src (pack Ofs "(%rsp)")) (prinst "xor" "%rax" "%rax") (prinst "movq" "%rax" (pack Ofs "(%rsp)")) ) (inc 'Ofs 8) ) (nth Arg 7) (nth M 7) ) ) # Don't use SSE registers in varargs for static calls (when (member Adr '("printf" "fprintf" "snprintf" "open" "fcntl")) (prinst "xor" "%al" "%al") ) ) (prinst "mov" "%rsp" "%rax") # A on arguments (prinst "push" "%rbp") # Link (prinst "mov" "%rsp" "%rbp") (prinst "mov" Arg "%rbx") (prinst "sub" "%rax" "%rbx") # Size of arguments (prinst "sub" "%rbx" "%rsp") # Allocate space (prinst "andb" "$~15" "%spl") # Align stack (prinst "mov" "%rsp" "%rbx") # E on stack space (prinst "lea" "5f(%rip)" "%r11") (mapc '((R X) (prinl "1:") (prinst "cmp" "%rax" Arg) (prinst "jz" "9f") (prinst "mov" "(%rax)" "%r10") (prinst "add" "$16" "%rax") (prinst "or" "%r10" "%r10") (prinst "jz" "7f") (prinst "call" "*%r11") (prinst "jmp" "1b") (prinl "5:") (unless (= R "%r9") (prinst "lea" "(5f-5b)(%r11)" "%r11") ) (prinst "shr" "$4" "%r10") (prinst "jc" "3f") (prinst "testb" "$0x02" "-8(%rax)") (prinst "jz" "2f") (prinst "cvtsi2sd" "%r10" "%xmm7") (prinst "mov" "-8(%rax)" "%r10") (prinst "shr" "$4" "%r10") (prinst "jnc" "1f") (prinst "neg" "%r10") (prinl "1:") (prinst "cvtsi2sd" "%r10" X) (prinst "divsd" "%xmm7" X) (prinst "ret") (prinl "2:") (prinst "cmpq" "$Nil" "-8(%rax)") (prinst "mov" "$0x7FF0000000000000" "%r10") (prinst "jnz" "1f") (prinst "mov" "$0xFFF0000000000000" "%r10") (prinl "1:") (prinst "mov" "%r10" "-8(%rax)") (prinst "movsd" "-8(%rax)" X) (prinst "ret") (prinl "3:") (prinst "testb" "$0x02" "-8(%rax)") (prinst "jz" "2f") (prinst "cvtsi2ss" "%r10" "%xmm7") (prinst "mov" "-8(%rax)" "%r10") (prinst "shr" "$4" "%r10") (prinst "jnc" "1f") (prinst "neg" "%r10") (prinl "1:") (prinst "cvtsi2ss" "%r10" X) (prinst "divss" "%xmm7" X) (prinst "ret") (prinl "2:") (prinst "cmpq" "$Nil" "-8(%rax)") (prinst "mov" "$0x7F800000" "%r10") (prinst "jnz" "1f") (prinst "mov" "$0xFF800000" "%r10") (prinl "1:") (prinst "mov" "%r10" "-8(%rax)") (prinst "movss" "-8(%rax)" X) (prinst "ret") (prinl "7:") (prinst "mov" "-8(%rax)" R) ) Reg '("%xmm0" "%xmm1" "%xmm2" "%xmm3" "%xmm4" "%xmm5") ) (prinl "1:") (prinst "cmp" "%rax" Arg) (prinst "jz" "9f") (prinst "mov" "8(%rax)" "%r10") (prinst "add" "$16" "%rax") (prinst "mov" "%r10" "(%rbx)") (prinst "add" "$8" "%rbx") (prinst "jmp 1b") (prinl "9:") # Maximally 6 SSE registers in varargs for dynamic calls (prinst "mov" "$6" "%al") ) ) ((get 'call 'asm) Adr A) (prinst "mov" "%rbp" "%rsp") (prinst "pop" "%rbp") (unless (== 'cc (caadr (memq *Statement *Program))) (prinst "mov" "%r12" "%rdx") (prinst "xor" "%r12" "%r12") ) ) (asm func ()) (asm begin () (prinst "call" "begin") ) (asm return () (prinst "jmp" "return") ) # Stack Manipulations (asm push (Src S) (setq Src (src Src S)) (cond ((=T Src) (prinst "pushf")) ((pre? "%" Src) (prinst "push" Src)) (T (prinst "pushq" Src)) ) ) (asm pop (Dst D) (setq Dst (dst Dst D)) (cond ((=T Dst) (prinst "popf")) ((pre? "%" Dst) (prinst "pop" Dst)) (T (prinst "popq" Dst)) ) ) (asm link () (prinst "push" "%rbp") (prinst "mov" "%rsp" "%rbp") ) (asm tuck (Src S) (setq Src (src Src S)) (prinst "mov" "(%rsp)" "%rbp") (if (or (pre? "$" Src) (pre? "%" Src)) (prinst "movq" Src "(%rsp)") (prinst "mov" Src "%r10") (prinst "mov" "%r10" "(%rsp)") ) ) (asm drop () (prinst "mov" "(%rbp)" "%rsp") (prinst "pop" "%rbp") ) # Evaluation (asm eval () (prinst "test" "$0x06" "%bl") # Number? (prinst "jnz" "1f") # Yes: Skip (prinst "test" "$0x08" "%bl") # Symbol? (prinst "cmovnzq" "(%rbx)" "%rbx") # Yes: Get value (prinst "jnz" "1f") # and skip (prinst "call" (target 'evListE_E)) # Else evaluate list (prinl "1:") ) (asm eval+ () (prinst "test" "$0x06" "%bl") # Number? (prinst "jnz" "1f") # Yes: Skip (prinst "test" "$0x08" "%bl") # Symbol? (prinst "cmovnzq" "(%rbx)" "%rbx") # Yes: Get value (prinst "jnz" "1f") # and skip (prinst "push" "%rbp") # Else 'link' (prinst "mov" "%rsp" "%rbp") (prinst "call" (target 'evListE_E)) # Evaluate list (prinst "pop" "%rbp") (prinl "1:") ) (asm eval/ret () (prinst "test" "$0x06" "%bl") # Number? (prinst "jnz" "ret") # Yes: Return (prinst "test" "$0x08" "%bl") # Symbol? (prinst "jz" 'evListE_E) # No: Evaluate list (prinst "mov" "(%rbx)" "%rbx") # Get value (prinst "ret") ) (asm exec (Reg) (prinl "1:") # do (prinst "mov" # ld E (R) (pack "(" Reg ")") "%rbx" ) (prinst "test" "$0x0E" "%bl") # atom E (prinst "jnz" "2f") (prinst "call" (target 'evListE_E)) # evList (prinl "2:") (prinst "mov" # ld R (R CDR) (pack "8(" Reg ")") Reg ) (prinst "testb" # atom R "$0x0E" (byteReg Reg) ) (prinst "jz" "1b") ) # until nz (asm prog (Reg) (prinl "1:") # do (prinst "mov" # ld E (R) (pack "(" Reg ")") "%rbx" ) (prinst "test" "$0x06" "%bl") # eval (prinst "jnz" "2f") (prinst "test" "$0x08" "%bl") (prinst "cmovnzq" "(%rbx)" "%rbx") (prinst "jnz" "2f") (prinst "call" (target 'evListE_E)) (prinl "2:") (prinst "mov" # ld R (R CDR) (pack "8(" Reg ")") Reg ) (prinst "testb" # atom R "$0x0E" (byteReg Reg) ) (prinst "jz" "1b") ) # until nz # System (asm initData ()) (asm initCode () (unless *FPic (label "begin") (prinst "pop" "%r10") # Get return address (prinst "push" "%r15") # Z (prinst "mov" "%r9" "%r15") (prinst "push" "%r14") # Y (prinst "mov" "%r8" "%r14") (prinst "push" "%r13") # X (prinst "mov" "%rcx" "%r13") (prinst "push" "%r12") (prinst "xor" "%r12" "%r12") # NULL register (prinst "push" "%rbx") (prinst "mov" "%rdx" "%rbx") # E (prinst "mov" "%rsi" "%rdx") # C (prinst "mov" "%rdi" "%rax") # A (prinst "jmp" "*%r10") # Return (prinl) (label "return") (prinst "pop" "%rbx") (prinst "pop" "%r12") (prinst "pop" "%r13") (prinst "pop" "%r14") (prinst "pop" "%r15") (prinst "ret") ) ) (asm initMain () (prinst "xor" "%r12" "%r12") # Init NULL register (prinst "mov" "(%rsi)" "%r13") # Get command in X (prinst "lea" "8(%rsi)" "%r14") # argument vector in Y (prinst "lea" "-8(%rsi,%rdi,8)" "%r15") ) # pointer to last argument in Z (asm initLib ()) ### Optimizer ### # Replace the the next 'cnt' elements with 'lst' (de optimize (Lst)) #> (cnt . lst) ### Decoration ### (de prolog (File)) (de epilog (File)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/big.l0000644000000000000000000022410412265263724015032 0ustar rootroot# 21aug13abu # (c) Software Lab. Alexander Burger ### Destructive primitives ### # Remove leading zeroes (code 'zapZeroA_A 0) push A # Save number ld C S # Short-tail in C ld E C # Null-tail in E do cnt (A BIG) # Last cell? while z # No null (A DIG) # Null digit? if nz # No ld E C # New null-tail end lea C (A BIG) # New short-tail ld A (C) # Next cell loop cmp (A BIG) ZERO # Trailing short zero? if eq # Yes ld A (A DIG) null A # Null digit? if nz # No test A (hex "F000000000000000") # Fit in short number? if z # Yes shl A 4 # Make short number or A CNT ld (C) A # Store in short-tail end else ld A ((E) DIG) # Digit in null-tail test A (hex "F000000000000000") # Fit in short number? if nz # No ld ((E) BIG) ZERO # Trim null-tail else shl A 4 # Make short number or A CNT ld (E) A # Store in null-tail end end end pop A # Result ret # Multiply (unsigned) number by 2 (code 'twiceA_A 0) cnt A # A short? if nz # Yes xor A 3 # Prepare tag bit shl A 1 # Shift left jnc Ret # Done rcr A 1 # Else normalize shr A 3 jmp boxNumA_A # Return bignum end : twiceBigA_A push A # Save bignum ld C (A DIG) # Lowest digit shl C 1 # Shift left do push F # Save carry ld (A DIG) C # Store digit ld E (A BIG) # Next cell cnt E # End of bignum? while z # No ld A E ld C (A DIG) # Next digit pop F rcl C 1 # Rotate left loop shr E 4 # Normalize pop F rcl E 1 # Rotate left test E (hex "F000000000000000") # Fit in short number? if z # Yes shl E 4 # Make short number or E CNT else call boxNumE_E # New cell end ld (A BIG) E # Store in final cell pop A # Return bignum ret # Divide (unsigned) number by 2 (code 'halfA_A 0) cnt A # A short? if nz # Yes shr A 1 # Shift right off A 9 # Clear lowest bit and tag or A CNT # Make short number ret end ld C (A DIG) # Lowest digit ld E (A BIG) # Next cell cnt E # Any? if nz # No shr E 5 # Normalize and shift right if nz # Non-empty rcr C 1 # Rotate right else rcr C 1 # Rotate right test C (hex "F000000000000000") # Fit in short number? if z # Yes shl C 4 # Return short number or C CNT ld A C ret end end ld (A DIG) C # Store lowest digit shl E 4 # Make short number or E CNT ld (A BIG) E # Store in the cell ret end push A # Save bignum do test (E DIG) 1 # Shift bit? if nz # Yes setc end rcr C 1 # Rotate right with carry ld (A DIG) C # Store digit ld C (E BIG) # More cells? cnt C while z # Yes ld A E # Advance pointers ld E C ld C (A DIG) # Next digit loop shr C 5 # Normalize and shift right if nz # Non-empty rcr (E DIG) 1 # Shift previous digit shl C 4 # Make short number or C CNT else ld C (E DIG) # Shift previous digit rcr C 1 test C (hex "F000000000000000") # Fit in short number? if z # Yes shl C 4 # Make short number or C CNT ld (A BIG) C pop A # Return bignum ret end ld (E DIG) C ld C ZERO end ld (E BIG) C # Store in the cell pop A # Return bignum ret # Multiply (unsigned) number by 10 (code 'tenfoldA_A 0) cnt A # A short? if nz # Yes shr A 4 # Normalize mul 10 # Multiply by 10 test A (hex "F000000000000000") # Fit in short number? jnz boxNumA_A # No: Return bignum shl A 4 # Make short number or A CNT ret end push X push A # Save bignum ld X A # Bignum in X ld A (X DIG) # Multiply lowest digit by 10 mul 10 do ld (X DIG) A # Store lower word ld E C # Keep upper word in E ld A (X BIG) # Next cell cnt A # End of bignum? while z # No ld X A ld A (X DIG) # Next digit mul 10 # Multiply by 10 add D E # Add previous upper word loop shr A 4 # Normalize mul 10 # Multiply by 10 add A E # Add previous upper word test A (hex "F000000000000000") # Fit in short number? if z # Yes shl A 4 # Make short number or A CNT else call boxNumA_A # Return bignum end ld (X BIG) A # Store in final cell pop A # Return bignum pop X ret ### Non-destructive primitives ### # Multiply (unsigned) number by 2 (code 'shluA_A 0) cnt A # A short? if nz # Yes xor A 3 # Prepare tag bit shl A 1 # Shift left jnc Ret # Done rcr A 1 # Else normalize shr A 3 jmp boxNumA_A # Return bignum end call boxNum_E # Build new head ld (E DIG) (A DIG) # Lowest digit link push E # Result link shl (E DIG) 1 # Shift left push F # Save carry do ld A (A BIG) # Next cell cnt A # End of bignum? while z # No call boxNum_C # Build next cell ld (E BIG) C ld E (A DIG) # Next digit pop F rcl E 1 # Rotate left push F # Save carry ld (C DIG) E ld E C loop shr A 4 # Normalize pop F rcl A 1 # Rotate left test A (hex "F000000000000000") # Fit in short number? if z # Yes shl A 4 # Make short number or A CNT else call boxNumA_A # New cell end ld (E BIG) A # Store in final cell ld A (L I) # Return bignum drop ret # Divide (unsigned) number by 2 (code 'shruA_A 0) cnt A # A short? if nz # Yes shr A 1 # Shift right off A 9 # Clear lowest bit and tag or A CNT # Make short number ret end ld E (A BIG) # Next cell cnt E # Any? if nz # No ld C (A DIG) # Lowest digit shr E 5 # Normalize and shift right if nz # Non-empty rcr C 1 # Rotate right else rcr C 1 # Rotate right test C (hex "F000000000000000") # Fit in short number? if z # Yes shl C 4 # Return short number or C CNT ld A C ret end end shl E 4 # Make short number or E CNT jmp consNumCE_A # Return bignum end call boxNum_C # Build new head ld (C DIG) (A DIG) # Lowest digit link push C # Result link do test (E DIG) 1 # Shift bit? if nz # Yes setc end rcr (C DIG) 1 # Rotate right with carry cnt (E BIG) # More cells? while z # Yes call boxNum_A # Build next digit ld (A DIG) (E DIG) ld (C BIG) A ld E (E BIG) # Advance pointers ld C A loop ld A (E BIG) # Final short number shr A 5 # Normalize and shift right if nz # Non-empty ld E (E DIG) # Shift previous digit rcr E 1 shl A 4 # Make short number or A CNT call consNumEA_E # Last cell ld (C BIG) E # Store in the cell else ld E (E DIG) # Shift previous digit rcr E 1 test E (hex "F000000000000000") # Fit in short number? if z # Yes shl E 4 # Make short number or E CNT ld (C BIG) E ld A (L I) # Return bignum drop ret end call boxNum_A # New cell ld (A DIG) E ld (C BIG) A end ld A (L I) # Return bignum drop ret # Bitwise AND of two (unsigned) numbers (code 'anduAE_A 0) cnt A # A short? if nz # Yes cnt E # E also short? if z # No ld E (E DIG) # Get digit shl E 4 # Make short number or E CNT end and A E # Return short number ret end # A is big cnt E # E short? if nz # Yes ld A (A DIG) # Get digit shl A 4 # Make short number or A CNT and A E # Return short number ret end # Both are big push X link push ZERO # Result link ld C (A DIG) # AND first digits and C (E DIG) call boxNum_X # Make bignum ld (X DIG) C ld (L I) X # Init result do ld A (A BIG) # Get tails ld E (E BIG) cnt A # End of A? if nz # Yes cnt E # Also end of E? if z # No ld E (E DIG) # Get digit shl E 4 # Make short number or E CNT end and A E # Concat short ld (X BIG) A ld A (L I) # Return bignum drop pop X jmp zapZeroA_A # Remove leading zeroes end cnt E # End of E? if nz # Yes ld A (A DIG) # Get digit shl A 4 # Make short number or A CNT and A E # Concat short ld (X BIG) A ld A (L I) # Return bignum drop pop X jmp zapZeroA_A # Remove leading zeroes end ld C (A DIG) # AND digits and C (E DIG) call consNumCE_C # New bignum cell ld (X BIG) C # Concat to result ld X C loop # Bitwise OR of two (unsigned) numbers (code 'oruAE_A 0) cnt A # A short? if nz # Yes cnt E # E also short? if nz # Yes or A E # Return short number ret end shr A 4 # Normalize or A (E DIG) # OR digit ld E (E BIG) # Rest of E jmp consNumAE_A # Append rest end # A is big cnt E # E short? if nz # Yes shr E 4 # Normalize or E (A DIG) # OR digit ld A (A BIG) # Rest of A jmp consNumEA_A # Append rest end # Both are big push X link push ZERO # Result link ld C (A DIG) # OR first digits or C (E DIG) call boxNum_X # Make bignum ld (X DIG) C ld (L I) X # Init result do ld A (A BIG) # Get tails ld E (E BIG) cnt A # End of A? if nz # Yes cnt E # Also end of E? if nz # Yes or A E # Concat short number else shr A 4 # Normalize or A (E DIG) # OR digit ld E (E BIG) # Rest of E call consNumAE_A # Append rest end ld (X BIG) A ld A (L I) # Return bignum drop pop X ret end cnt E # End of E? if nz # Yes shr E 4 # Normalize or E (A DIG) # OR digit ld A (A BIG) # Rest of A call consNumEA_A # Append rest ld (X BIG) A ld A (L I) # Return bignum drop pop X ret end ld C (A DIG) # OR digits or C (E DIG) call consNumCE_C # New bignum cell ld (X BIG) C # Concat to result ld X C loop # Bitwise XOR of two (unsigned) numbers (code 'xoruAE_A 0) cnt A # A short? if nz # Yes cnt E # E also short? if nz # Yes xor A E # Return short number or A CNT ret end shr A 4 # Normalize xor A (E DIG) # XOR digit ld E (E BIG) # Rest of E call consNumAE_A # Append rest jmp zapZeroA_A # Remove leading zeroes end # A is big cnt E # E short? if nz # Yes shr E 4 # Normalize xor E (A DIG) # XOR digit ld A (A BIG) # Rest of A call consNumEA_A # Append rest jmp zapZeroA_A # Remove leading zeroes end # Both are big push X link push ZERO # Result link ld C (A DIG) # XOR first digits xor C (E DIG) call boxNum_X # Make bignum ld (X DIG) C ld (L I) X # Init result do ld A (A BIG) # Get tails ld E (E BIG) cnt A # End of A? if nz # Yes cnt E # Also end of E? if nz # Yes xor A E # Concat short number or A CNT else shr A 4 # Normalize xor A (E DIG) # XOR digit ld E (E BIG) # Rest of E call consNumAE_A # Append rest end ld (X BIG) A ld A (L I) # Return bignum drop pop X jmp zapZeroA_A # Remove leading zeroes end cnt E # End of E? if nz # Yes shr E 4 # Normalize xor E (A DIG) # XOR digit ld A (A BIG) # Rest of A call consNumEA_A # Append rest ld (X BIG) A ld A (L I) # Return bignum drop pop X jmp zapZeroA_A # Remove leading zeroes end ld C (A DIG) # XOR digits xor C (E DIG) call consNumCE_C # New bignum cell ld (X BIG) C # Concat to result ld X C loop # Add two (unsigned) numbers (code 'adduAE_A 0) cnt A # A short? if nz # Yes cnt E # E also short? jz 10 # No: Jump off E CNT # Else clear tag add A E # Add short numbers jnc Ret # Done rcr A 1 # Get top bit shr A 3 # Normalize jmp boxNumA_A # Return bignum end # A is big cnt E # E short? if nz # Yes xchg A E # Exchange args 10 shr A 4 # Normalize short add A (E DIG) # Add first digit ld E (E BIG) # Tail in E jnc consNumAE_A # Cons new cell if no carry call consNumAE_A # Else build new head link push A # Result link do cnt E # Short number? if nz # Yes add E (hex "10") # Add carry if nc # No further carry ld (A BIG) E # Append it else # Again carry rcr E 1 # Get top bit shr E 3 # Normalize call boxNum_C # New cell ld (C DIG) E ld (A BIG) C # Append it end ld A (L I) # Return bignum drop ret end ld C (E DIG) # Next digit ld E (E BIG) add C 1 # Add carry if nc # None call consNumCE_E # New last cell ld (A BIG) E ld A (L I) # Return bignum drop ret end call consNumCE_C # New cell ld (A BIG) C # Append it ld A C # Tail of result loop end # Both are big push X link push ZERO # Result link ld C (A DIG) # Add first digits add C (E DIG) push F # Save carry call boxNum_X # Make bignum ld (X DIG) C ld (L I) X # Init result do ld A (A BIG) # Get tails ld E (E BIG) cnt A # End of A? if nz # Yes cnt E # Also end of E? jz 20 # No: Jump shr A 4 # Normalize A shr E 4 # Normalize E pop F addc A E # Add final shorts with carry shl A 4 if nc or A CNT # Make short number else # Again carry rcr A 1 # Get top bit shr A 3 # Normalize call boxNumA_A # Make bignum end ld (X BIG) A ld A (L I) # Return bignum drop pop X ret end cnt E # End of E? if nz # Yes xchg A E # Exchange args 20 shr A 4 # Normalize A pop F addc A (E DIG) # Add next digit with carry do ld E (E BIG) if nc # No carry call consNumAE_A # Append rest ld (X BIG) A ld A (L I) # Return bignum drop pop X ret end call consNumAE_A # New cell ld (X BIG) A # Concat to result ld X A # Pointer to last cell cnt E # End of E? if nz # Yes add E (hex "10") # Add carry if nc # No further carry ld (X BIG) E # Append it else # Again carry rcr E 1 # Get top bit shr E 3 # Normalize call boxNum_C # New cell ld (C DIG) E ld (X BIG) C # Append it end ld A (L I) # Return bignum drop pop X ret end ld A (E DIG) # Add carry to next digit add A 1 loop end ld C (A DIG) # Add digits pop F addc C (E DIG) push F call consNumCE_C # New bignum cell ld (X BIG) C # Concat to result ld X C loop # Subtract two (unsigned) numbers (code 'subuAE_A 0) cnt A # A short? if nz # Yes cnt E # E also short? if nz # Yes off E CNT # Clear tag sub A E # Subtract short numbers jnc Ret # Done xor A -16 # 2-complement add A (hex "18") ret end xchg A E # Exchange args call 10 # Subtract short from big cmp A ZERO # Zero? if ne # No or A SIGN # Set negative end ret end # A is big cnt E # E short? if nz # Yes 10 shr E 4 # Normalize short ld C (A DIG) sub C E # Subtract from first digit ld E (A BIG) # Tail in E if nc # No borrow cmp E ZERO # Leading zero? jne consNumCE_A # No: Cons new cell test C (hex "F000000000000000") # Fit in short number? jnz consNumCE_A # No: Cons new cell ld A C # Get digit shl A 4 # Make short number or A CNT ret end call consNumCE_A # Else build new head link push A # Result link do cnt E # Short number? if nz # Yes sub E (hex "10") # Subtract borrow if c # Again borrow: Must be the first pass ld A C # C still has lowest digit neg A # Negate shl A 4 or A (| SIGN CNT) # Make short negative number drop ret end ld (A BIG) E # Append it ld A (L I) # Return bignum drop jmp zapZeroA_A # Remove leading zeroes end ld C (E DIG) # Next digit ld E (E BIG) sub C 1 # Subtract borrow if nc # None call consNumCE_E # New last cell ld (A BIG) E # Append it ld A (L I) # Return bignum drop jmp zapZeroA_A # Remove leading zeroes end call consNumCE_C # New cell ld (A BIG) C # Append it ld A C # Tail of result loop end # Both are big push X link push ZERO # Result link ld C (A DIG) # Subtract first digits sub C (E DIG) push F # Save borrow ld A (A BIG) # Get tail call consNumCA_C # First bignum cell ld (L I) C # Init result do ld X C # Keep last cell in X ld E (E BIG) # Get tail cnt E # End of E? if nz # Yes shr E 4 # Normalize E do cnt A # Also end of A? while z # No ld C (A DIG) # Subtract final digit with borrow ld A (A BIG) # Next cell pop F subc C E # Borrow again? if nc # No call consNumCA_C # Final new bignum tail ld (X BIG) C # Concat to result 20 ld A (L I) # Return bignum drop pop X jmp zapZeroA_A # Remove leading zeroes end push F # Save borrow call consNumCA_C # New bignum tail ld (X BIG) C # Concat to result ld X C # Keep last cell ld E 0 loop shr A 4 # Normalize A break T end cnt A # End of A? if nz # Yes shr A 4 # Normalize A do pop F subc A (E DIG) # Subtract next digit with borrow push F call boxNum_C # New bignum tail ld (C DIG) A ld (X BIG) C # Concat to result ld X C # Keep last cell ld E (E BIG) # Next cell ld A 0 cnt E # Also end of E? until nz # Yes shr E 4 # Normalize E break T end ld C (A DIG) # Subtract digits pop F subc C (E DIG) push F # Save borrow ld A (A BIG) call consNumCA_C # New bignum cell ld (X BIG) C # Concat to result loop pop F subc A E # Subtract final shorts with borrow push F # Save borrow shl A 4 or A CNT # Make short number ld (X BIG) A pop F # Borrow? jnc 20 # No ld A (L I) # Get result ld E A # 2-complement do not (E DIG) # Invert ld C (E BIG) # Next digit cnt C # Done? while z # No ld E C # Next digit loop xor C -16 # Invert final short ld (E BIG) C ld E A # Result again do add (E DIG) 1 # Increment jnc 90 # Skip if no carry ld C (E BIG) # Next digit cnt C # Done? while z # No ld E C # Next digit loop add C (hex "10") # Increment final short ld (E BIG) C 90 drop pop X call zapZeroA_A # Remove leading zeroes or A SIGN # Set negative ret # Multiply two (unsigned) numbers (code 'muluAE_A 0) cnt A # A short? if nz # Yes cmp A ZERO # Multiply with zero? jeq ret # Yes: Return zero shr A 4 # Normalize cnt E # E also short? if nz # Yes xchg A E shr A 4 # Normalize mul E # Multiply null C # Only lower word? if z # Yes test A (hex "F000000000000000") # Fit in short number? if z # Yes shl A 4 # Make short number or A CNT ret end end shl C 4 # Make short number or C CNT jmp consNumAC_A # Return bignum end 10 push X push Y push Z ld Y A # Save digit in Y mul (E DIG) # Multiply lowest digit call boxNum_X # First cell ld (X DIG) A link push X # Safe link ld Z C # Keep upper word in Z do ld E (E BIG) cnt E # End of bignum? while z # No ld A (E DIG) # Get next digit mul Y # Multiply digit add D Z # Add previous upper word ld Z C call boxNum_C # Next cell ld (C DIG) A ld (X BIG) C ld X C loop ld A Y # Retrieve digit shr E 4 # Normalize mul E # Multiply add D Z # Add previous upper word if z # Only lower word test A (hex "F000000000000000") # Fit in short number? if z # Yes shl A 4 # Make short number or A CNT 20 ld (X BIG) A # Store in final cell ld A (L I) # Return bignum drop pop Z pop Y pop X ret end end shl C 4 # Make short number or C CNT call consNumAC_A # Return bignum jmp 20 end # A is big cnt E # E short? if nz # Yes cmp E ZERO # Multiply with zero? jeq ret # Yes: Return zero xchg A E # Exchange args shr A 4 # Normalize jmp 10 end # Both are big push X push Y push Z ld Y A # Arg1 in Y ld Z E # Arg2 in Z call boxNum_X # Zero bignum ld (X DIG) 0 link push X # Safe link push X # Safe index push Y # Arg1 index do ld A (Y DIG) # Multiply digits mul (Z DIG) add D (X DIG) # Add lower word to safe do ld (X DIG) A # Store lower word ld E C # Keep upper word in E ld A (X BIG) # Next safe cell cnt A # End of safe? if nz # Yes call boxNum_A # Extend safe ld (A DIG) 0 ld (X BIG) A end ld X A ld Y (Y BIG) # Next cell of Arg1 cnt Y # End of bignum? while z # No ld A (Y DIG) # Multiply digits mul (Z DIG) add D (X DIG) # Add safe addc D E # plus carry loop ld A Y # Final short number shr A 4 # Normalize mul (Z DIG) add D (X DIG) # Add safe addc D E # plus carry ld (X DIG) A if nz # Uppper word ld A (X BIG) # Next safe cell cnt A # End of safe? if nz # Yes call boxNum_A # Extend safe ld (A DIG) 0 ld (X BIG) A end ld (A DIG) C # Store uppper word end ld Y (L -II) # Get Arg1 index ld X ((L -I) BIG) # Advance safe index ld (L -I) X ld Z (Z BIG) # Next cell of Arg2 cnt Z # End of bignum? until nz # Yes ld A Z shr A 4 # Normalize ld Z A mul (Y DIG) # Multiply digit add D (X DIG) # Add lower word to safe do ld (X DIG) A # Store lower word ld E C # Keep upper word in E ld A (X BIG) # Next safe cell cnt A # End of safe? if nz # Yes call boxNum_A # Extend safe ld (A DIG) 0 ld (X BIG) A end ld X A ld Y (Y BIG) # Next cell of Arg1 cnt Y # End of bignum? while z # No ld A (Y DIG) # Multiply digit mul Z add D (X DIG) # Add safe addc D E # plus carry loop ld A Y # Final short number shr A 4 # Normalize mul Z # Multiply digit add D (X DIG) # Add safe addc D E # plus carry ld (X DIG) A if nz # Uppper word ld A (X BIG) # Next safe cell cnt A # End of safe? if nz # Yes call boxNum_A # Extend safe ld (A DIG) 0 ld (X BIG) A end ld (A DIG) C # Store uppper word end ld A (L I) # Return bignum drop pop Z pop Y pop X jmp zapZeroA_A # Remove leading zeroes # Divide two (unsigned) numbers (Knuth Vol.2, p.257) (code 'divuAE_A 0) cnt A # A short? if nz # Yes cnt E # E also short? if nz # Yes shr A 4 # Normalize A ld C 0 shr E 4 # Normalize E div E # Divide shl A 4 # Make short number or A CNT # Quotient ret end ld A ZERO # Else return zero ret end push X push Y push Z link push ZERO # Quotient push A # Dividend 'u' push E # Divisor 'v' link ld E (A DIG) # Copy dividend call boxNumE_E ld (L II) E # Save new 'u' ld X 0 # Calculate 'm' do ld A (A BIG) # Next cell of 'u' cnt A # Last one? while z # No call boxNum_C # Copy next digit ld (C DIG) (A DIG) ld (E BIG) C ld E C inc X # Increment 'm' loop cmp A ZERO # Trailing short zero? if ne # No shr A 4 # Normalize call boxNum_C # Append in new cell ld (C DIG) A ld (E BIG) C ld E C inc X # Increment 'm' end ld Z E # Keep last cell in Z push X # 'm' ld Y 0 # Last cell ld C 0 # Calculate 'n' ld A (L I) # Get divisor cnt A # Short? if nz # Yes shr A 4 # Normalize call boxNumA_A # Make big ld (L I) A # Save new 'v' ld X A # Keep in X inc C # 'n' = 1 else call boxNum_X # Copy divisor ld (X DIG) (A DIG) ld (L I) X # Save new 'v' do inc C # Increment 'n' ld A (A BIG) # Next cell of 'v' cnt A # Last one? while z # No ld E (A DIG) # Copy next digit call boxNumE_E ld (X BIG) E # Append to 'v' ld Y X # Keep last cell ld X E dec (L -I) # Decrement 'm' loop cmp A ZERO # Trailing short zero? if ne # No shr A 4 # Normalize call boxNumA_A # Append in new cell ld (X BIG) A # Append to 'v' ld Y X # Set last cell ld X A dec (L -I) # Decrement 'm' inc C # Increment 'n' end null (L -I) # 'm' negative? js divUnder # Yes end push C # 'n' ld A 0 # Append additional cell call boxNumA_A ld (Z BIG) A ld Z 0 # Calculate 'd' do null (X DIG) # Max left position? while ns # No ld A (L II) # Shift left 'u' call twiceBigA_A ld A (L I) # and 'v' call twiceBigA_A inc Z # Increment 'd' loop push Z # 'd' push (X DIG) # 'v1' null Y # Last cell? if nz # Yes ld Y (Y DIG) # Yes: Get digit end push Y # Last cell 'v2' push 0 # tmp do ld C (L -I) # Get 'm' ld X (L II) # and 'u' do sub C 1 while ge ld X (X BIG) # Index X -> u loop ld E (L -II) # Get 'n' in E ld Y X ld C 0 # 'u1' in C ld A 0 # 'u2' in A do ld (S) A # Save 'u3' im tmp ld A C # Shift words ld C (Y DIG) ld Y (Y BIG) sub E 1 until lt ld Z C # Keep 'r' = 't' in Z,Y ld Y A cmp C (L -IV) # 'u1' = 'v1'? if ne # No div (L -IV) # 'q' = 't' / 'v1' else ld A -1 # 'q' = MAX end ld E A # Save 'q' in E mul (L -IV) # 'q' * 'v1' sub Y A # Subtract from 'r' subc Z C do null Z # 'r' <= MAX? while z # Yes ld A E # 'q' * 'v2' mul (L -V) cmp C Y # > lo(r), 'u3'? while ge if eq cmp A (S) # 'u3' in tmp break le end dec E # Yes: Decrement 'q' add Y (L -IV) # Increment 'r' by 'v1' addc Z 0 loop ld (S) E # Save 'q' in tmp ld Z X # Get 'x' ld Y (L I) # 'v' ld A E # and 'q' mul (Y DIG) # Multiply lowest digit sub (Z DIG) A # Subtract from 'x' addc C 0 ld E C # Borrow in E do ld Y (Y BIG) # More in 'v'? cnt Y while z # Yes ld Z (Z BIG) # Next 'x' ld A (S) # Multiply with 'q' in tmp mul (Y DIG) # 't' in D sub (Z DIG) E # Subtract borrow ld E 0 rcl E 1 # New borrow sub (Z DIG) A # Subtract lo(t) addc E C # Adjust borrow plus hi(t) loop null E # Borrow? if nz # Yes ld Z (Z BIG) # Next 'x' sub (Z DIG) E # Subtract borrow if c dec (S) # Decrement 'q' null (L -I) # 'm' ? if nz # Yes ld Y (L I) # Get 'v' add (X DIG) (Y DIG) # 'x' += 'v' push F # Save carry do ld X (X BIG) # More? ld Y (Y BIG) cnt Y while z # Yes pop F # Get carry addc (X DIG) (Y DIG) # Add digits push F loop pop F # Final carry addc (X DIG) 0 end end end ld A (S) # Get 'q' ld C (L III) # Quotient so far call consNumAC_A # Prepend 'q' ld (L III) A # Store result sub (L -I) 1 # Decrement 'm' until lt ld A (L III) # Return quotient in A call zapZeroA_A : divDone drop pop Z pop Y pop X ret : divUnder # Dividend smaller than divisor ld A ZERO # Return quotient 0 jmp divDone # Remainder of two (unsigned) numbers (code 'remuAE_A 0) cnt A # A short? if nz # Yes cnt E # E also short? if nz # Yes shr A 4 # Normalize A ld C 0 shr E 4 # Normalize E div E # Divide ld A C # Get remainder shl A 4 # Make short number or A CNT # Quotient ret end ret # Remainder is in A end push X push Y push Z link push ZERO # Quotient push A # Dividend 'u' push E # Divisor 'v' link ld E (A DIG) # Copy dividend call boxNumE_E ld (L II) E # Save new 'u' ld X 0 # Calculate 'm' do ld A (A BIG) # Next cell of 'u' cnt A # Last one? while z # No call boxNum_C # Copy next digit ld (C DIG) (A DIG) ld (E BIG) C ld E C inc X # Increment 'm' loop cmp A ZERO # Trailing short zero? if ne # No shr A 4 # Normalize call boxNum_C # Append in new cell ld (C DIG) A ld (E BIG) C ld E C inc X # Increment 'm' end ld Z E # Keep last cell in Z push X # 'm' ld Y 0 # Last cell ld C 0 # Calculate 'n' ld A (L I) # Get divisor cnt A # Short? if nz # Yes shr A 4 # Normalize call boxNumA_A # Make big ld (L I) A # Save new 'v' ld X A # Keep in X inc C # 'n' = 1 else call boxNum_X # Copy divisor ld (X DIG) (A DIG) ld (L I) X # Save new 'v' do inc C # Increment 'n' ld A (A BIG) # Next cell of 'v' cnt A # Last one? while z # No ld E (A DIG) # Copy next digit call boxNumE_E ld (X BIG) E # Append to 'v' ld Y X # Keep last cell ld X E dec (L -I) # Decrement 'm' loop cmp A ZERO # Trailing short zero? if ne # No shr A 4 # Normalize call boxNumA_A # Append in new cell ld (X BIG) A # Append to 'v' ld Y X # Set last cell ld X A dec (L -I) # Decrement 'm' inc C # Increment 'n' end null (L -I) # 'm' negative? js remUnder # Yes end push C # 'n' ld A 0 # Append additional cell call boxNumA_A ld (Z BIG) A ld Z 0 # Calculate 'd' do null (X DIG) # Max left position? while ns # No ld A (L II) # Shift left 'u' call twiceBigA_A ld A (L I) # and 'v' call twiceBigA_A inc Z # Increment 'd' loop push Z # 'd' push (X DIG) # 'v1' null Y # Last cell? if nz # Yes ld Y (Y DIG) # Yes: Get digit end push Y # Last cell 'v2' push 0 # tmp do ld C (L -I) # Get 'm' ld X (L II) # and 'u' do sub C 1 while ge ld X (X BIG) # Index X -> u loop ld E (L -II) # Get 'n' in E ld Y X ld C 0 # 'u1' in C ld A 0 # 'u2' in A do ld (S) A # Save 'u3' im tmp ld A C # Shift words ld C (Y DIG) ld Y (Y BIG) sub E 1 until lt ld Z C # Keep 'r' = 't' in Z,Y ld Y A cmp C (L -IV) # 'u1' = 'v1'? if ne # No div (L -IV) # 'q' = 't' / 'v1' else ld A -1 # 'q' = MAX end ld E A # Save 'q' in E mul (L -IV) # 'q' * 'v1' sub Y A # Subtract from 'r' subc Z C do null Z # 'r' <= MAX? while z # Yes ld A E # 'q' * 'v2' mul (L -V) cmp C Y # > lo(r), 'u3'? while ge if eq cmp A (S) # 'u3' in tmp break le end dec E # Yes: Decrement 'q' add Y (L -IV) # Increment 'r' by 'v1' addc Z 0 loop ld (S) E # Save 'q' in tmp ld Z X # Get 'x' ld Y (L I) # 'v' ld A E # and 'q' mul (Y DIG) # Multiply lowest digit sub (Z DIG) A # Subtract from 'x' addc C 0 ld E C # Borrow in E do ld Y (Y BIG) # More in 'v'? cnt Y while z # Yes ld Z (Z BIG) # Next 'x' ld A (S) # Multiply with 'q' in tmp mul (Y DIG) # 't' in D sub (Z DIG) E # Subtract borrow ld E 0 rcl E 1 # New borrow sub (Z DIG) A # Subtract lo(t) addc E C # Adjust borrow plus hi(t) loop null E # Borrow? if nz # Yes ld Z (Z BIG) # Next 'x' sub (Z DIG) E # Subtract borrow if c dec (S) # Decrement 'q' ld Y (L I) # Get 'v' add (X DIG) (Y DIG) # 'x' += 'v' push F # Save carry do ld X (X BIG) # More? ld Y (Y BIG) cnt Y while z # Yes pop F # Get carry addc (X DIG) (Y DIG) # Add digits push F loop pop F # Final carry addc (X DIG) 0 end end ld A (S) # Get 'q' ld C (L III) # Quotient so far call consNumAC_A # Prepend 'q' ld (L III) A # Store result sub (L -I) 1 # Decrement 'm' until lt ld A (L II) # Get remainder call zapZeroA_A do null (L -III) # 'd'? while nz # Yes call halfA_A # Shift right (destructive) dec (L -III) # Decrement 'd' loop : remDone drop pop Z pop Y pop X ret : remUnder # Dividend smaller than divisor ld A (L II) # Get remainder call zapZeroA_A jmp remDone # Increment a (signed) number (code 'incE_A 0) ld A ONE test E SIGN # Positive? jz adduAE_A # Increment off E SIGN # Make positive call subuAE_A # Subtract cmp A ZERO # Zero? if ne # No or A SIGN # Negate again end ret # Decrement a (signed) number (code 'decE_A 0) ld A ONE test E SIGN # Positive? if z # Yes xchg A E jmp subuAE_A # Decrement end off E SIGN # Make positive call adduAE_A # Add or A SIGN # Negate again ret # Add two (signed) numbers (code 'addAE_A 0) test A SIGN # Positive? if z # Yes test E SIGN # Arg also positive? jz adduAE_A # Add [+ A E] off E SIGN # [+ A -E] jmp subuAE_A # Sub end # Result negatve test E SIGN # Arg positive? if z # [+ -A E] off A SIGN call subuAE_A # Sub else # [+ -A -E] off A SIGN off E SIGN call adduAE_A # Add end cmp A ZERO # Zero? if ne # No xor A SIGN # Negate end ret # Subtract to (signed) numbers (code 'subAE_A 0) test A SIGN # Positive? if z # Yes test E SIGN # Arg also positive? jz subuAE_A # Sub [- A E] off E SIGN # [- A -E] jmp adduAE_A # Add end # Result negatve test E SIGN # Arg positive? if z # [- -A E] off A SIGN call adduAE_A # Add else # [- -A -E] off A SIGN off E SIGN call subuAE_A # Sub end cmp A ZERO # Zero? if ne # No xor A SIGN # Negate end ret ### Comparisons ### (code 'cmpNumAE_F 0) test A SIGN # A positive? if z # Yes test E SIGN # E also positive? jz cmpuAE_F # Yes [A E] clrc # gt [A -E] ret end # A negative test E SIGN # E positive? if z # Yes or B B # nz [-A E] setc # lt ret end xchg A E # [-A -E] off A SIGN off E SIGN # Compare two (unsigned) numbers (code 'cmpuAE_F 0) cnt A # A short? if nz # Yes cnt E # E also short? if nz # Yes cmp A E # F ret end or B B # nz (E is big) setc # lt ret end # A is big cnt E # E short? if nz # Yes clrc # gt (E is short) ret end # Both are big push X push Y ld X 0 # Clear reverse pointers ld Y 0 do ld C (A BIG) # Tails equal? cmp C (E BIG) if eq # Yes do ld C (A DIG) # Compare digits cmp C (E DIG) while eq null X # End of reversed list? if z # Yes pop Y # eq pop X ret end ld C (X BIG) # Restore A ld (X BIG) A ld A X ld X C ld C (Y BIG) # Restore E ld (Y BIG) E ld E Y ld Y C loop push F break T end cnt C # End of A? if nz # Yes cnt (E BIG) # Also end of E? if nz # Yes cmp C (E BIG) # F else or B B # nz (E is bigger) setc # lt end push F break T end cnt (E BIG) # End of E? if nz # Yes clrc # gt push F break T end ld (A BIG) X # Reverse A ld X A ld A C ld C (E BIG) # Reverse E ld (E BIG) Y ld Y E ld E C loop do null X # Reversed? while nz # Yes ld C (X BIG) # Restore A ld (X BIG) A ld A X ld X C ld C (Y BIG) # Restore E ld (Y BIG) E ld E Y ld Y C loop pop F # Return flags pop Y pop X ret ### Conversions ### # Make number from symbol (code 'symToNumXA_FE 0) link push ZERO # Safe link push A # Scale push 0 # Sign flag push 0 # Fraction flag ld C 0 call symByteCX_FACX # Get first byte jz 99 # None do cmp B 32 # Skip white space while le call symByteCX_FACX # Next byte jz 99 # None loop cmp B (char "+") # Plus sign? jz 10 # Yes cmp B (char "-") # Minus sign? if eq # Yes or (L -II) 1 # Set Sign 10 call symByteCX_FACX # Next byte jz 99 # None end sub A (char "0") # First digit cmp A 10 # Too big? jge 99 # Return NO shl A 4 # Make short number or A CNT ld (L I) A # Save do call symCharCX_FACX # More? while nz # Yes test (L -III) 1 # Fraction? if nz # Yes null (L -I) # Scale? if z # No sub A (char "0") # Next digit cmp A 10 # Too big? jge 99 # Return NO cmp A 5 # Round? if ge # Yes ld A ONE # Increment ld E (L I) push C call adduAE_A pop C ld (L I) A end do call symByteCX_FACX # More? while nz # Yes sub A (char "0") # Next digit cmp A 10 # Too big? jge 99 # Return NO loop break T end end cmp A (Sep0) # Decimal separator? if eq # Yes test (L -III) 1 # Fraction? jnz 99 # Return NO or (L -III) 1 # Set Fraction else cmp A (Sep3) # Thousand separator? if ne # No sub A (char "0") # Next digit cmp A 10 # Too big? jge 99 # Return NO push C # Save symByte args push X push A # Save digit ld A (L I) # Multiply number by 10 call tenfoldA_A ld (L I) A # Save pop E # Get digit shl E 4 # Make short number or E CNT call adduAE_A # Add to number ld (L I) A # Save again pop X # Pop symByte args pop C test (L -III) 1 # Fraction? if nz # Yes dec (L -I) # Decrement Scale end end end loop test (L -III) 1 # Fraction? if nz # Yes do sub (L -I) 1 # Decrement Scale while nc # >= 0 ld A (L I) # Multiply number by 10 call tenfoldA_A ld (L I) A # Save loop end ld E (L I) # Get result test (L -II) 1 # Sign? if nz # Yes cmp E ZERO # Zero? if ne # No xor E SIGN # Negate end end setc # Return YES 99 drop ret # Format number to output, length, or symbol (code 'fmtNum0AE_E 0) ld (Sep3) 0 # Thousand separator 0 ld (Sep0) 0 # Decimal separator 0 (code 'fmtNumAE_E) push C push X push Y push Z link push ZERO # Name link push A # Scale ld A E # Get number cnt A # Short number? if nz # Yes push 16 # mask else push 1 # mask end shr B 3 # Get sign bit push A # Sign flag off E SIGN # Calculate buffer size ld A 19 # Decimal length of 'cnt' (60 bit) ld C E # Get number do cnt C # Last digit? while z # No add A 20 # Add decimal length of 'digit' (64 bit) ld C (C BIG) loop add A 17 # Round up ld C 0 # Divide by 18 div 18 shl A 3 # Word count sub S A # Space for incrementor ld (S) 1 # Init to '1' ld X S # Keep pointer to incrementor in X sub S A # Accumulator cmp S (StkLimit) # Stack check jlt stkErr ld (S) 0 # Init to '0' push S # Top of accumulator push X # Pointer to incrementor push X # Top of incrementor do cnt E # Short number? ldnz Z E # Yes if z ld Z (E DIG) # Digit in Z end do ld A Z # Current digit test A (L -II) # Test next bit with mask if nz # Add incrementor to accumulator ld C 0 # Carry for BCD addition lea X (S III) # Accumulator ld Y (S I) # Incrementor do cmp X (S II) # X > Top of accumulator? if gt # Yes add (S II) 8 # Extend accumulator ld (X) 0 # with '0' end ld A (X) add A (Y) # Add BCD add A C # Add BCD-Carry ld C 0 # Clear BCD-Carry cmp A 1000000000000000000 # BCD overflow? if ge # Yes sub A 1000000000000000000 ld C 1 # Set BCD-Carry end ld (X) A # Store BCD digit in accumulator add X 8 add Y 8 cmp Y (S) # Reached top of incrementor? until gt # Yes null C # BCD-Carry? if ne # Yes add (S II) 8 # Extend accumulator ld (X) 1 # With '1' end end # Shift incrementor left ld C 0 # Clear BCD-Carry ld Y (S I) # Incrementor do ld A (Y) add A A # Double add A C # Add BCD-Carry ld C 0 # Clear BCD-Carry cmp A 1000000000000000000 # BCD overflow? if ge # Yes sub A 1000000000000000000 ld C 1 # Set BCD-Carry end ld (Y) A # Store BCD digit in incrementor add Y 8 cmp Y (S) # Reached top of incrementor? until gt # Yes null C # BCD-Carry? if ne # Yes add (S) 8 # Extend incrementor ld (Y) 1 # With '1' end shl (L -II) 1 # Shift bit mask until z cnt E # Short number? while z # No ld E (E BIG) # Next digit cnt E # Short number? if nz # Yes ld A 16 # Mask else ld A 1 end ld (L -II) A # Set bit mask loop ld Y (S II) # Top of accumulator lea Z (S III) # Accumulator null (L -I) # Scale negative? if s # Yes cmp (L -I) -1 # Direct print? if eq # Yes test (L -III) 1 # Sign? if nz # Yes ld B (char "-") # Output sign call (PutB) end ld A (Y) # Output highest word call outWordA do sub Y 8 # More? cmp Y Z while ge # Yes ld A (Y) # Output words in reverse order ld E 100000000000000000 # Digit scale do ld C 0 # Divide by digit scale div E push C # Save remainder add B (char "0") # Output next digit call (PutB) cmp E 1 # Done? while ne # No ld C 0 # Divide digit scale by 10 ld A E div 10 ld E A pop A # Get remainder loop loop else # Calculate length ld A Y # Top of accumulator sub A Z # Accumulator shr A 3 # Number of accumulator words mul 18 # Number of digits ld E A ld A (Y) # Length of highest word do inc E # Increment length ld C 0 # Divide by 10 div 10 null A # Done? until z # Yes test (L -III) 1 # Sign? if nz # Yes inc E # Space for '-' end shl E 4 # Make short number or E CNT end drop else ld C 4 # Build name lea X (L I) test (L -III) 1 # Sign? if nz # Yes ld B (char "-") # Insert sign call byteSymBCX_CX end push C # Save name index ld A Y # Top of accumulator sub A Z # Accumulator shr A 3 # Number of accumulator words mul 18 # Number of digits ld E A # Calculate length-1 ld A (Y) # Highest word do ld C 0 # Divide by 10 div 10 null A # Done? while nz # No inc E # Increment length loop pop C # Restore name index sub E (L -I) # Scale ld (L -I) E # Decrement by Length-1 if lt # Scale < 0 ld B (char "0") # Prepend '0' call byteSymBCX_CX ld A (Sep0) # Prepend decimal separator call charSymACX_CX do cmp (L -I) -1 # Scale while lt inc (L -I) # Increment scale ld B (char "0") # Ouput zeroes call byteSymBCX_CX loop end ld A (Y) # Pack highest word call fmtWordACX_CX do sub Y 8 # More? cmp Y Z while ge # Yes ld A (Y) # Pack words in reverse order ld E 100000000000000000 # Digit scale do push A call fmtScaleCX_CX # Handle scale character(s) pop A push C # Save name index ld C 0 # Divide by digit scale div E xchg C (S) # Save remainder, restore name index add B (char "0") # Pack next digit call byteSymBCX_CX cmp E 1 # Done? while ne # No push C # Save name index ld C 0 # Divide digit scale by 10 ld A E div 10 pop C # Restore name index ld E A pop A # Get remainder loop loop ld X (L I) # Get name drop call consSymX_E end pop Z pop Y pop X pop C ret (code 'fmtWordACX_CX 0) cmp A 9 # Single digit? if gt # No ld E C # Save C ld C 0 # Divide by 10 div 10 push C # Save remainder ld C E # Restore C call fmtWordACX_CX # Recurse call fmtScaleCX_CX # Handle scale character(s) pop A end add B (char "0") # Make ASCII digit jmp byteSymBCX_CX (code 'fmtScaleCX_CX 0) null (L -I) # Scale null? if z # Yes ld A (Sep0) # Output decimal separator call charSymACX_CX else null (Sep3) # Thousand separator? if nz # Yes ld A (L -I) # Scale > 0? null A if nsz # Yes push C ld C 0 # Modulus 3 div 3 null C pop C if z ld A (Sep3) # Output thousand separator call charSymACX_CX end end end end dec (L -I) # Decrement scale ret # (format 'num ['cnt ['sym1 ['sym2]]]) -> sym # (format 'sym|lst ['cnt ['sym1 ['sym2]]]) -> num (code 'doFormat 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'num' | 'sym' link ld Y (Y CDR) # Second arg ld E (Y) eval # Eval 'cnt' cmp E Nil # Any? if eq # No ld E 0 # Zero else call xCntEX_FE # Extract 'cnt' end push E # Scale push (char ".") # Sep0 push 0 # Sep3 ld Y (Y CDR) # Third arg? atom Y if z # Yes ld E (Y) eval # Eval 'sym1' num E # Need symbol jnz symErrEX sym E jz symErrEX call firstCharE_A ld (L -II) A # Sep0 ld Y (Y CDR) # Fourth arg? atom Y if z # Yes ld E (Y) eval # Eval 'sym2' num E # Need symbol jnz symErrEX sym E jz symErrEX call firstCharE_A ld (S) A end end pop (Sep3) # Get Sep3 pop (Sep0) # and Sep0 ld E (L I) # Get 'num' | 'sym' num E # Number? if nz # Yes pop A # Get scale call fmtNumAE_E # Convert to string else sym E # Symbol? if nz # Yes ld X (E TAIL) call nameX_X # Get name else link push ZERO # Number safe push ZERO # Result ld C 4 # Build name ld X S link call packECX_CX ld X (L I) # Get result drop end pop A # Get scale call symToNumXA_FE # Convert to number if nc # Failed ld E Nil end end drop pop Y pop X ret ### Arithmetics ### # (+ 'num ..) -> num (code 'doAdd 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No link push ZERO # Safe push E # Result link do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) eval # Eval next arg cmp E Nil jz 10 # Abort if NIL num E # Number? jz numErrEX # No ld (L II) E # Save arg ld A (L I) # Result call addAE_A # Add ld (L I) A # Result loop ld E (L I) # Result 10 drop end pop Y pop X ret # (- 'num ..) -> num (code 'doSub 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No ld Y (Y CDR) # More than one arg? atom Y if nz # No: Unary minus cmp E ZERO # Zero? if ne # No xor E SIGN # Negate end else link push ZERO # Safe push E # Result link do ld E (Y) eval # Eval next arg cmp E Nil jz 10 # Abort if NIL num E # Number? jz numErrEX # No ld (L II) E # Save arg ld A (L I) # Result call subAE_A # Subtract ld (L I) A # Result ld Y (Y CDR) # More args? atom Y until nz # No ld E (L I) # Result 10 drop end end pop Y pop X ret # (inc 'num) -> num # (inc 'var ['num]) -> num (code 'doInc 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL link push E # First arg link num E # Number? if nz # Yes call incE_A # Increment it else call checkVarEX sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end ld Y (Y CDR) # Next arg? atom Y if nz # No ld E (E) # Get VAL cmp E Nil # NIL? ldz A E if ne # No num E # Number? jz numErrEX # No call incE_A # Increment it ld ((L I)) A # Set new value end else ld E (Y) eval # Eval next arg tuck E # Second arg link ld A ((L II)) # First arg's VAL cmp A Nil # NIL? if ne # No num A # Number? jz numErrAX # No ld E (L I) # Second arg cmp E Nil # NIL? ldz A E if ne # No num E jz numErrEX # No call addAE_A # Add ld ((L II)) A # Set new value end end end end ld E A # Get result drop end pop Y pop X ret # (dec 'num) -> num # (dec 'var ['num]) -> num (code 'doDec 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL link push E # First arg link num E # Number? if nz # Yes call decE_A # Decrement it else call checkVarEX sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end ld Y (Y CDR) # Next arg? atom Y if nz # No ld E (E) # Get VAL cmp E Nil # NIL? ldz A E if ne # No num E # Number? jz numErrEX # No call decE_A # Decrement it ld ((L I)) A # Set new value end else ld E (Y) eval # Eval next arg tuck E # Second arg link ld A ((L II)) # First arg's VAL cmp A Nil # NIL? if ne # No num A # Number? jz numErrAX # No ld E (L I) # Second arg cmp E Nil # NIL? ldz A E if ne # No num E jz numErrEX # No call subAE_A # Subtract ld ((L II)) A # Set new value end end end end ld E A # Get result drop end pop Y pop X ret # (* 'num ..) -> num (code 'doMul 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No ld B 0 # Init sign test E SIGN if nz off E SIGN inc B end link push ZERO # Safe push E # Result link push A # Sign flag do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) eval # Eval next arg cmp E Nil jz 10 # Abort if NIL num E # Number? jz numErrEX # No test E SIGN # Arg negative? if nz # Yes off E SIGN # Make argument positive xor (L -I) 1 # Toggle result sign end ld (L II) E # Save arg ld A (L I) # Result call muluAE_A # Multiply ld (L I) A # Result loop ld E (L I) # Result test (L -I) 1 # Sign? if nz # Yes cmp E ZERO # Zero? if ne # No or E SIGN # Set negative end end 10 drop end pop Y pop X ret # (*/ 'num1 ['num2 ..] 'num3) -> num (code 'doMulDiv 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No ld B 0 # Init sign test E SIGN if nz off E SIGN inc B end link push ZERO # Safe push E # Result link push A # Sign flag do ld Y (Y CDR) # Next arg ld E (Y) eval # Eval next arg cmp E Nil jz 10 # Abort if NIL num E # Number? jz numErrEX # No test E SIGN # Arg negative? if nz # Yes off E SIGN # Make argument positive xor (L -I) 1 # Toggle result sign end ld (L II) E # Save arg atom (Y CDR) # More args? while z # Yes ld A (L I) # Result call muluAE_A # Multiply ld (L I) A # Result loop cmp E ZERO # Zero? jeq divErrX # Yes ld A E # Last argument call shruA_A # / 2 ld E (L I) # Get product ld (L I) A # Save halved argument call adduAE_A # Add for rounding ld (L I) A # Save rounded product ld E (L II) # Last argument call divuAE_A # Divide ld E A # Result test (L -I) 1 # Sign? if nz # Yes cmp E ZERO # Zero? if ne # No or E SIGN # Set negative end end 10 drop end pop Y pop X ret # (/ 'num ..) -> num (code 'doDiv 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No ld B 0 # Init sign test E SIGN if nz off E SIGN inc B end link push ZERO # Safe push E # Result link push A # Sign flag do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) eval # Eval next arg cmp E Nil jz 10 # Abort if NIL num E # Number? jz numErrEX # No cmp E ZERO # Zero? jeq divErrX # Yes test E SIGN # Arg negative? if nz # Yes off E SIGN # Make argument positive xor (L -I) 1 # Toggle result sign end ld (L II) E # Save arg ld A (L I) # Result call divuAE_A # Divide ld (L I) A # Result loop ld E (L I) # Result test (L -I) 1 # Sign? if nz # Yes cmp E ZERO # Zero? if ne # No or E SIGN # Set negative end end 10 drop end pop Y pop X ret # (% 'num ..) -> num (code 'doRem 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No ld B 0 # Init sign test E SIGN if nz off E SIGN ld B 1 end link push ZERO # Safe push E # Result link push A # Sign flag do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) eval # Eval next arg cmp E Nil jz 10 # Abort if NIL num E # Number? jz numErrEX # No cmp E ZERO # Zero? jeq divErrX # Yes off E SIGN # Make argument positive ld (L II) E # Save arg ld A (L I) # Result call remuAE_A # Remainder ld (L I) A # Result loop ld E (L I) # Result test (L -I) 1 # Sign? if nz # Yes cmp E ZERO # Zero? if ne # No or E SIGN # Set negative end end 10 drop end pop Y pop X ret # (>> 'cnt 'num) -> num (code 'doShift 2) push X push Y ld X E ld Y (E CDR) # Y on args call evCntXY_FE # Get shift count link push ZERO # Safe link push E # Shift count ld Y (Y CDR) # Second arg ld E (Y) eval # Eval number cmp E Nil # Any? if nz # Yes num E # Number? jz numErrEX # No ld A E # Number in A off A SIGN # Make positive and E SIGN # Sign bit push E # Sign bit null (L -I) # Shift count? if nz # Yes if ns # Positive call shruA_A # Non-destructive ld (L I) A do dec (L -I) # Shift count? while nz call halfA_A # Shift right (destructive) ld (L I) A loop else call shluA_A # Non-destructive ld (L I) A do inc (L -I) # Shift count? while nz call twiceA_A # Shift left (destructive) ld (L I) A loop end end cmp A ZERO # Result zero? if ne # No or A (L -II) # Sign bit end ld E A # Get result end drop pop Y pop X ret # (lt0 'any) -> num | NIL (code 'doLt0 2) ld E (E CDR) # Get arg ld E (E) eval # Eval it num E # Number? jz retNil test E SIGN # Negative? jz retNil ret # Yes: Return num # (le0 'any) -> num | NIL (code 'doLe0 2) ld E (E CDR) # Get arg ld E (E) eval # Eval it num E # Number? jz retNil cmp E ZERO # Zero? if ne # No test E SIGN # Negative? jz retNil end ret # Yes: Return num # (ge0 'any) -> num | NIL (code 'doGe0 2) ld E (E CDR) # Get arg ld E (E) eval # Eval it num E # Number? jz retNil test E SIGN # Positive? jnz retNil ret # Yes: Return num # (gt0 'any) -> num | NIL (code 'doGt0 2) ld E (E CDR) # Get arg ld E (E) eval # Eval it num E # Number? jz retNil cmp E ZERO # Zero? jeq retNil test E SIGN # Positive? jnz retNil ret # Yes: Return num # (abs 'num) -> num (code 'doAbs 2) push X ld X E ld E (E CDR) # Get arg ld E (E) eval # Eval it cmp E Nil # Any? if nz # Yes num E # Number? jz numErrEX # No off E SIGN # Clear sign end pop X ret ### Bit operations ### # (bit? 'num ..) -> num | NIL (code 'doBitQ 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg num E # Number? jz numErrEX # No off E SIGN # Clear sign link push E # Bit mask link do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) eval # Eval next arg cmp E Nil while ne # Abort if NIL num E # Number? jz numErrEX # No off E SIGN # Clear sign ld C (L I) # Get mask do cnt C # C short? while z # No cnt E # E short? jnz 10 # Yes: Return NIL ld A (E DIG) # Get digit and A (C DIG) # Match? cmp A (C DIG) jne 10 # No: Return NIL ld C (C BIG) ld E (E BIG) loop cnt E # E also short? if z # No shr C 4 # Normalize ld E (E DIG) # Get digit end and E C # Match? cmp E C if ne # No 10 ld E Nil # Return NIL drop pop Y pop X ret end loop ld E (L I) # Return bit mask drop pop Y pop X ret # (& 'num ..) -> num (code 'doBitAnd 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No off E SIGN # Clear sign link push ZERO # Safe push E # Result link do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) eval # Eval next arg cmp E Nil jeq 10 # Abort if NIL num E # Number? jz numErrEX # No off E SIGN # Clear sign ld (L II) E # Save arg ld A (L I) # Result call anduAE_A # Bitwise AND ld (L I) A # Result loop ld E (L I) # Result 10 drop end pop Y pop X ret # (| 'num ..) -> num (code 'doBitOr 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No off E SIGN # Clear sign link push ZERO # Safe push E # Result link do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) eval # Eval next arg cmp E Nil jeq 10 # Abort if NIL num E # Number? jz numErrEX # No off E SIGN # Clear sign ld (L II) E # Save arg ld A (L I) # Result call oruAE_A # Bitwise OR ld (L I) A # Result loop ld E (L I) # Result 10 drop end pop Y pop X ret # (x| 'num ..) -> num (code 'doBitXor 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No off E SIGN # Clear sign link push ZERO # Safe push E # Result link do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) eval # Eval next arg cmp E Nil jeq 10 # Abort if NIL num E # Number? jz numErrEX # No off E SIGN # Clear sign ld (L II) E # Save arg ld A (L I) # Result call xoruAE_A # Bitwise XOR ld (L I) A # Result loop ld E (L I) # Result 10 drop end pop Y pop X ret # (sqrt 'num ['flg|num]) -> num (code 'doSqrt 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) eval # Eval first arg cmp E Nil if ne # Non-NIL num E # Number? jz numErrEX # No test E SIGN # Negative? jnz argErrEX # Yes link push E # First arg link ld E ((Y CDR)) # Second arg eval # flg|num tuck E # Second arg link ld A (L II) # First arg in A num E # Second arg numeric? if nz # Yes call muluAE_A # Multiply with scale end cnt A # Short? if nz # Yes shr A 4 # Normalize ld C (hex "400000000000000") # Mask ld E 0 # Result do add E C # result += mask cmp E A # > number? if gt # Yes sub E C # Undo else sub A E # Subtract result add E C # Add mask to result end shr E 1 # Shift result shr C 2 # Shift mask until z cmp (L I) Nil # Second arg? if ne # Yes cmp A E # Round? if gt # Yes inc E # Increment result end end shl E 4 # Make short number or E CNT else tuck A # Number push A # Mask push ZERO # Result link ld C 0 # Init mask ld E ONE call consNumCE_C ld (L II) C # Save ld E (A DIG) # Copy number call boxNumE_E ld (L III) E # Save do ld A (A BIG) # Next cell cnt A # Last one? while z # No call boxNum_C # Copy next digit ld (C DIG) (A DIG) ld (E BIG) C ld E C call boxNum_X # Extend mask ld (X DIG) 0 ld (X BIG) (L II) ld (L II) X # Save loop ld (E BIG) A # Copy trailing short ld A (L II) # Mask do ld E (L III) # Number call cmpuAE_F # Mask <= number? while le # Yes call twiceA_A # Times 4 call twiceA_A loop do ld A (L I) # result += mask ld E (L II) call adduAE_A ld (L I) A ld E (L III) # > number? call cmpuAE_F if gt # Yes ld E (L II) # Undo call subuAE_A else ld A (L III) # Subtract result ld E (L I) call subuAE_A ld (L III) A ld A (L I) # Add mask to result ld E (L II) call adduAE_A end call halfA_A # Shift result ld (L I) A ld A (L II) # Shift mask twice call halfA_A call halfA_A ld (L II) A cmp A ZERO # Zero? until eq # Yes ld E (L I) # Get result cmp (L IV) Nil # Second arg? if ne # Yes ld A (L III) # Get number call cmpuAE_F # Round? if gt # Yes ld A ONE # Increment result call adduAE_A ld E A end end end drop end pop Y pop X ret ### Random generator ### (code 'initSeedE_E 0) push C # Counter ld C 0 do atom E # Pair? while z # Yes push E # Recurse on CAR ld E (E) call initSeedE_E add C E pop E # Loop on CDR ld E (E CDR) loop cmp E Nil # NIL? if ne # No num E # Need number if z # Must be symbol ld E (E TAIL) call nameE_E # Get name end do cnt E # Short? while z # No add C (E DIG) # Add next digit ld E (E BIG) loop shr E 3 # Keep sign add C E # Add final short end ld E C # Return counter pop C ret # (seed 'any) -> cnt (code 'doSeed 2) ld E (E CDR) # Get arg ld E (E) eval # Eval it call initSeedE_E # Initialize 'Seed' ld A 6364136223846793005 # Multiplier mul E # times 'Seed' ld (Seed) D # Save shr A (- 32 3) # Get higher 32 bits ld E A off E 7 # Keep sign or E CNT # Make short number ret # (hash 'any) -> cnt (code 'doHash 2) push X ld E (E CDR) # Get arg ld E (E) eval # Eval it call initSeedE_E # Initialize ld X E # Value in X ld C 64 # Counter ld E 0 # Result do ld A X # Value XOR Result xor A E test A 1 # LSB set? if nz # Yes xor E (hex "14002") # CRC Polynom x**16 + x**15 + x**2 + 1 end shr X 1 # Shift value shr E 1 # and result dec C # Done? until z # Yes inc E # Plus 1 shl E 4 # Make short number or E CNT # Make short number pop X ret # (rand ['cnt1 'cnt2] | ['T]) -> cnt | flg (code 'doRand 2) push X push Y ld X E ld Y (E CDR) # Y on args ld A 6364136223846793005 # Multiplier mul (Seed) # times 'Seed' add D 1 # plus 1 ld (Seed) D # Save ld E (Y) eval # Eval first arg cmp E Nil # Any? if eq # No shr A (- 32 3) # Get higher 32 bits ld E A off E 7 # Keep sign or E CNT # Make short number pop Y pop X ret end cmp E TSym # Boolean if eq ld A (Seed) rcl A 1 # Highest bit? if nc # No ld E Nil # Return NIL end # else return T pop Y pop X ret end call xCntEX_FE # Get cnt1 push E # Save it ld Y (Y CDR) # Second arg call evCntXY_FE # Get cnt2 inc E # Seed % (cnt2 + 1 - cnt1) + cnt1 sub E (S) ld D (Seed) # Get 'Seed' shl C 32 # Get middle 64 bits shr A 32 or A C ld C 0 div E # Modulus in C pop E # + cnt1 add E C pop Y pop X jmp boxE_E # Return short number # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/db.l0000644000000000000000000016615012265263724014664 0ustar rootroot# 11dec13abu # (c) Software Lab. Alexander Burger # 6 bytes in little endian format # Get block address from buffer (code 'getAdrZ_A 0) ld B (Z 5) # Highest byte zxt shl A 8 ld B (Z 4) shl A 8 ld B (Z 3) shl A 8 ld B (Z 2) shl A 8 ld B (Z 1) shl A 8 ld B (Z) # Lowest byte ret # Set block address in buffer (code 'setAdrAZ 0) ld (Z) B # Lowest byte shr A 8 ld (Z 1) B shr A 8 ld (Z 2) B shr A 8 ld (Z 3) B shr A 8 ld (Z 4) B shr A 8 ld (Z 5) B # Highest byte ret (code 'setAdrAS 0) ld (S (+ I 2)) B # Write block address to stack shr A 8 ld (S (+ I 3)) B shr A 8 ld (S (+ I 4)) B shr A 8 ld (S (+ I 5)) B shr A 8 ld (S (+ I 6)) B shr A 8 ld (S (+ I 7)) B # Highest byte ret # Read file number from 'Buf' into 'DbFile' (code 'dbfBuf_AF 0) ld B (Buf 1) # Two bytes little endian zxt shl A 8 ld B (Buf) shl A 6 # 'dbFile' index cmp A (DBs) # Local file? jge retc # No add A (DbFiles) # Get DB file ld (DbFile) A # Set current ret # 'nc' # Build external symbol name (code 'extNmCE_X 0) ld X C # Get object ID into X and X (hex "FFFFF") # Lowest 20 bits shr C 20 # Middle part of object ID ld A C and A (hex "FFF") # Lowest 12 bits shl A 28 or X A # into X shr C 12 # Rest of object ID shl C 48 or X C # into X ld A E # Get file number and A (hex "FF") # Lowest 8 bits shl A 20 # Insert or X A # into X shr E 8 # Rest of file number shl E 40 or X E # into X shl X 4 # Make short name or X CNT ret # Pack external symbol name (code 'packExtNmX_E) link push ZERO # Name link call fileObjX_AC # Get file and object ID push C # Save object ID ld C 4 # Build name lea X (L I) null A # Any? if nz # Yes call packAoACX_CX # Pack file number end pop A # Get object ID call packOctACX_CX # Pack it call cons_E # Cons symbol ld (E) (L I) # Set name or E SYM # Make symbol ld (E) E # Set value to itself drop ret (code 'packAoACX_CX 0) cmp A 15 # Single digit? if gt # No push A # Save shr A 4 # Divide by 16 call packAoACX_CX # Recurse pop A and B 15 # Get remainder end add B (char "@") # Make ASCII letter jmp byteSymBCX_CX # Pack byte (code 'packOctACX_CX 0) cmp A 7 # Single digit? if gt # No push A # Save shr A 3 # Divide by 8 call packOctACX_CX # Recurse pop A and B 7 # Get remainder end add B (char "0") # Make ASCII digit jmp byteSymBCX_CX # Pack byte # Chop external symbol name (code 'chopExtNmX_E) call fileObjX_AC # Get file and object ID ld X A # Keep file in X call oct3C_CA # Get lowest octal digits call consA_E # Final cell ld (E) A ld (E CDR) Nil link push E # Result link do shr C 3 # Higher octal digits? while nz # Yes call oct3C_CA # Get next three digits call consA_E # Cons into result ld (E) A ld (E CDR) (L I) ld (L I) E loop null X # File number? if nz # Yes ld E 0 # Build A-O encoding ld A 0 do ld B X # Next hax digit and B 15 # Lowest four bits add B (char "@") # Make ASCII letter or E B shr X 4 # More hax digits? while nz # Yes shl E 8 # Shift result loop shl E 4 # Make short name or E CNT call cons_A # Make transient symbol ld (A) E # Set name or A SYM # Make symbol ld (A) A # Set value to itself call consA_E # Cons into result ld (E) A ld (E CDR) (L I) ld (L I) E end ld E (L I) # Get result drop ret (code 'oct3C_CA 0) ld A 0 ld B C # Lowest octal digit and B 7 add B (char "0") # Make ASCII digit ld E A shr C 3 # Next digit? if nz # Yes ld B C # Second octal digit and B 7 add B (char "0") # Make ASCII digit shl E 8 or E B shr C 3 # Next digit? if nz # Yes ld B C # Hightest octal digit and B 7 add B (char "0") # Make ASCII digit shl E 8 or E B end end shl E 4 # Make short name or E CNT call cons_A # Make transient symbol ld (A) E # Set name or A SYM # Make symbol ld (A) A # Set value to itself ret # Get file and object ID from external symbol name (code 'fileObjX_AC 0) shl X 2 # Strip status bits shr X 6 # Normalize ld C X # Get object ID and C (hex "FFFFF") # Lowest 20 bits shr X 20 # Get file number ld A X and A (hex "FF") # Lowest 8 bits shr X 8 # More? if nz # Yes ld E X # Rest in E and E (hex "FFF") # Middle 12 bits of object ID shl E 20 or C E # into C shr X 12 # High 8 bits of file number ld E X # into E and E (hex "FF") # Lowest 8 bits shl E 8 or A E # into A shr X 8 # Rest of object ID shl X 32 or C X # into C end ret # Get file and object ID from external symbol (code 'fileObjE_AC 0) push X ld X (E TAIL) call nameX_X # Get name call fileObjX_AC pop X ret # Get dbFile index and block index from external symbol (code 'dbFileBlkY_AC 0) push X ld X Y # Name in X call fileObjX_AC shl A 6 # 'dbFile' index shl C 6 # Block index pop X ret (code 'rdLockDb) cmp (Solo) TSym # Already locked whole DB? jeq ret # Yes ld A (| F_RDLCK (hex "10000")) # Read lock, length 1 ld C ((DbFiles)) # Descriptor of first file jmp lockFileAC (code 'wrLockDb) cmp (Solo) TSym # Already locked whole DB? jeq ret # Yes ld A (| F_WRLCK (hex "10000")) # Write lock, length 1 ld C ((DbFiles)) # Descriptor of first file jmp lockFileAC (code 'rwUnlockDbA) cmp (Solo) TSym # Already locked whole DB? jeq ret # Yes null A # Length zero? if z # Yes push X push Y ld X (DbFiles) # Iterate DB files ld Y (DBs) # Count do sub Y VIII # Done? while ne # No add X VIII # Skip first, increment by sizeof(dbFile) nul (X (+ IV 0)) # This one locked? if nz # Yes ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 ld C (X) # File descriptor call unLockFileAC set (X (+ IV 0)) 0 # Clear lock entry end loop pop Y pop X ld (Solo) ZERO # Reset solo mode ld A 0 # Length zero again end or A F_UNLCK ld C ((DbFiles)) # Unlock first file jmp unLockFileAC (code 'tryLockCE_FA) do ld A F_WRLCK # Write lock st2 (Flock L_TYPE) # 'l_type' ld (Flock L_START) C # Start position ('l_whence' is SEEK_SET) ld (Flock L_LEN) E # Length cc fcntl(((DbFile)) F_SETLK Flock) # Try to lock nul4 # OK? if ns # Yes set ((DbFile) (+ IV 0)) 1 # Set lock flag null C # 'Start position is zero? if z # Yes ld (Solo) TSym # Set solo mode else cmp (Solo) TSym # Already locked whole DB? if ne # No ld (Solo) Nil # Clear solo mode setz end end ret # 'z' end call errno_A cmp A EINTR # Interrupted? if ne # No cmp A EACCES # Locked by another process? if ne # No cmp A EAGAIN # Memory-mapped by another process? jne lockErr # No end end do cc fcntl(((DbFile)) F_GETLK Flock) # Try to get lock nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? jne lockErr # No loop ld2 (Flock L_TYPE) # Get 'l_type' cmp B F_UNLCK # Locked by another process? until ne # Yes ld4 (Flock L_PID) # Return PID ret # 'nz' (code 'jnlFileno_A) cc fileno((DbJnl)) # Get fd ret (code 'logFileno_A) cc fileno((DbLog)) # Get fd ret (code 'lockJnl) call jnlFileno_A # Get fd ld C A # into C jmp wrLockFileC # Write lock journal (code 'unLockJnl) cc fflush((DbJnl)) # Flush journal call jnlFileno_A # Get fd ld C A # into C ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 jmp unLockFileAC # Unlock journal (code 'setBlockAC_Z 0) add A (DbFiles) # Get DB file : setBlkAC_Z ld (DbFile) A # Set current ld (BlkIndex) C # Set block index ld A (A III) # Block size ld Z (DbBlock) # Get block buffer in Z add A Z # Caclulate data end ld (BufEnd) A ret (code 'rdBlockLinkZ_Z) ld A (BlkLink) # Next block (code 'rdBlockIndexAZ_Z) ld (BlkIndex) A # Set block index ld Z (DbBlock) # Block buffer in Z (code 'rdBlockZ_Z) ld A (DbFile) # Get current file ld C (A III) # Block size ld E (BlkIndex) # Get block index in E shl E (A II) # Shift for current file call blkPeekCEZ # Read block call getAdrZ_A # Get link address off A BLKTAG ld (BlkLink) A # Store as next block add Z BLK # Point to block data ret (code 'blkPeekCEZ) cc pread(((DbFile)) Z C E) # Read C bytes from pos E into buffer Z cmp A C # OK? jne dbRdErr # No ret (code 'wrBlockZ) ld A (DbFile) # Get current file ld C (A III) # Block size ld E (BlkIndex) # Get block index in E shl E (A II) # Shift for current file (code 'blkPokeCEZ) cc pwrite(((DbFile)) Z C E) # Write C bytes from buffer Z to pos E cmp A C # OK? jne dbWrErr # No null (DbJnl) # Journal? if nz # Yes cmp A ((DbFile) III) # Size (in A and C) equal to current file's block size? if eq # Yes ld A BLKSIZE # Use block unit size instead end cc putc_unlocked(A (DbJnl)) # Write size sub S (+ BLK 2) # Buffer ld A ((DbFile) I) # Get file number ld (S) B # Store low byte shr A 8 ld (S 1) B # and high byte ld A E # Get position shr A ((DbFile) II) # Un-shift for current file call setAdrAS # Set block address in buffer cc fwrite(S (+ BLK 2) 1 (DbJnl)) # Write file number and address cmp A 1 # OK? jne wrJnlErr # No cc fwrite(Z C 1 (DbJnl)) # Write C bytes from buffer Z cmp A 1 # OK? jne wrJnlErr # No add S (+ BLK 2) # Drop buffer end ret (code 'logBlock) sub S (+ BLK 2) # Buffer ld A ((DbFile) I) # Get file number ld (S) B # Store low byte shr A 8 ld (S 1) B # and high byte ld A (BlkIndex) # Get block index in E call setAdrAS # Write into buffer cc fwrite(S (+ BLK 2) 1 (DbLog)) # Write file number and address cmp A 1 # OK? jne wrLogErr # No cc fwrite((DbBlock) ((DbFile) III) 1 (DbLog)) # Write 'siz' bytes from block buffer cmp A 1 # OK? jne wrLogErr # No add S (+ BLK 2) # Drop buffer ret (code 'newBlock_X) push Z ld C (* 2 BLK) # Read 'free' and 'next' ld E 0 # from block zero ld Z Buf # into 'Buf' call blkPeekCEZ call getAdrZ_A # 'free'? null A jz 10 # No null ((DbFile) VII) # 'fluse'? if nz # Yes ld X A # Keep 'free' in X ld C (DbFile) shl A (C II) # Shift 'free' dec (C VII) # Decrement 'fluse' ld E A # Read 'free' link ld C BLK call blkPeekCEZ # into 'Buf' ld E 0 # Restore block zero in E ld C (* 2 BLK) # and poke size in C else 10 add Z BLK # Get 'next' call getAdrZ_A cmp A (hex "FFFFFFFFFFC0") # Max object ID jeq dbSizErr # DB Oversize ld X A # Keep in X add A BLKSIZE # Increment 'next' call setAdrAZ sub Z BLK # Restore 'Buf' in Z end call blkPokeCEZ # Write 'Buf' back ld C ((DbFile) III) # Current file's block size sub S C # Buffer ld B 0 # Clear buffer mset (S) C # with block size ld E X # Get new block address shl E ((DbFile) II) # Shift it ld Z S # Write initblock call blkPokeCEZ add S ((DbFile) III) # Drop buffer pop Z ret (code 'newIdEX_X) dec E # Zero-based shl E 6 # 'dbFile' index cmp E (DBs) # In Range? jge dbfErrX # No add E (DbFiles) # Get DB file ld (DbFile) E # Set current null (DbLog) # Transaction log? if z # No inc (EnvProtect) # Protect the operation end call wrLockDb # Write lock DB null (DbJnl) # Journal? if nz # Yes call lockJnl # Write lock journal end call newBlock_X # Allocate new block ld C X # Object ID shr C 6 # Normalize ld E ((DbFile) I) # Get file number call extNmCE_X # Build external symbol name null (DbJnl) # Journal? if nz # Yes call unLockJnl # Unlock journal end ld A (hex "10000") # Length 1 call rwUnlockDbA # Unlock null (DbLog) # Transaction log? if z # No dec (EnvProtect) # Unprotect end ret (code 'isLifeE_F) push E # Save symbol call fileObjE_AC # Get file and ID pop E # Restore symbol shl C 6 # Block index? jz retnz # No shl A 6 # 'dbFile' index cmp A (DBs) # Local file? if lt # Yes add A (DbFiles) # Get DB file ld (DbFile) A # Set current ld A (E TAIL) # Get tail call nameA_A # Get name shl A 1 # Dirty? jc retz # Yes shl A 1 # Loaded? jc Retz # Yes push E push Z push C # Save block index ld C BLK # Read 'next' ld E BLK ld Z Buf # into 'Buf' call blkPeekCEZ call getAdrZ_A # Get 'next' pop C # Get block index cmp C A # Less than 'next'? if ge # No clrz # 'nz' jmp 90 end ld E C # Block index shl E ((DbFile) II) # Shift ld C BLK # Read link field call blkPeekCEZ # into 'Buf' ld B (Z) # Get tag byte and B BLKTAG # Block tag cmp B 1 # One? 90 pop Z pop E else atom (Ext) # Extended databases? end ret # 'z' if OK (code 'cleanUpY) ld C BLK # Read 'free' ld E 0 # from block zero ld Z Buf # into 'Buf' call blkPeekCEZ call getAdrZ_A # Get 'free' push A # Save 'free' ld A Y # Deleted block call setAdrAZ # Store in buffer call blkPokeCEZ # Set new 'free' ld E Y # Deleted block do shl E ((DbFile) II) # Shift it call blkPeekCEZ # Get block link off (Z) BLKTAG # Clear tag call getAdrZ_A # Get link null A # Any? while nz # Yes ld Y A # Keep link in Y call blkPokeCEZ # Write link ld E Y # Get link loop pop A # Retrieve 'free' call setAdrAZ # Store in buffer jmp blkPokeCEZ # Append old 'free' list (code 'getBlockZ_FB 0) cmp Z (BufEnd) # End of block data? if eq # Yes ld A (BlkLink) # Next block? null A jz ret # No: Return 0 push C push E call rdBlockIndexAZ_Z # Read block pop E pop C end ld B (Z) # Next byte add Z 1 # (nc) ret (code 'putBlockBZ 0) cmp Z (BufEnd) # End of block data? if eq # Yes push A # Save byte push C push E ld Z (DbBlock) # Block buffer null (BlkLink) # Next block? if nz # Yes call wrBlockZ # Write current block call rdBlockLinkZ_Z # Read next block else push X call newBlock_X # Allocate new block ld B (Z) # Get block count (link is zero) zxt push A # Save count or A X # Combine with new link call setAdrAZ # Store in current block call wrBlockZ # Write current block ld (BlkIndex) X # Set new block index pop A # Retrieve count cmp A BLKTAG # Max reached? if ne # No inc A # Increment count end call setAdrAZ # Store in new current block add Z BLK # Point to block data pop X end pop E pop C pop A # Retrieve byte end ld (Z) B # Store byte inc Z # Increment pointer ret # (pool ['sym1 ['lst] ['sym2] ['sym3]]) -> T (code 'doPool 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args call evSymY_E # Eval database name link push E # 'sym1' ld Y (Y CDR) ld E (Y) # Eval scale factor list eval+ push E # 'lst' link cmp E Nil # Need list if ne atom E jnz lstErrEX end ld Y (Y CDR) call evSymY_E # Eval replication journal tuck E # 'sym2' link ld Y (Y CDR) call evSymY_E # Eval transaction log tuck E # 'sym3' link ld (Solo) ZERO # Reset solo mode null (DBs) # DB open? if nz # Yes call doRollback # Roll back possible changes ld E (DbFiles) # Iterate DB files ld C (DBs) # Count do ld A (E) # File descriptor call closeAX # Close it cc free((E VI)) # Free mark bit vector add E VIII # Increment by sizeof(dbFile) sub C VIII # Done? until z # Yes ld (DBs) 0 null (DbJnl) # Journal? if nz # Yes cc fclose((DbJnl)) # Close it ld (DbJnl) 0 end null (DbLog) # Transaction log? if nz # Yes cc fclose((DbLog)) # Close it ld (DbLog) 0 end end ld E (L IV) # Database name cmp E Nil # Given? if ne # Yes push A # 8 bytes additional buffer space call pathStringE_SZ # DB name slen C S # String length in C add C S # Add to buffer push C # DB name end pointer ld E VIII # Default to single dbFile ld A (L III) # Get scale factor list atom A # Any? if z # Yes ld E 0 # Calculate length do add E VIII # Increment by sizeof(dbFile) ld A (A CDR) atom A # More cells? until nz # No end ld A (DbFiles) # DB file structure array call allocAE_A # Set to new size ld (DbFiles) A ld Y A # Index in Y add A E push A # Limit ld (MaxBlkSize) 0 # Init block size maximum do ld C (S I) # Get DB name end pointer ld A Y # Get index sub A (DbFiles) shr A 6 # Revert to file number ld (Y I) A # Store in 'dbFile' atom (L III) # Scale factor list? if z # Yes call bufAoAC_C # Append AO encoding to DB base name end set (C) 0 # Null-byte string terminator ld A (L III) # Scale factor list ld (L III) (A CDR) ld A (A) # Next scale factor cnt A # Given? ldz A 2 # No: Default to 2 if nz shr A 4 # Else normalize end ld (Y II) A # Set block shift ld (DbFile) Y # Set current file cc open(&(S II) O_RDWR) # Try to open nul4 # OK? if ns # Yes ld (Y) A # Set file descriptor ld C (+ BLK BLK 1) # Read block shift ld E 0 # from block zero ld Z Buf # into 'Buf' call blkPeekCEZ ld B (Z (+ BLK BLK)) # Get block shift ld (Y II) B # Override argument block shift ld C BLKSIZE # Calculate block size shl C B ld (Y III) C # Set in dbFile else ld E (L IV) # Database name (if error) call errno_A cmp A ENOENT # Non-existing? jne openErrEX # No cc open(&(S II) (| O_CREAT O_EXCL O_RDWR) (oct "0666")) # Try to create nul4 # OK? js openErrEX # No ld (Y) A # Set file descriptor ld C BLKSIZE # Calculate block size shl C (Y II) ld (Y III) C # Set in dbFile sub S C # Buffer ld B 0 # Clear buffer mset (S) C # with block size ld E 0 # Position of DB block zero lea Z (S BLK) # Address of 'next' in buffer cmp Y (DbFiles) # First file? if ne # No ld A BLKSIZE # Only block zero else ld A (* 2 BLKSIZE) # Block zero plus DB root end call setAdrAZ # into 'next' ld Z S # Buffer address set (Z (* 2 BLK)) (Y II) # Set block shift in block zero call blkPokeCEZ # Write DB block zero cmp Y (DbFiles) # First file? if eq # Yes ld (S) 0 # Clear 'next' link in buffer ld (S I) 0 ld Z S # Address of 'link' in buffer ld A 1 # First block for DB root call setAdrAZ # into link field ld E (Y III) # Second block has block size position call blkPokeCEZ # Write first ID-block (DB root block) end add S (Y III) # Drop buffer end ld A (Y) # Get fd call closeOnExecAX ld A (Y III) # Block size cmp A (MaxBlkSize) # Calculate maximum if gt ld (MaxBlkSize) A end ld (Y IV) 0 # Clear 'flgs' ld (Y V) 0 # mark vector size ld (Y VI) 0 # and mark bit vector ld (Y VII) -1 # Init 'fluse' add Y VIII # Increment index by sizeof(dbFile) ld A Y # Get index sub A (DbFiles) # Advanced so far ld (DBs) A # Set new scaled DB file count cmp Y (S) # Done? until eq # Yes ld A (DbBlock) # Allocate block buffer ld E (MaxBlkSize) # for maximal block size call allocAE_A ld (DbBlock) A ld E (L II) # Replication journal? cmp E Nil if ne # Yes call pathStringE_SZ # Write journal to stack buffer cc fopen(S _a_) # Open for appending ld S Z # Drop buffer null A # OK? jz openErrEX # No ld (DbJnl) A call jnlFileno_A # Get fd call closeOnExecAX end ld E (L I) # Transaction log? cmp E Nil if ne # Yes call pathStringE_SZ # Write journal to stack buffer cc fopen(S _ap_) # Open for reading and appending ld S Z # Drop buffer null A # OK? jz openErrEX # No ld (DbLog) A call logFileno_A # Get fd call closeOnExecAX call rewindLog # Test for existing transaction cc fread(Buf 2 1 (DbLog)) # Read first file number null A # Any? if nz # Yes cc feof((DbLog)) # EOF? nul4 if z # No call ignLog # Discard incomplete transaction else do ld2 (Buf) # Get file number (byte order doesn't matter) cmp A (hex "FFFF") # End marker? if eq # Yes cc fprintf((stderr) RolbLog) # Rollback incomplete transaction call rewindLog # Rewind transaction log ld E (DbFiles) # Iterate DB files ld C (DBs) # Count do set (E (+ IV 1)) 0 # Clear dirty flag add E VIII # Increment by sizeof(dbFile) sub C VIII # Done? until z # Yes sub S (MaxBlkSize) # Buffer do cc fread(Buf 2 1 (DbLog)) # Read file number null A # Any? jz jnlErrX # No ld2 (Buf) # Get file number (byte order doesn't matter) cmp A (hex "FFFF") # End marker? while ne # No call dbfBuf_AF # Read file number from 'Buf' to 'DbFile' jc jnlErrX # No local file cc fread(Buf BLK 1 (DbLog)) # Read object ID cmp A 1 # OK? jne jnlErrX # No cc fread(S ((DbFile) III) 1 (DbLog)) # Read block data cmp A 1 # OK? jne jnlErrX # No ld Z Buf # Get object ID from 'Buf' call getAdrZ_A shl A ((DbFile) II) # Shift ld C ((DbFile) III) # Block size cc pwrite(((DbFile)) S C A) # Write C bytes from stack buffer to pos A cmp A C # OK? jne dbWrErr set ((DbFile) (+ IV 1)) 1 # Set dirty flag loop add S (MaxBlkSize) # Drop buffer call fsyncDB # Sync DB files to disk break T end call dbfBuf_AF # Read file number from 'Buf' into 'DbFile' jc 40 # No local file cc fread(Buf BLK 1 (DbLog)) # Read object ID cmp A 1 # OK? jne 40 # No cc fseek((DbLog) ((DbFile) III) SEEK_CUR) # Skip by 'siz' nul4 # OK? jnz 40 # No cc fread(Buf 2 1 (DbLog)) # Read next file number cmp A 1 # OK? if nz # No 40 call ignLog # Discard incomplete transaction break T end loop end end call truncLog # Truncate log file end end drop pop Z pop Y pop X ld E TSym # Return T ret (code 'ignLog) cc fprintf((stderr) IgnLog) ret (code 'rewindLog) cc fseek((DbLog) 0 SEEK_SET) # Rewind transaction log ret (code 'fsyncDB) ld E (DbFiles) # Iterate DB files ld C (DBs) # Count do nul (E (+ IV 1)) # Dirty? if nz # Yes cc fsync((E)) # Sync DB file to disk nul4 # OK? js dbSyncErrX # No end add E VIII # Increment by sizeof(dbFile) sub C VIII # Done? until z # Yes ret (code 'truncLog) call rewindLog # Rewind transaction log call logFileno_A # Get fd cc ftruncate(A 0) # Truncate log file nul4 # OK? jnz truncErrX ret # Append A-O encoding to string (code 'bufAoAC_C 0) cmp A 15 # Single digit? if gt # No push A # Save shr A 4 # Divide by 16 call bufAoAC_C # Recurse pop A and B 15 # Get remainder end add B (char "@") # Make ASCII letter ld (C) B # Store in buffer inc C ret # (journal 'any ..) -> T (code 'doJournal 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args sub S (MaxBlkSize) # Buffer do atom Y # More args? while z # Yes call evSymY_E # Next file name call pathStringE_SZ # Write to stack buffer cc fopen(S _r_) # Open file ld S Z # Drop buffer null A # OK? jz openErrEX # No ld E A # Keep journal file pointer in E do cc getc_unlocked(E) # Next char nul4 # EOF? while ns # No ld C A # Size in C cc fread(Buf 2 1 E) # Read file number cmp A 1 # OK? jne jnlErrX # No call dbfBuf_AF # Read file number from 'Buf' to 'DbFile' jc dbfErrX # No local file cmp C BLKSIZE # Whole block? ldz C (A III) # Yes: Take file's block size cc fread(Buf BLK 1 E) # Read object ID cmp A 1 # OK? jne jnlErrX # No cc fread(S C 1 E) # Read data into buffer cmp A 1 # OK? jne jnlErrX # No push E # Save journal file pointer ld Z Buf # Get object ID from 'Buf' call getAdrZ_A ld E A # into E shl E ((DbFile) II) # Shift lea Z (S I) # Buffer call blkPokeCEZ # Write object data pop E # Restore journal file pointer loop cc fclose(E) # Close file pointer ld Y (Y CDR) loop add S (MaxBlkSize) # Drop buffer ld E TSym # Return T pop Z pop Y pop X ret # (id 'num ['num]) -> sym # (id 'sym [NIL]) -> num # (id 'sym T) -> (num . num) (code 'doId 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval num E # File number? if nz # Yes shr E 4 # Normalize push E # Scaled file number or object ID ld Y (Y CDR) # Next arg ld E (Y) eval # Eval object ID cmp E Nil # Given? if eq # No pop C # Get object ID ld E 0 # File defaults to zero else call xCntEX_FE # Eval object ID ld C E # into C pop E # Get file number dec E # Zero-based end call extNmCE_X # Build external symbol name call externX_E # New external symbol pop Y pop X ret end sym E # Need symbol jz symErrEX sym (E TAIL) # External symbol? jz extErrEX # No xchg E Y # Keep symbol in Y ld E ((E CDR)) # Eval second arg eval # Eval flag xchg E Y # Keep flag in Y, get symbol in E call fileObjE_AC # Get file and ID shl C 4 # Make short object ID or C CNT cmp Y Nil # Return only object ID? ldz E C # Yes if ne # No inc A # File is zero-based shl A 4 # Make short file number or A CNT call cons_E # Return (file . id) ld (E) A ld (E CDR) C end pop Y pop X ret # (seq 'cnt|sym1) -> sym | NIL (code 'doSeq 2) push X push Y push Z ld X E ld E ((E CDR)) # Eval arg eval num E # File number? if nz # Yes off E 15 # Normalize + 'dbFile' index sub E (hex "10") # Zero-based shl E 2 push E # Scaled file number cmp E (DBs) # Local file? jge dbfErrX # No add E (DbFiles) # Get DB file ld (DbFile) E # Set current ld X 0 # Block index zero else sym E # Need symbol jz symErrEX sym (E TAIL) # External symbol? jz extErrEX # No call fileObjE_AC # Get file and ID shl A 6 # 'dbFile' index push A # Scaled file number cmp A (DBs) # Local file? jge dbfErrX # No add A (DbFiles) # Get DB file ld (DbFile) A # Set current shl C 6 # Block index from object ID ld X C # Block index in X end call rdLockDb # Lock for reading ld C BLK # Read 'next' ld E BLK ld Z Buf # into 'Buf' call blkPeekCEZ call getAdrZ_A # Get 'next' ld Y A # into Y do add X BLKSIZE # Increment block index cmp X Y # Less than 'next'? if ge # No add S I # Drop file number ld E Nil # Return NIL break T end ld E X # Block index shl E ((DbFile) II) # Shift ld C BLK # Read link field call blkPeekCEZ # into 'Buf' ld B (Z) # Get tag byte and B BLKTAG # Block tag cmp B 1 # One? if eq # Yes pop E # Get scaled file number shr E 6 # Normalize ld C X # Object ID shr C 6 # Normalize call extNmCE_X # Build external symbol name call externX_E # New external symbol break T end loop ld A (hex "10000") # Length 1 call rwUnlockDbA # Unlock pop Z pop Y pop X ret # (lieu 'any) -> sym | NIL (code 'doLieu 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jnz retNil # Yes sym E # Symbol? jz retNil # No ld A (E TAIL) # Get tail sym A # External symbol? jz retNil # No off A SYM # Clear 'extern' tag do num A # Found name? if nz # Yes shl A 1 # Dirty? if nc # No shl A 1 # Loaded? ldnc E Nil # No ret end shl A 1 # Deleted? ldc E Nil # Yes ret end ld A (A CDR) # Skip property loop # (lock ['sym]) -> cnt | NIL (code 'doLock 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it cmp E Nil # NIL? if eq # Yes ld (DbFile) (DbFiles) # Use first dbFile ld C 0 # Start ld E 0 # Length call tryLockCE_FA # Lock whole DB else num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? jz extErrEX # No call fileObjE_AC # Get file and ID shl A 6 # 'dbFile' index cmp A (DBs) # Local file? jge dbfErrX # No add A (DbFiles) # Get DB file ld (DbFile) A ld A (A III) # Get block size mul C # Multiply with object ID for start position ld C A # Start ld E 1 # Length call tryLockCE_FA # Lock external symbol end ld E Nil # Preload NIL if nz # Locked by another process ld E A # Get PID shl E 4 # Make short number or E CNT end pop X ret (code 'dbFetchEX 0) ld A (E TAIL) # Get tail num A # Any properties? jz Ret # Yes rcl A 1 # Dirty? jc ret # Yes rcl A 1 # Loaded? jc ret # Yes setc # Set "loaded" rcr A 1 shr A 1 push C : dbAEX push Y push Z link push E # Symbol link ld Y A # Status/name in Y call dbFileBlkY_AC # Get file and block index cmp A (DBs) # Local file? if lt # Yes call setBlockAC_Z # Set up block env call rdLockDb # Lock for reading call rdBlockZ_Z # Read first block ld B (Z (- BLK)) # Get tag byte and B BLKTAG # Block tag cmp B 1 # One? jne idErrXL # Bad ID ld (GetBinZ_FB) getBlockZ_FB # Set binary read function ld (Extn) 0 # Set external symbol offset to zero call binReadZ_FE # Read first item ld A (L I) # Get symbol ld (A) E # Set value ld (A TAIL) Y # and status/name call binReadZ_FE # Read first property key cmp E Nil # Any? if ne # Yes call consE_A # Build first property cell ld (A) E # Cons key ld (A CDR) Y # With status/name ld Y A # Keep cell in Y or A SYM # Set 'extern' tag ld ((L I) TAIL) A # Set symbol's tail call binReadZ_FE # Read property value cmp E TSym # T? if ne # No call consE_A # Cons property value ld (A) E ld (A CDR) (Y) # With key ld (Y) A # Save in first property cell end do call binReadZ_FE # Read next property key cmp E Nil # Any? while ne # Yes call consE_A # Build next property cell ld (A) E # Cons key ld (A CDR) (Y CDR) # With name ld (Y CDR) A # Insert ld Y A # Point Y to new cell call binReadZ_FE # Read property value cmp E TSym # T? if ne # No call consE_A # Cons property value ld (A) E ld (A CDR) (Y) # With key ld (Y) A # Save in property cell end loop end ld A (hex "10000") # Length 1 call rwUnlockDbA # Unlock else shr A 6 # Revert to file number ld Z (Ext) # Extended databases? atom Z jnz dbfErrX # No ld C ((Z)) # First offset shr C 4 # Normalize cmp A C # First offset too big? jlt dbfErrX # Yes do ld E (Z CDR) # More? atom E while z # Yes ld C ((E)) # Next offset shr C 4 # Normalize cmp A C # Matching entry? while ge # No ld Z E # Try next DB extension loop push Y # Save name push ((Z) CDR) # fun ((Obj) ..) ld Y S # Pointer to fun in Y push (L I) # Symbol ld Z S # Z on (last) argument call applyXYZ_E # Apply pop Z # Get symbol add S I # Drop 'fun' pop Y # Get name ld (Z) (E) # Set symbol's value ld E (E CDR) # Properties? atom E if z # Yes ld A E # Set 'extern' tag or A SYM ld (Z TAIL) A # Set property list do atom (E CDR) # Find end while z ld E (E CDR) loop ld (E CDR) Y # Set name else or Y SYM # Set 'extern' tag ld (Z TAIL) Y # Set name end end ld E (L I) # Restore symbol drop pop Z pop Y pop C ret (code 'dbTouchEX 0) push C lea C (E TAIL) # Get tail ld A (C) num A # Any properties? if z # Yes off A SYM # Clear 'extern' tag do lea C (A CDR) # Skip property ld A (C) num A # Find name until nz end rcl A 1 # Already dirty? if nc # No rcl A 1 # Loaded? if c # Yes shr A 1 setc # Set "dirty" rcr A 1 ld (C) A # in status/name pop C ret end shr A 1 setc # Set "dirty" rcr A 1 jmp dbAEX end pop C ret (code 'dbZapE 0) ld A (E TAIL) # Get tail num A # Any properties? if z # Yes off A SYM # Clear 'extern' tag do ld A (A CDR) # Skip property num A # Find name until nz or A SYM # Set 'extern' tag end shl A 2 # Set "deleted" setc rcr A 1 setc rcr A 1 ld (E TAIL) A # Set empty tail ld (E) Nil # Clear value ret # (commit ['any] [exe1] [exe2]) -> T (code 'doCommit 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'any' eval link push E # 'any' link null (DbLog) # Transaction log? if z # No inc (EnvProtect) # Protect the operation end call wrLockDb # Write lock DB null (DbJnl) # Journal? if nz # Yes call lockJnl # Write lock journal end null (DbLog) # Transaction log? if nz # Yes ld E (DbFiles) # Iterate DB files ld C (DBs) # Count do set (E (+ IV 1)) 0 # Clear dirty flag ld (E VII) 0 # and 'fluse' add E VIII # Increment by sizeof(dbFile) sub C VIII # Done? until z # Yes push X push Y ld X Extern # Iterate external symbol tree ld Y 0 # Clear TOS do do ld A (X CDR) # Get subtrees atom (A CDR) # Right subtree? while z # Yes ld C X # Go right ld X (A CDR) # Invert tree ld (A CDR) Y # TOS ld Y C loop do ld A ((X) TAIL) # Get external symbol's tail call nameA_A # Get name rcl A 1 # Dirty or deleted? if c # Yes push Y rcr A 1 ld Y A # Name in Y call dbFileBlkY_AC # Get file and block index cmp A (DBs) # Local file? if lt # Yes call setBlockAC_Z # Set up block env call rdBlockZ_Z # Read first block do call logBlock # Write to transaction log null (BlkLink) # More blocks? while nz # Yes call rdBlockLinkZ_Z # Read next block loop ld C (DbFile) set (C (+ IV 1)) 1 # Set dirty flag rcl Y 2 # Deleted? if nc # No inc (C VII) # Increment 'fluse' end end pop Y end ld A (X CDR) # Left subtree? atom (A) if z # Yes ld C X # Go left ld X (A) # Invert tree ld (A) Y # TOS or C SYM # First visit ld Y C break T end do ld A Y # TOS null A # Empty? jeq 20 # Done sym A # Second visit? if z # Yes ld C (A CDR) # Nodes ld Y (C CDR) # TOS on up link ld (C CDR) X ld X A break T end off A SYM # Set second visit ld C (A CDR) # Nodes ld Y (C) ld (C) X ld X A loop loop loop 20 ld X (DbFiles) # Iterate DB files ld Y (DBs) # Count do ld A (X VII) # Get 'fluse' null A # Any? if nz # Yes push A # Save as count ld A X ld C 0 # Save Block 0 and free list call setBlkAC_Z # Set up block env call rdBlockZ_Z # Read first block do call logBlock # Write to transaction log null (BlkLink) # More blocks? while nz # Yes sub (S) 1 # Decrement count while nc call rdBlockLinkZ_Z # Read next block loop add S I # Drop count end add X VIII # Increment by sizeof(dbFile) sub Y VIII # Done? until z # Yes cc putc_unlocked((hex "FF") (DbLog)) # Write end marker cc putc_unlocked((hex "FF") (DbLog)) cc fflush((DbLog)) # Flush Transaction log call logFileno_A # Sync log file to disk cc fsync(A) nul4 # OK? js trSyncErrX # No pop Y pop X end ld Y (Y CDR) # Eval pre-expression ld E (Y) eval cmp (L I) Nil # 'any'? if eq # No push 0 # No notification else ld A (Tell) or A (Children) push A # Notify flag if nz push A # Tell's buffer pointer push (TellBuf) # Save current 'tell' env sub S PIPE_BUF # New 'tell' buffer ld Z S # Buffer pointer call tellBegZ_Z # Start 'tell' message ld E (L I) # Get 'any' call prTellEZ # Print to 'tell' ld (L -II) Z # Save buffer pointer end end push X push Y ld X Extern # Iterate external symbol tree ld Y 0 # Clear TOS do do ld A (X CDR) # Get subtrees atom (A CDR) # Right subtree? while z # Yes ld C X # Go right ld X (A CDR) # Invert tree ld (A CDR) Y # TOS ld Y C loop do lea C ((X) TAIL) # Get external symbol's tail ld A (C) num A # Any properties? if z # Yes off A SYM # Clear 'extern' tag do lea C (A CDR) # Skip property ld A (C) num A # Find name until nz end rcl A 1 # Dirty? if c # Yes push Y rcl A 1 # Deleted? if nc # No setc # Set "loaded" rcr A 1 shr A 1 ld (C) A # in status/name ld Y A # Name in Y call dbFileBlkY_AC # Get file and block index cmp A (DBs) # Local file? if lt # Yes call setBlockAC_Z # Set up block env call rdBlockZ_Z # Read first block ld B 1 # First block in object (might be a new object) or (Z (- BLK)) B # Set in tag byte ld (PutBinBZ) putBlockBZ # Set binary print function ld Y (X) # Get external symbol ld E (Y) # Print value ld (Extn) 0 # Set external symbol offset to zero call binPrintEZ ld Y (Y TAIL) # Get tail off Y SYM # Clear 'extern' tag do num Y # Properties? while z # Yes atom (Y) # Flag? if z # No ld E ((Y) CDR) # Get key cmp E Nil # Volatile property? if ne # No call binPrintEZ # Print key ld E ((Y)) # Print value call binPrintEZ end else ld E (Y) # Get key cmp E Nil # Volatile property? if ne # No call binPrintEZ # Print key ld E TSym # Print 'T' call binPrintEZ end end ld Y (Y CDR) loop ld A NIX call putBlockBZ # Output NIX ld Z (DbBlock) # Block buffer in Z again ld B (Z) # Lowest byte of link field and B BLKTAG # Clear link zxt call setAdrAZ # Store in last block call wrBlockZ # Write block ld Y (BlkLink) # More blocks? null Y if nz # Yes call cleanUpY # Clean up end null (L -I) # Notify? if nz # Yes ld Z (L -II) # Get buffer pointer lea A ((TellBuf) (- PIPE_BUF 10)) # Space for EXTERN+<8>+END? cmp Z A if ge # No ld A 0 # Send to all PIDs call tellEndAZ # Close 'tell' lea Z (L (- (+ III PIPE_BUF))) # Reset buffer pointer call tellBegZ_Z # Start new 'tell' message ld E (L I) # Get 'any' call prTellEZ # Print to 'tell' end ld E (X) # Get external symbol call prTellEZ # Print to 'tell' ld (L -II) Z # Save buffer pointer end end else # Deleted shr A 2 # Set "not loaded" ld (C) A # in status/name ld Y A # Name in Y call dbFileBlkY_AC # Get file and block index cmp A (DBs) # Local file? if lt # Yes add A (DbFiles) # Get DB file ld (DbFile) A # Set current ld Y C call cleanUpY # Clean up null (L -I) # Notify? if nz # Yes ld Z (L -II) # Get buffer pointer lea A ((TellBuf) (- PIPE_BUF 10)) # Space for EXTERN+<8>+END? cmp Z A if ge # No ld A 0 # Send to all PIDs call tellEndAZ # Close 'tell' lea Z (L (- (+ III PIPE_BUF))) # Reset buffer pointer call tellBegZ_Z # Start new 'tell' message ld E (L I) # Get 'any' call prTellEZ # Print to 'tell' end ld E (X) # Get external symbol call prTellEZ # Print to 'tell' ld (L -II) Z # Save buffer pointer end end end pop Y end ld A (X CDR) # Left subtree? atom (A) if z # Yes ld C X # Go left ld X (A) # Invert tree ld (A) Y # TOS or C SYM # First visit ld Y C break T end do ld A Y # TOS null A # Empty? jeq 40 # Done sym A # Second visit? if z # Yes ld C (A CDR) # Nodes ld Y (C CDR) # TOS on up link ld (C CDR) X ld X A break T end off A SYM # Set second visit ld C (A CDR) # Nodes ld Y (C) ld (C) X ld X A loop loop loop 40 pop Y pop X null (L -I) # Notify? if nz # Yes ld A 0 # Send to all PIDs ld Z (L -II) # Get buffer pointer call tellEndAZ # Close 'tell' add S PIPE_BUF # Drop 'tell' buffer pop (TellBuf) end ld Y (Y CDR) # Eval post-expression ld E (Y) eval null (DbJnl) # Journal? if nz # Yes call unLockJnl # Unlock journal end ld Y (Zap) # Objects to delete? atom Y if z # Yes push (OutFile) # Save output channel sub S (+ III BUFSIZ) # Local buffer with sizeof(outFile) ld E (Y CDR) # Get zap file pathname call pathStringE_SZ # Write to stack buffer cc open(S (| O_APPEND O_CREAT O_WRONLY) (oct "0666")) # Open zap file nul4 # OK? js openErrEX # No ld S Z # Drop buffer ld (S) A # Store 'fd' in outFile ld (S I) 0 # Clear 'ix' ld (S II) 0 # and 'tty' ld (OutFile) S # Set OutFile ld (PutBinBZ) putStdoutB # Set binary print function ld Y (Y) # Get zap list do atom Y # More symbols? while z # Yes ld E (Y) # Get next ld (Extn) 0 # Set external symbol offset to zero call binPrintEZ # Print it ld Y (Y CDR) loop ld A S # Flush file call flushA_F ld A S # Close file call closeAX ld ((Zap)) Nil # Clear zap list add S (+ III BUFSIZ) # Drop buffer pop (OutFile) # Restore output channel end null (DbLog) # Transaction log? if nz # Yes call fsyncDB # Sync DB files to disk call truncLog # Truncate log file end ld A 0 # Length call rwUnlockDbA # Unlock all call unsync # Release sync null (DbLog) # Transaction log? if z # No dec (EnvProtect) # Unprotect end ld E (DbFiles) # Iterate DB files ld C (DBs) # Count do ld (E VII) -1 # Init 'fluse' add E VIII # Increment by sizeof(dbFile) sub C VIII # Done? until z # Yes drop pop Z pop Y pop X ld E TSym # Return T ret # (rollback) -> flg (code 'doRollback 2) null (DBs) # DB open? jz retNil # No push X push Y ld X Extern # Iterate external symbol tree ld Y 0 # Clear TOS do do ld A (X CDR) # Get subtrees atom (A CDR) # Right subtree? while z # Yes ld C X # Go right ld X (A CDR) # Invert tree ld (A CDR) Y # TOS ld Y C loop do ld E (X) # Get external symbol ld A (E TAIL) num A # Any properties? if z # Yes off A SYM # Clear 'extern' tag do ld A (A CDR) # Skip property num A # Find name until nz or A SYM # Set 'extern' tag end shl A 2 # Strip status bits shr A 2 ld (E TAIL) A # Set status/name ld (E) Nil # Clear value ld A (X CDR) # Left subtree? atom (A) if z # Yes ld C X # Go left ld X (A) # Invert tree ld (A) Y # TOS or C SYM # First visit ld Y C break T end do ld A Y # TOS null A # Empty? jeq 90 # Done sym A # Second visit? if z # Yes ld C (A CDR) # Nodes ld Y (C CDR) # TOS on up link ld (C CDR) X ld X A break T end off A SYM # Set second visit ld C (A CDR) # Nodes ld Y (C) ld (C) X ld X A loop loop loop 90 ld Y (Zap) # Objects to delete? atom Y if z # Yes ld (Y) Nil # Clear zap list end ld A 0 # Length call rwUnlockDbA # Unlock all call unsync # Release sync pop Y pop X ld E TSym # Return T ret # (mark 'sym|0 [NIL | T | 0]) -> flg (code 'doMark 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval cmp E ZERO # Zero? if eq # Yes ld X (DbFiles) # Iterate DB files ld Y (DBs) # Count do sub Y VIII # Done? while ge # No ld (X V) 0 # Mark vector size zero cc free((X VI)) # Free mark bit vector ld (X VI) 0 # Set to null add X VIII # Increment by sizeof(dbFile) loop ld E Nil # Return NIL pop Y pop X ret end num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? jz extErrEX # No push E # 'sym' ld E ((Y CDR)) # Eval second arg eval xchg E (S) # NIL | T | 0 call fileObjE_AC # Get file and ID shl A 6 # 'dbFile' index cmp A (DBs) # Local file? jge dbfErrX # No add A (DbFiles) # Get DB file ld X A # into X ld E C # Object ID in E shr E 3 # Byte position cmp E (X V) # Greater or equal to mark vector size? if ge # Yes push E # Save byte position inc E # New size ld Y E # Keep in Y ld A (X VI) # Get mark bit vector call allocAE_A # Increase to new size ld (X VI) A xchg E (X V) # Store size in 'dbFile', get old size sub Y E # Length of new area add E A # Start position of new area ld B 0 # Clear new area mset (E) Y pop E # Restore byte position end add E (X VI) # Byte position in bit vector and C 7 # Lowest three bits of object ID ld B 1 # Bit position shl B C # in B test (E) B # Bit test if z # Not set cmp (S) TSym # Second arg 'T'? if eq # Yes or (E) B # Set mark end ld E Nil # Return NIL else # Bit was set cmp (S) ZERO # Second arg '0'? if eq # Yes not B and (E) B # Clear mark end ld E TSym # Return T end add S I # Drop second arg pop Y pop X ret # (free 'cnt) -> (sym . lst) (code 'doFree 2) push X push Y push Z ld X E ld E ((E CDR)) # Eval 'cnt' call evCntEX_FE dec E # File is zero-based shl E 6 # 'dbFile' index cmp E (DBs) # Local file? jge dbfErrX # No add E (DbFiles) # Get DB file ld (DbFile) E # Set current call rdLockDb # Lock for reading ld C (* 2 BLK) # Read 'free' and 'next' ld E 0 # from block zero ld Z Buf # into 'Buf' call blkPeekCEZ call getAdrZ_A # Get 'free' ld (BlkLink) A # Store as next block add Z BLK call getAdrZ_A # Get 'next' ld C A # Object ID shr C 6 # Normalize ld E ((DbFile) I) # Get file number call extNmCE_X # Build external symbol name call externX_E # New external symbol call cons_Y # Cons as CAR of result list ld (Y) E ld (Y CDR) Nil link push Y # (L I) Result list link do # Collect free list ld C (BlkLink) # Next free block? null C while nz # Yes shr C 6 # Normalize ld E ((DbFile) I) # Get file number call extNmCE_X # Build external symbol name call externX_E # New external symbol call cons_A # Next cell ld (A) E ld (A CDR) Nil ld (Y CDR) A # Append ot result list ld Y A call rdBlockLinkZ_Z # Read next block loop ld A (hex "10000") # Length 1 call rwUnlockDbA # Unlock ld E (L I) # Get result list drop pop Z pop Y pop X ret # (dbck ['cnt] 'flg) -> any (code 'doDbck 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval ld (DbFile) (DbFiles) # Default to first dbFile cnt E # 'cnt' arg? if nz # Yes off E 15 # Normalize + 'dbFile' index sub E (hex "10") # Zero-based shl E 2 cmp E (DBs) # Local file? jge dbfErrX # No add E (DbFiles) # Get DB file ld (DbFile) E # Set current ld Y (Y CDR) # Next arg ld E (Y) eval # Eval next arg end push (DbJnl) # Journal push E # 'flg' push ZERO # 'syms' push ZERO # 'blks' inc (EnvProtect) # Protect the operation call wrLockDb # Write lock DB null (DbJnl) # Journal? if nz # Yes call lockJnl # Write lock journal end ld C (* 2 BLK) # Read 'free' and 'next' ld E 0 # from block zero ld Z Buf # into 'Buf' call blkPeekCEZ call getAdrZ_A # Get 'free' ld (BlkLink) A # Store as next block add Z BLK call getAdrZ_A # Get 'next' push A # 'next' ld Y BLKSIZE # 'cnt' in Y ld (DbJnl) 0 # Disable Journal do # Check free list ld A (BlkLink) # Next block? null A while nz # Yes call rdBlockIndexAZ_Z # Read next block add Y BLKSIZE # Increment 'cnt' cmp Y (S) # Greater than 'next'? if gt # Yes ld E CircFree # Circular free list call mkStrE_E # Return message jmp 90 end ld Z (DbBlock) # Block buffer in Z again or (Z) BLKTAG # Mark free list call wrBlockZ # Write block loop ld (DbJnl) (S IV) # Restore Journal ld X BLKSIZE # 'p' in X do # Check all chains cmp X (S) # Reached 'next'? while ne # No ld A X # Get 'p' call rdBlockIndexAZ_Z # Read next block sub Z BLK # Block buffer in Z again ld B (Z) # Get tag byte and B BLKTAG # Block tag zero? if z # Yes add Y BLKSIZE # Increment 'cnt' movn (Z) (Buf) BLK # Insert into free list call wrBlockZ # Write block ld A X # Write 'free' ld Z Buf # into 'Buf' call setAdrAZ ld C BLK ld E 0 # 'free' address call blkPokeCEZ # Write 'Buf' else cmp B 1 # ID-block of symbol? if eq # Yes push X add (S II) (hex "10") # Increment 'blks' add (S III) (hex "10") # Increment 'syms' add Y BLKSIZE # Increment 'cnt' ld X 2 # Init 'i' do ld A (BlkLink) # Next block? null A while nz # Yes add Y BLKSIZE # Increment 'cnt' add (S II) (hex "10") # Increment 'blks' call rdBlockIndexAZ_Z # Read next block ld B (Z (- BLK)) # Get tag byte and B BLKTAG # Block tag cmp B X # Same as 'i'? if ne # No ld E BadChain # Bad object chain call mkStrE_E # Return message jmp 90 end cmp X BLKTAG # Less than maximum? if lt # Yes inc X # Increment end loop pop X end end add X BLKSIZE # Increment 'p' loop ld Z Buf # Get 'free' call getAdrZ_A ld (BlkLink) A # Store as next block ld (DbJnl) 0 # Disable Journal do # Unmark free list null A # Any? while nz # Yes call rdBlockIndexAZ_Z # Read next block sub Z BLK # Block buffer in Z again ld B (Z) # Get tag byte and B BLKTAG # Block tag non-zero? if nz # Nes off (Z) BLKTAG # Clear tag call wrBlockZ # Write block end ld A (BlkLink) # Get next block loop cmp Y (S) # 'cnt' == 'next'? if ne # No ld E BadCount # Circular free list call mkStrE_E # Return message else cmp (S III) Nil # 'flg' is NIL? ldz E Nil # Yes: Return NIL if ne # No call cons_E # Return (blks . syms) ld (E) (S I) # 'blks' ld (E CDR) (S II) # 'syms' end end 90 add S IV # Drop 'next', 'blks', 'syms' and 'flg' pop (DbJnl) # Restore Journal null (DbJnl) # Any? if nz # Yes call unLockJnl # Unlock journal end ld A (hex "10000") # Length 1 call rwUnlockDbA # Unlock dec (EnvProtect) # Unprotect pop Z pop Y pop X ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/defs.l0000644000000000000000000000305112265263724015206 0ustar rootroot# 19may13abu # (c) Software Lab. Alexander Burger # Constants (equ HEAP (* 1024 1024)) # Heap size in bytes (equ CELLS (/ HEAP 16)) # Number of cells in a single heap (65536) (equ STACK (* 1024 1024)) # Default coroutine stack segment size (1 MB) (equ ZERO (short 0)) # Short number '0' (equ ONE (short 1)) # Short number '1' (equ TOP (hex "10000")) # Character top (equ DB1 (hex "1A")) # Name of '{1}' # Pointer offsets (equ I 8) (equ II 16) (equ III 24) (equ IV 32) (equ V 40) (equ VI 48) (equ VII 56) (equ VIII 64) (equ IX 72) (equ -I . -8) (equ -II . -16) (equ -III . -24) (equ -IV . -32) (equ -V . -40) (equ -VI . -48) (equ -VII . -56) (equ -VIII . -64) # Cell offsets (equ CNT 2) # Count tag (equ BIG 4) # Rest of a bignum + bignum tag (equ DIG -4) # First digit of a big number (equ CDR 8) # CDR part of a cons pair (equ SIGN 8) # Sign bit of a number (equ SYM 8) # Symbol tag (equ TAIL -8) # Tail of a symbol # I/O Tokens (equ NIX 0) # NIL (equ BEG 1) # Begin list (equ DOT 2) # Dotted pair (equ END 3) # End list (equ NUMBER 0) # Number (equ INTERN 1) # Internal symbol (equ TRANSIENT 2) # Transient symbol (equ EXTERN 3) # External symbol # DB-I/O (equ BLK 6) # Block address size (equ BLKSIZE 64) # DB block unit size (equ BLKTAG 63) # Block tag mask # Networking (equ UDPMAX 4096) # UDP buffer size # Case mappings from the GNU Kaffe Project (equ CHAR_UPPERCASE 1) (equ CHAR_LOWERCASE 2) (equ CHAR_LETTER 62) (equ CHAR_DIGIT 512) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/err.l0000644000000000000000000003520212265263724015060 0ustar rootroot# 05jul13abu # (c) Software Lab. Alexander Burger # Debug print routine (code 'dbgS) xchg E (S) # Get return address xchg E (S I) # Get argument, save return push C # Save all registers push A push (OutFile) # Save output channel ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) push (PutB) # Save 'put' ld (PutB) putStdoutB # Set new call printE_E # Print argument call newline # and a newline pop (PutB) # Restore 'put' pop (OutFile) # and output channel pop A pop C pop E ret # System error number (code 'errnoEXY) call errno_A # Get 'errno' cc strerror(A) # Convert to string ld Z A # E reason # X context # Y message format # Z message parameter (code 'errEXYZ) null E # Reason? if nz # Yes link push E # Save reason link else push E # Push reason sub S I # and dummy end sub S (+ 240 IV) # Message, outFrame, reason cc snprintf(S 240 Y Z) # Build message null X # Error context? ld A Nil ldnz A X # Yes ld (Up) A # Save it nul (S) # Message empty? if nz # No ld E S # Make transient symbol call mkStrE_E ld (Msg) E # Store in '*Msg' ld C (Catch) # Search catch frames do null C # Any? while nz # Yes ld Y (C I) # Tag non-zero? null Y if nz # Yes do atom Y # List? while z # Yes ld A (Y) # Next element of tag list ld E (Msg) # Substring of '*Msg'? push C call subStrAE_F pop C if eq # Yes ld Y (Y) # Get tag list element cmp Y Nil # NIL? ldz Y (Msg) # Yes: Use *Msg instead push Y # Save tag list element call unwindC_Z # Unwind environments pop E # Return tag list element from 'catch' ld S Z # Restore stack jmp caught end ld Y (Y CDR) # Tag list loop end ld C (C) # Next frame loop end ld (Chr) 0 # Init globals ld (ExtN) 0 ld (Break) 0 ld (Alarm) Nil ld (Sigio) Nil ld (LineX) ZERO ld (LineC) -1 lea Y (S 240) # Pointer to outFrame ld (Y I) 2 # fd = stderr ld (Y II) 0 # pid = 0 call pushOutFilesY ld Y (InFile) # Current InFile null Y # Any? if nz # Yes ld C (Y VI) # Filename? null C if nz # Yes ld B (char "[") # Output location call (PutB) call outStringC # Print filename ld B (char ":") # Separator ':' call (PutB) ld A (Y V) # Get 'src' call outWordA # Print line number ld B (char "]") call (PutB) call space end end null X # Error context? if nz # Yes ld C ErrTok # Print error token call outStringC ld E X # Get context call printE # Print context call newline end ld E (S (+ 240 V)) # Get reason null E # any? if nz # Yes call printE # Print reason ld C Dashes # Print " -- " call outStringC end nul (S) # Message empty? if nz # No call outStringS # Print message call newline cmp (Err) Nil # Error handler? if ne # Yes nul (Jam) # Jammed? if z # No set (Jam) 1 # Set flag ld X (Err) # Run error handler prog X set (Jam) 0 # Reset flag end end ld E 1 # Exit error code cc isatty(0) # STDIN nul4 # on a tty? jz byeE # No cc isatty(1) # STDOUT nul4 # on a tty? jz byeE # No ld B (char "?") # Prompt ld E Nil # Load argument ld X 0 # Runtime expression call loadBEX_E end ld C 0 # Top frame call unwindC_Z # Unwind ld (EnvProtect) 0 # Reset environments ld (EnvIntern) pico ld (EnvTask) Nil ld (EnvCo7) 0 ld (EnvArgs) 0 ld (EnvNext) 0 ld (EnvMake) 0 ld (EnvYoke) 0 ld (EnvTrace) 0 ld L 0 # Init link register ld S (Stack0) # stack pointer null (Stacks) # Coroutines? if nz # Yes lea A (S 4096) # Set stack limit sub A (StkSize) ld (StkLimit) A end jmp restart # Restart interpreter (code 'unwindC_Z 0) push C # Target frame ld X (Catch) # Catch link ld Y (EnvBind) # Bindings do null X # Catch frames? while nz # Yes do null Y # Bindings? while nz # Yes ld C (Y -I) # First env swap null C # Zero? if nz # No ld A C # 'j' ld E 0 # 'n' ld Z Y # Bindings in Z do inc E # Increment 'n' inc A # Done? while nz # No ld Z ((Z) I) # Follow link null Z # Any? while nz # Yes cmp (Z -I) C # Env swap nesting? if lt # Yes dec A # Adjust end loop do ld Z Y # Get bindings ld A E # and 'n' do dec A # 'n-1' times while nz ld Z ((Z) I) # Follow link loop sub (Z -I) C # Increment 'eswp' by absolute first eswp if ge # Last pass if gt # Overflowed ld (Z -I) 0 # Reset end lea A ((Z) -II) # End of bindings in A do xchg ((A)) (A I) # Exchange next symbol value with saved value sub A II cmp A Z # More? until lt # No end dec E # Decrement 'n' until z # Done end cmp Y (X III) # Reached last bind frame? while ne # No ld C (Y) # C on link null (Y -I) # Env swap now zero? if z # Yes add Y I # Y on bindings do ld Z (Y) # Next symbol add Y I ld (Z) (Y) # Restore value add Y I cmp Y C # More? until eq # No end ld Y (C I) # Bind link loop do cmp (EnvInFrames) (X (pack III "+(EnvInFrames-Env)")) # Open input frames? while ne # Yes call popInFiles # Clean up loop do cmp (EnvOutFrames) (X (pack III "+(EnvOutFrames-Env)")) # Open output frames? while ne # Yes call popOutFiles # Clean up loop do cmp (EnvErrFrames) (X (pack III "+(EnvErrFrames-Env)")) # Open error frames? while ne # Yes call popErrFiles # Clean up loop do cmp (EnvCtlFrames) (X (pack III "+(EnvCtlFrames-Env)")) # Open control frames? while ne # Yes call popCtlFiles # Clean up loop ld Z (EnvCo7) # Get coroutines do cmp Z (X (pack III "+(EnvCo7-Env)")) # Skipped? while ne # Yes ld C (Stack1) # Find stack segment do cmp C (Z II) # Found 'seg'? while ne # No sub C (StkSize) # Next segment loop ld (C -I) 0 # Mark segment as unused dec (Stacks) # Last coroutine? if z # Yes ld (StkLimit) 0 # Clear stack limit end ld Z (Z) # Next coroutine loop load (Env) (EnvEnd) (X III) # Restore environment ld E (X II) # 'fin' eval # Evaluate 'finally' expression cmp X (S) # Reached target catch frame? ld X (X) # Catch link ld (Catch) X if eq # Yes pop Z # Get target frame ret end loop add S I # Drop target frame do # Top level bindings null Y # Any? while nz # Yes ld C (Y) # C on link null (Y -I) # Env swap zero? if z # Yes add Y I # Y on bindings do ld Z (Y) # Next symbol add Y I ld (Z) (Y) # Restore value add Y I cmp Y C # More? until eq # No end ld Y (C I) # Bind link loop ld (EnvBind) 0 do null (EnvInFrames) # Open input frames? while nz # Yes call popInFiles # Clean up loop do null (EnvOutFrames) # Open output frames? while nz # Yes call popOutFiles # Clean up loop do null (EnvErrFrames) # Open error frames? while nz # Yes call popErrFiles # Clean up loop do null (EnvCtlFrames) # Open control frames? while nz # Yes call popCtlFiles # Clean up loop ld X (Stack1) # Search through stack segments ld C (Stacks) # Segment count do null C # Any? while nz # Yes null (X -I) # In use? if nz # Yes null (X -II) # Active? if z # Yes ld (X -I) 0 # Mark segment as unused dec (Stacks) # Last coroutine? if z # Yes ld (StkLimit) 0 # Clear stack limit end end dec C # Decrement count end sub X (StkSize) # Next segment loop ret ### Checks ### (code 'needSymAX 0) num A # Need symbol jnz symErrAX sym A jz symErrAX cmp A Nil # A < NIL ? jlt ret # Yes cmp A TSym # A > T ? jgt Ret # Yes ld E A jmp protErrEX (code 'needSymEX 0) num E # Need symbol jnz symErrEX sym E jz symErrEX cmp E Nil # E < NIL ? jlt ret # Yes cmp E TSym # E > T ? jgt Ret # Yes jmp protErrEX (code 'needVarAX 0) num A # Need variable jnz varErrAX cmp A Nil # A < NIL ? jlt ret # Yes cmp A TSym # A > T ? jgt Ret # Yes ld E A jmp protErrEX (code 'needVarEX 0) num E # Need variable jnz varErrEX cmp E Nil # E < NIL ? jlt ret # Yes cmp E TSym # E > T ? jgt Ret # Yes jmp protErrEX (code 'checkVarAX 0) cmp A Nil # A < NIL ? jlt ret # Yes cmp A TSym # A > T ? jgt Ret # Yes ld E A jmp protErrEX (code 'checkVarYX 0) cmp Y Nil # Y < NIL ? jlt ret # Yes cmp Y TSym # Y > T ? jgt Ret # Yes ld E Y jmp protErrEX (code 'checkVarEX 0) cmp E Nil # E < NIL ? jlt ret # Yes cmp E TSym # E > T ? jgt Ret # Yes (code 'protErrEX) ld Y ProtErr jmp errEXYZ (code 'symNsErrEX) ld Y SymNsErr jmp errEXYZ ### Error messages ### (code 'stkErr) ld E 0 (code 'stkErrE) ld X E (code 'stkErrX) ld E 0 (code 'stkErrEX) ld Y StkErr ld (StkLimit) 0 # Reset stack limit jmp errEXYZ (code 'argErrAX) ld E A (code 'argErrEX) ld Y ArgErr jmp errEXYZ (code 'numErrAX) ld E A (code 'numErrEX) ld Y NumErr jmp errEXYZ (code 'cntErrAX) ld C A (code 'cntErrCX) ld E C (code 'cntErrEX) ld Y CntErr jmp errEXYZ (code 'symErrAX) ld Y A (code 'symErrYX) ld E Y (code 'symErrEX) ld Y SymErr jmp errEXYZ (code 'extErrEX) ld Y ExtErr jmp errEXYZ (code 'pairErrAX) ld E A (code 'pairErrEX) ld Y PairErr jmp errEXYZ (code 'atomErrAX) ld E A (code 'atomErrEX) ld Y AtomErr jmp errEXYZ (code 'lstErrAX) ld E A (code 'lstErrEX) ld Y LstErr jmp errEXYZ (code 'varErrAX) ld E A (code 'varErrEX) ld Y VarErr jmp errEXYZ (code 'divErrX) ld E 0 ld Y DivErr jmp errEXYZ (code 'renErrEX) ld Y RenErr jmp errEXYZ (code 'makeErrX) ld E 0 ld Y MakeErr jmp errEXYZ (code 'reentErrEX) ld Y ReentErr jmp errEXYZ (code 'yieldErrX) ld E 0 (code 'yieldErrEX) ld Y YieldErr jmp errEXYZ (code 'msgErrYX) ld A Y (code 'msgErrAX) ld E A (code 'msgErrEX) ld Y MsgErr jmp errEXYZ (code 'brkErrX) ld E 0 ld Y BrkErr jmp errEXYZ # I/O errors (code 'openErrEX) ld Y OpenErr jmp errnoEXY (code 'closeErrX) ld E 0 (code 'closeErrEX) ld Y CloseErr jmp errnoEXY (code 'pipeErrX) ld E 0 ld Y PipeErr jmp errnoEXY (code 'forkErrX) ld E 0 ld Y ForkErr jmp errEXYZ (code 'waitPidErrX) ld E 0 ld Y WaitPidErr jmp errnoEXY (code 'badFdErrEX) ld Y BadFdErr jmp errEXYZ (code 'noFdErrX) ld E 0 ld Y NoFdErr jmp errEXYZ (code 'eofErr) ld E 0 ld X 0 ld Y EofErr jmp errEXYZ (code 'suparErrE) ld X 0 ld Y SuparErr jmp errEXYZ (code 'badInputErrB) zxt ld Z A ld E 0 ld X 0 ld Y BadInput jmp errEXYZ (code 'badDotErrE) ld X 0 ld Y BadDot jmp errEXYZ (code 'selectErrX) ld E 0 ld Y SelectErr jmp errnoEXY (code 'wrBytesErr) ld E 0 ld X 0 ld Y WrBytesErr jmp errnoEXY (code 'wrChildErr) ld E 0 ld X 0 ld Y WrChildErr jmp errnoEXY (code 'wrSyncErrX) ld E 0 ld Y WrSyncErr jmp errnoEXY (code 'wrJnlErr) ld E 0 ld X 0 ld Y WrJnlErr jmp errnoEXY (code 'wrLogErr) ld E 0 ld X 0 ld Y WrLogErr jmp errnoEXY (code 'truncErrX) ld E 0 ld Y TruncErr jmp errnoEXY (code 'dbSyncErrX) ld E 0 ld Y DbSyncErr jmp errnoEXY (code 'trSyncErrX) ld E 0 ld Y TrSyncErr jmp errnoEXY (code 'lockErr) ld E 0 ld X 0 ld Y LockErr jmp errnoEXY (code 'dbfErrX) ld E 0 ld Y DbfErr jmp errEXYZ (code 'jnlErrX) ld E 0 ld Y JnlErr jmp errEXYZ (code 'idErrXL) ld E (L I) # Get symbol ld Y IdErr jmp errEXYZ (code 'dbRdErr) ld E 0 ld X 0 ld Y DbRdErr jmp errnoEXY (code 'dbWrErr) ld E 0 ld X 0 ld Y DbWrErr jmp errnoEXY (code 'dbSizErr) ld E 0 ld X 0 ld Y DbSizErr jmp errEXYZ (code 'tellErr) ld E 0 ld X 0 ld Y TellErr jmp errEXYZ (code 'ipSocketErrX) ld E 0 ld Y IpSocketErr jmp errnoEXY (code 'ipGetsocknameErrX) ld E 0 ld Y IpGetsocknameErr jmp errnoEXY (code 'ipV6onlyErrX) ld E 0 ld Y IpV6onlyErr jmp errnoEXY (code 'ipReuseaddrErrX) ld E 0 ld Y IpReuseaddrErr jmp errnoEXY (code 'ipBindErrX) ld E 0 ld Y IpBindErr jmp errnoEXY (code 'ipListenErrX) ld E 0 ld Y IpListenErr jmp errnoEXY (code 'udpOvflErr) ld E 0 ld X 0 ld Y UdpOvflErr jmp errEXYZ ### Undefined symbol ### (code 'undefinedCE) ld X E (code 'undefinedCX) ld E C (code 'undefinedEX) ld Y UndefErr jmp errEXYZ (code 'dlErrX) ld E 0 cc dlerror() # Get dynamic loader error message ld Y DlErr ld Z A jmp errEXYZ ### Global return labels ### (code 'ret 0) ret (code 'retc 0) setc ret (code 'retnc 0) clrc ret (code 'retz 0) setz ret (code 'retnz 0) clrz ret (code 'retNull 0) ld E 0 ret (code 'retNil 0) ld E Nil ret (code 'retT 0) ld E TSym ret (code 'retE_E 0) ld E (E) # Get value or CAR ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/ext.l0000644000000000000000000001756412265263724015103 0ustar rootroot# 18feb13abu # (c) Software Lab. Alexander Burger (data 'ExtData) initData ### Soundex Algorithm ### (data 'SnxTab) bytes ( (char "0") (char "1") (char "2") (char "3") (char "4") (char "5") (char "6") (char "7") # 48 (char "8") (char "9") 0 0 0 0 0 0 0 0 (char "F") (char "S") (char "T") 0 (char "F") (char "S") # 64 0 0 (char "S") (char "S") (char "L") (char "N") (char "N") 0 (char "F") (char "S") (char "R") (char "S") (char "T") 0 (char "F") (char "F") (char "S") 0 (char "S") 0 0 0 0 0 0 0 (char "F") (char "S") (char "T") 0 (char "F") (char "S") # 96 0 0 (char "S") (char "S") (char "L") (char "N") (char "N") 0 (char "F") (char "S") (char "R") (char "S") (char "T") 0 (char "F") (char "F") (char "S") 0 (char "S") 0 0 0 0 0 0 0 0 0 0 0 0 0 # 128 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 # 160 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 (char "S") # 192 0 0 0 0 0 0 0 0 (char "T") (char "N") 0 0 0 0 0 (char "S") 0 0 0 0 0 0 0 (char "S") 0 0 0 0 0 0 0 (char "S") # 224 0 0 0 0 0 0 0 0 0 (char "N") ) (equ SNXBASE 48) (equ SNXSIZE (+ (* 24 8) 2)) (code 'ExtCode) initCode # (ext:Snx 'any ['cnt]) -> sym (code 'Snx 2) push X push Y ld X E ld Y (E CDR) # Y on args call evSymY_E # Eval 'any' cmp E Nil if ne # No ld E (E TAIL) call nameE_E # Get name link push E # Save Name link ld Y (Y CDR) # Next arg atom Y # Any? ldnz E 24 # Default to 24 if z # Yes call evCntXY_FE # Eval 'cnt' end tuck ZERO # Result ld X S link push 4 # Build name push X # Pack status ld X (L II) # Get name ld C 0 # Index do call symCharCX_FACX # First char? jz 90 # No cmp A SNXBASE # Too small? until ge # No cmp A (char "a") # Lower case? if ge cmp A (char "z") jle 40 # Yes end cmp A 128 jeq 40 # Yes cmp A 224 if ge cmp A 255 if le # Yes 40 off B 32 # Convert to lower case end end push A # Last character xchg C (S II) # Swap status xchg X (S I) call charSymACX_CX # Pack first char xchg X (S I) # Swap status xchg C (S II) do call symCharCX_FACX # Next char? while nz # Yes cmp A 32 # Non-white? if gt # Yes sub A SNXBASE # Too small? jlt 60 # Yes cmp A SNXSIZE # Too big? jge 60 # Yes ld B (A SnxTab) # Character entry? zxt or A A if z # No 60 ld (S) 0 # Clear last character else cmp A (S) # Same as last? if ne # No dec E # Decrement count break z ld (S) A # Save last character xchg C (S II) # Swap status xchg X (S I) call charSymACX_CX # Pack char xchg X (S I) # Swap status xchg C (S II) end end end loop 90 ld X (L I) # Get result call consSymX_E # Make transient symbol drop end pop Y pop X ret ### File Descriptor ### # (ext:FD 'cnt) -> fd (code 'FD 2) push X ld X E ld E ((E CDR)) # Eval 'cnt' eval push E # Save result call xCntEX_FE if ns ld X E # Keep file descriptor ld A E call initInFileA_A # Init input file ld A X call initOutFileA_A # and output file end pop E # Get result pop X ret ### Audio Data ### (equ BIAS 132) (equ CLIP (- 32767 BIAS)) # (ext:Ulaw 'cnt) -> cnt # SEEEMMMM (code 'Ulaw 2) push X ld X E ld E ((E CDR)) # Get arg eval # Eval 'cnt' cnt E # # Short number? jz cntErrEX # No ld X 0 # No sign shr E 4 # Normalize if c # Negative? ld X (hex "80") # Set sign end cmp E (+ CLIP 1) # Clip the value ldnc E CLIP add E BIAS # Increment by BIAS ld A E # Double value add A A # in 'tmp' ld C 7 # Exponent do test A (hex "8000") while z add A A # Double 'tmp' dec C # Decrement exponent until z ld A C # Get exponent add A 3 # plus 3 shr E A # Shift value right and E 15 # Lowest 4 bits shl C 4 # Shift exponent left or E C # Combine with value or E X # and sign not E # Negate and E (hex "FF") # Get byte value shl E 4 # Make short number or E CNT pop X ret ### Base64 Encoding ### (data 'Chr64) ascii "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" # (ext:Base64 'num1|NIL ['num2|NIL ['num3|NIL]]) -> flg (code 'Base64 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first 'num|NIL' eval cmp E Nil # NIL? if ne # No shr E 4 # Normalize first arg ld Z E # Keep in Z shr E 2 # Upper 6 bits call chr64E # Output encoded ld Y (Y CDR) # Next arg ld E (Y) eval # Eval second arg cmp E Nil # NIL? if eq # Yes ld E Z # Get first arg and E 3 # Mask shl E 4 # Shift to upper position call chr64E # Output encoded ld B (char "=") # and two equal signs call (PutB) ld B (char "=") call (PutB) ld E Nil # Return NIL else shr E 4 # Normalize second arg and Z 3 # Mask first arg shl Z 4 # Shift to upper position ld A E # Get second arg shr A 4 # Normalize or A Z # Combine ld Z E # Keep second arg in Z call chr64A # Output encoded ld Y (Y CDR) # Next arg ld E (Y) eval # Eval third arg cmp E Nil # NIL? if eq # Yes ld A Z # Get second and A 15 # Lowest four bits shl A 2 # Shift call chr64A # Output encoded ld B (char "=") # and an equal sign call (PutB) ld E Nil # Return NIL else shr E 4 # Normalize third arg ld A E shr A 6 # Upper bits and Z 15 # Lowest four bits of second arg shl Z 2 # Shift or A Z # Combine call chr64A # Output encoded and E 63 # Last arg call chr64E # Output encoded ld E TSym # Return T end end end pop Z pop Y pop X ret (code 'chr64E) ld A E (code 'chr64A) ld B (A Chr64) # Fetch from table jmp (PutB) # Output byte # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/flow.l0000644000000000000000000025020112265263724015235 0ustar rootroot# 14nov13abu # (c) Software Lab. Alexander Burger (code 'redefMsgEC) push (OutFile) # Save output channel ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) push (PutB) # Save 'put' ld (PutB) putStdoutB # Set new push C # Save optional class ld C HashBlank # Print comment call outStringC call printE # Print sym pop E # Class? null E if nz # Yes call space call printE_E # Print class end ld C Redefined # Print message call outStringC pop (PutB) # Restore 'put' pop (OutFile) # and output channel ret (code 'putSrcEC_E) cmp (Dbg) Nil # Debug? if ne # Yes sym (E TAIL) # External symbol? if z # No ld A (InFile) # Current InFile null A # Any? if nz # Yes null (A VI) # Filename? if nz # Yes push X push E # sym push C # key ld C Dbg call getEC_E # Get '*Dbg' properties ld X E # into X ld E ((InFile) VI) # Get filename call mkStrE_E # Make string ld A ((InFile) V) # Get 'src' shl A 4 # Make short number or A CNT push E call consE_E # ( . "filename") ld (E) A pop (E CDR) ld A (S) # Get key null A # Any? if z # No cmp X Nil # '*Dbg' properties? if eq # No push E call consE_E # Make list pop (E) ld (E CDR) Nil ld A (S I) # Put initial '*Dbg' properties ld C Dbg call putACE else ld (X) E # Set first '*Dbg' property end else cmp X Nil # '*Dbg' properties? if eq # No call consE_C # Make list ld (C) E ld (C CDR) Nil call consC_E # Empty first property ld (E) Nil ld (E CDR) C ld A (S I) # Put initial '*Dbg' properties ld C Dbg call putACE else ld C (X CDR) # Search secondary properties do atom C # Any? if nz # No call consE_C ld (C) (S) # Get key ld (C CDR) E # Cons with value call consC_A # Insert into list ld (A) C ld (A CDR) (X CDR) ld (X CDR) A break T end cmp ((C)) (S) # Found key? if eq # Yes ld ((C) CDR) E # Store value break T end ld C (C CDR) loop end end pop C pop E pop X end end end end ret (code 'redefineCE 0) ld A (E) # Current value cmp A Nil # NIL? if ne # NO cmp A E # Auto-symbol? if ne # No push C # Save definition push E # and sym ld E C # Value call equalAE_F # Changing? if ne # Yes ld E (S) # Get sym ld C 0 # No class call redefMsgEC end pop E # Retrieve sym pop C # and definition end end ld (E) C # Set definition ld C 0 # No key call putSrcEC_E # Put source information ret # (quote . any) -> any (code 'doQuote 2) ld E (E CDR) # Get CDR ret # (as 'any1 . any2) -> any2 | NIL (code 'doAs 2) ld E (E CDR) push E # Save args ld E (E) # Eval condition eval pop A # Retrieve args cmp E Nil # Result NIL? ldnz E (A CDR) # No: Return 'any2' ret # (lit 'any) -> any (code 'doLit 2) ld E (E CDR) # Get arg ld E (E) # Eval it eval num E # Number? if z # No cmp E Nil # NIL? if ne # No cmp E TSym # T? if ne # No atom E # Pair? jnz 10 # No num (E) # CAR number? if z # No 10 ld A E call consE_E # Cons with 'quote' ld (E) Quote ld (E CDR) A end end end end ret # (eval 'any ['cnt ['lst]]) -> any (code 'doEval 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval num E # 'any' is number? if z # No link push E # 'any' link ld X (X CDR) # X on rest atom X # Any? if nz # No 10 sym E # Symbolic? if nz # Yes ld E (E) # Get value else call evListE_E # Else evaluate expression end drop pop X ret end null (EnvBind) # Bindings? jz 10 # No ld E (X) # Eval 'cnt' eval shr E 4 # Normalize push E # 'cnt' push 0 # 'n' ld E ((X CDR)) # Last argument eval # Exclusion list 'lst' in E push Y ld C (L -I) # Get 'cnt' ld Y (EnvBind) # and bindings do ld A (Y) # End of bindings in A inc (L -II) # Increment 'n' sub (Y -I) (L -I) # Decrement 'eswp' by 'cnt' if c # First pass add Y I do ld X (Y) # Next symbol xchg (X) (Y I) # Exchange symbol value with saved value add Y II cmp Y A # More? until eq # No cmp X At # Lambda frame? if eq # Yes dec C # Decrement local 'cnt' break z # Done end end ld Y (A I) # Bind link null Y # More bindings? until z # No atom E # Exclusion list? if nz # No ld E (L I) # Get 'any' eval # Evaluate it else push (EnvBind) # Build bind frame link do ld X (E) # Next excluded symbol push (X) # Save in bind frame push X ld C (L -II) # Get 'n' ld Y (EnvBind) # Bindings do ld A (Y) # End of bindings in A add Y I do cmp X (Y) # Found excluded symbol? if eq # Yes ld (X) (Y I) # Bind to found value jmp 20 end add Y II cmp Y A # More? until eq # No dec C # Traversed 'n' frames? while nz # No ld Y (A I) # Bind link null Y # More bindings? until z # No 20 ld E (E CDR) atom E # Exclusion list? until nz # No ld E ((L) I) # Get 'any' link ld (EnvBind) L # Close bind frame push 0 # Init env swap eval # Evaluate 'any' add S I # Drop env swap pop L # Get link do # Unbind excluded symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link end ld C (L -II) # Get 'n' do ld A C # in A ld Y (EnvBind) # Bindings do dec A # 'n-1' times while nz ld Y ((Y) I) # Follow link loop add (Y -I) (L -I) # Increment 'eswp' by 'cnt' if z # Last pass lea A ((Y) -II) # Last binding in A do xchg ((A)) (A I) # Exchange next symbol value with saved value sub A II cmp A Y # More? until lt # No end dec C # Decrement 'n' until z # Done pop Y drop end pop X ret # (run 'any ['cnt ['lst]]) -> any (code 'doRun 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval num E # 'any' is number? if z # No link push E # 'any' link ld X (X CDR) # X on rest atom X # Any? if nz # No 10 sym E # Symbolic? if nz # Yes ld E (E) # Get value else call runE_E # Execute end drop pop X ret end null (EnvBind) # Bindings? jz 10 # No ld E (X) # Eval 'cnt' eval shr E 4 # Normalize push E # 'cnt' push 0 # 'n' ld E ((X CDR)) # Last argument eval # Exclusion list 'lst' in E push Y ld C (L -I) # Get 'cnt' ld Y (EnvBind) # and bindings do ld A (Y) # End of bindings in A inc (L -II) # Increment 'n' sub (Y -I) (L -I) # Decrement 'eswp' by 'cnt' if c # First pass add Y I do ld X (Y) # Next symbol xchg (X) (Y I) # Exchange symbol value with saved value add Y II cmp Y A # More? until eq # No cmp X At # Lambda frame? if eq # Yes dec C # Decrement local 'cnt' break z # Done end end ld Y (A I) # Bind link null Y # More bindings? until z # No atom E # Exclusion list? if nz # No ld E (L I) # Run 'any' sym E # Symbolic? if nz # Yes ld E (E) # Get value else call runE_E # Execute end else push (EnvBind) # Build bind frame link do ld X (E) # Next excluded symbol push (X) # Save in bind frame push X ld C (L -II) # Get 'n' ld Y (EnvBind) # Bindings do ld A (Y) # End of bindings in A add Y I do cmp X (Y) # Found excluded symbol? if eq # Yes ld (X) (Y I) # Bind to found value jmp 20 end add Y II cmp Y A # More? until eq # No dec C # Traversed 'n' frames? while nz # No ld Y (A I) # Bind link null Y # More bindings? until z # No 20 ld E (E CDR) atom E # Exclusion list? until nz # No ld E ((L) I) # Get 'any' link ld (EnvBind) L # Close bind frame push 0 # Init env swap sym E # 'any' symbolic? if nz # Yes ld E (E) # Get value else call runE_E # Execute end add S I # Drop env swap pop L # Get link do # Unbind excluded symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link end ld C (L -II) # Get 'n' do ld A C # in A ld Y (EnvBind) # Bindings do dec A # 'n-1' times while nz ld Y ((Y) I) # Follow link loop add (Y -I) (L -I) # Increment 'eswp' by 'cnt' if z # Last pass lea A ((Y) -II) # Last binding in A do xchg ((A)) (A I) # Exchange next symbol value with saved value sub A II cmp A Y # More? until lt # No end dec C # Decrement 'n' until z # Done pop Y drop end pop X ret # (def 'sym 'any) -> sym # (def 'sym 'sym 'any) -> sym (code 'doDef 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval num E # Need symbol jnz symErrEX sym E jz symErrEX link push E # First symbol ld Y (Y CDR) # Next arg ld E (Y) eval+ # Eval next arg push E # Second arg link ld Y (Y CDR) # Third arg? atom Y if nz # No ld E (L II) # First symbol call checkVarEX # Check sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end ld A (E) # Current value cmp A Nil # NIL? if ne # NO cmp A E # Auto-symbol? if ne # No ld E (L I) # New value call equalAE_F # Changing? if ne # Yes ld E (L II) # Get symbol ld C 0 # No class call redefMsgEC end ld E (L II) # Get symbol again end end ld (E) (L I) # Set symbol to new value ld C 0 # No key call putSrcEC_E # Put source information else ld E (Y) eval # Eval next arg tuck E # Third arg link ld E (L III) # First symbol ld C (L II) # Second arg sym (E TAIL) # External symbol? if nz # Yes cmp C Nil # Volatile property? if ne # No call dbTouchEX # Touch symbol else call dbFetchEX # else fetch end end call getEC_E # Current property value cmp E Nil # NIL? if ne # NO ld A (L I) # New value call equalAE_F # Changing? if ne # Yes ld E (L III) # First symbol ld C (L II) # Property key call redefMsgEC end end ld A (L III) # Symbol ld C (L II) # Key ld E (L I) # Value call putACE # Put propery ld E (L III) # Symbol ld C (L II) # Key call putSrcEC_E # Put source information end drop # Return first symbol pop Y pop X ret # (de sym . any) -> sym (code 'doDe 2) push X ld X (E CDR) # Args ld E (X) # Symbol in E ld C (X CDR) # Body in C call needSymEX call redefineCE # Redefine pop X ret # (dm sym . fun|cls2) -> sym # (dm (sym . cls) . fun|cls2) -> sym # (dm (sym sym2 [. cls]) . fun|cls2) -> sym (code 'doDm 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Get first atom E # First form? if nz # Yes ld C (Class) # Get 'cls' from Class else ld C (E CDR) atom C # Second form? if z # No ld E (C CDR) # 'cls'? cmp E Nil if eq # No ld E (Class) # Default to Class end ld C (C) # 'sym' call getEC_E # Get instance object ld C E # into C ld E (Y) # Get first again end ld E (E) # msg end cmp E TSym # 'msg' is T? if ne # No push C # Save class ld C (Meth) # Get 'meth' code pointer call needSymEX call redefineCE # Redefine pop C end ld A (Y CDR) # Explicit inheritance? num A if z # No sym A if nz # Yes ld A (A) # Get cls2's value do atom A # More method definitions? jnz msgErrAX # No atom (A) jnz msgErrAX cmp E ((A)) # Found 'msg'? if eq # Yes ld Y (A) # Get method entry break T end ld A (A CDR) loop end end ld X (C) # Get cls's value do atom X # More method definitions? while z # Yes atom (X) while z cmp E ((X)) # Found 'msg'? if eq # Yes push E # Save 'msg' ld E ((X) CDR) # Old body ld A (Y CDR) # New body call equalAE_F # Changing? if ne # Yes ld E (S) # Get 'msg' push C # Save 'cls' call redefMsgEC pop C end pop E ld ((X) CDR) (Y CDR) # Set new body jmp 90 end ld X (X CDR) loop atom (Y) # First form or explict inheritance? if nz # Yes call cons_A # Cons into methods ld (A) Y ld (A CDR) (C) else call cons_A # Cons 'msg' ld (A) E ld (A CDR) (Y CDR) # With method body push A call consA_A # Cons into methods pop (A) ld (A CDR) (C) end ld (C) A 90 xchg C E # 'msg' <-> 'cls' call putSrcEC_E # Put source information ld E C # Return 'msg' pop Y pop X ret # Apply METH in C to X, with object A (code 'evMethodACEXYZ_E 0) cmp S (StkLimit) # Stack check jlt stkErr push Z # <(L) IV> 'cls' push Y # <(L) III> 'key' ld Y (C) # Parameter list in Y ld Z (C CDR) # Body in Z push E # Save 'exe' push (EnvBind) # Build bind frame link push (At) # Bind At push At push A # Bind object in A push This # to 'This' do atom Y # More evaluating parameters? while z # Yes ld E (X) # Get next argument ld X (X CDR) eval+ # Evaluate and save push E push (Y) # Save symbol ld Y (Y CDR) loop cmp Y Nil # NIL-terminated parameter list? if eq # Yes: Bind parameter symbols ld Y S # Y on bindings do ld X (Y) # Symbol in X add Y I ld A (X) # Old value in A ld (X) (Y) # Set new value ld (Y) A # Save old value add Y I cmp Y L # End? until eq # Yes link ld (EnvBind) L # Close bind frame push 0 # Init env swap xchg (EnvCls) ((L) IV) # 'cls' xchg (EnvKey) ((L) III) # 'key' prog Z # Run body add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link add S I # Drop 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret end # Non-NIL parameter cmp Y At # '@'? if ne # No push (Y) # Save last parameter's old value push Y # and the last parameter ld (Y) X # Set to unevaluated argument list lea Y (S II) # Y on evaluated bindings do ld X (Y) # Symbol in X add Y I ld A (X) # Old value in A ld (X) (Y) # Set new value ld (Y) A # Save old value add Y I cmp Y L # End? until eq # Yes link ld (EnvBind) L # Close bind frame push 0 # Init env swap xchg (EnvCls) ((L) IV) # 'cls' xchg (EnvKey) ((L) III) # 'key' prog Z # Run body add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link add S I # Drop 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret end # Evaluated argument list link # Close bind frame ld Y L # Y on frame push 0 # Init env swap push (EnvNext) # Save current 'next' push (EnvArgs) # and varArgs base atom X # Any args? if nz # No ld (EnvArgs) 0 ld (EnvNext) 0 else link # Build varArgs frame do ld E (X) # Get next argument eval+ # Evaluate and save push E ld X (X CDR) atom X # More args? until nz # No ld (EnvArgs) S # Set new varArgs base ld (EnvNext) L # Set new 'next' link # Close varArgs frame end ld (EnvBind) Y # Close bind frame xchg (EnvCls) ((Y) IV) # 'cls' xchg (EnvKey) ((Y) III) # 'key' ld C (Y) # End of bindings in C add Y I do ld X (Y) # Symbol in X add Y I ld A (X) # Old value in A ld (X) (Y) # Set new value ld (Y) A # Save old value add Y I cmp Y C # End? until eq # Yes prog Z # Run body null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end pop (EnvArgs) # Restore varArgs base pop (EnvNext) # and 'next' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link add S I # Drop 'exe' pop (EnvKey) # 'key' pop (EnvCls) # and 'cls' ret (code 'methodEY_FCYZ 0) ld A (E) # Get class definition (methods and superclasses) atom A # Any? if z # Yes do ld C (A) # First item atom C # Method definition? while z # Yes cmp Y (C) # Found method definition? if eq # Yes ld C (C CDR) # Return method ret # 'z' end ld A (A CDR) # Next item atom A # Any? jnz ret # Return 'nz' loop do ld Z A # Set class list ld E (A) # Class symbol push A cmp S (StkLimit) # Stack check jlt stkErr call methodEY_FCYZ # Found method definition? pop A jeq ret # 'z' ld A (A CDR) # Next superclass atom A # Any? until nz # No end ret # 'nz' # (box 'any) -> sym (code 'doBox 2) ld E ((E CDR)) # Get arg eval # Eval it call consE_A # New symbol ld (A) ZERO # anonymous or A SYM ld (A) E # Set value ld E A ret # (new ['flg|num] ['typ ['any ..]]) -> obj (code 'doNew 2) push X push Y push Z ld Z E # Save 'exe' in Z ld Y (E CDR) # Y on args ld E (Y) # Eval first eval atom E # 'typ' list? if z # Yes call consE_A # New object ld (A) ZERO # anonymous or A SYM # Make symbol ld (A) E # Set 'typ' link push A # 'obj' push Nil # Safe link else cmp E Nil # 'flg'? if eq # NIL call cons_E # New object ld (E) ZERO # anonymous or E SYM # Make symbol ld (E) Nil # Init to 'NIL' else # External object cnt E # File number? ldz E ONE # Default to '1' shr E 4 # Normalize call newIdEX_X # Allocate new external name call externX_E # Intern external symbol ld A (E TAIL) # Get name again shl A 1 setc # Set "dirty" rcr A 1 ld (E TAIL) A # Set name end link push E # 'obj' push Nil # Safe link ld Y (Y CDR) # Next arg ld E (Y) eval # Eval 'typ' ld A (L II) # Object in A ld (A) E # Set value in 'obj' end push Z # 'exe' ld X (Y CDR) # Keep args in X ld E A # Object ld Y TSym # Search for initial method ld Z 0 # No classes call methodEY_FCYZ # Found? if eq # Yes ld A (L II) # Get 'obj' ld E (S) # and 'exe' call evMethodACEXYZ_E else do atom X # More args? while z # Yes ld E (X) # Eval next key eval ld (L I) E # Save it ld X (X CDR) ld E (X) # Eval next value eval ld A (L II) # 'obj' ld C (L I) # Key call putACE # Put property ld X (X CDR) loop end ld E (L II) # Return 'obj' drop pop Z pop Y pop X ret # (type 'any) -> lst (code 'doType 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it num E # Symbol? if z sym E if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end pop X ld E (E) # Get value ld C E # Keep in C do atom E # Class definitions? jnz retNil # No atom (E) # Class? if nz # Yes ld A E do num (A) # Symbol? jnz retNil # No ld A (A CDR) # Next class atom A # Any? if nz # No cmp A Nil # End of classes? jnz retNil # No ret # Return E end cmp C A # Circular? jeq retNil # Yes loop end ld E (E CDR) # Next definition cmp C E # Circular? jeq retNil # Yes loop end end pop X ld E Nil # Return NIL ret # (isa 'cls|typ 'any) -> obj | NIL (code 'doIsa 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'cls|typ' link ld Y (Y CDR) # Next arg ld E (Y) eval # Eval 'any' num E # Symbol? if z sym E if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end ld C (L I) # Get 'cls|typ' atom C # 'cls'? if nz # Yes call isaCE_F # Check ldnz E Nil # Return NIL if no match else ld Y C # Get 'typ' in Y do ld C (Y) # Next class call isaCE_F # Check if nz ld E Nil # Return NIL if no match break T end ld Y (Y CDR) # More? atom Y until nz # No end drop pop Y pop X ret end end ld E Nil # Return NIL drop pop Y pop X ret : isaCE_F # A, X ld X (E) # Get value ld A X # Keep in A do atom X # Atomic value? jnz ret # Return NO atom (X) # Next item atomic? if nz # Yes do num (X) # Numeric? jnz ret # Return NO sym ((X) TAIL) # External? jnz ret # Return NO cmp C (X) # Match? jeq ret # Return YES push A # Save list head push E # object push X # and list ld E (X) # Recurse cmp S (StkLimit) # Stack check jlt stkErr call isaCE_F # Match? pop X pop E pop A jeq ret # Return YES ld X (X CDR) # Next class atom X # Any? jnz ret # Return NO cmp A X # Circular? jeq retnz # Return NO atom (X) # Next item a list? jz retnz # Return NO loop end ld X (X CDR) # Next item cmp A X # Circular? jeq retnz # Yes loop # (method 'msg 'obj) -> fun (code 'doMethod 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval # Eval it num E # Need symbol jnz symErrEX sym E jz symErrEX link push E # 'msg' link ld E ((Y CDR)) # Second eval # 'obj' num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end ld Y (L I) # 'msg' call methodEY_FCYZ # Found? ld E C # Yes ldnz E Nil # No drop pop Z pop Y pop X ret # (meth 'obj ['any ..]) -> any (code 'doMeth 2) push X push Y push Z link push C # Message symbol link ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'obj' eval num E # Need symbol jnz symErrEX sym E jz symErrEX tuck E # 'obj' link sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end push (Y CDR) # Save args ld Y (L II) # Get message num Y # Need symbol jnz msgErrYX ld Z 0 # No classes call methodEY_FCYZ # Found? jne msgErrYX # No ld A (L I) # Get 'obj' ld E X # 'exe' pop X # and args call evMethodACEXYZ_E drop pop Z pop Y pop X ret # (send 'msg 'obj ['any ..]) -> any (code 'doSend 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'msg' eval num E # Need symbol jnz symErrEX sym E jz symErrEX link push E # 'msg' ld Y (Y CDR) # Next arg ld E (Y) eval+ # Eval 'obj' push E # 'obj' link num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end push (Y CDR) # Save args ld Y (L II) # Get 'msg' ld Z 0 # No classes call methodEY_FCYZ # Found? jne msgErrYX # No ld A (L I) # Get 'obj' ld E X # 'exe' pop X # and args call evMethodACEXYZ_E drop pop Z pop Y pop X ret # (try 'msg 'obj ['any ..]) -> any (code 'doTry 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'msg' eval num E # Need symbol jnz symErrEX sym E jz symErrEX link push E # 'msg' ld Y (Y CDR) # Next arg ld E (Y) eval+ # Eval push E # 'obj' link num E # Symbol? jnz 90 sym E jz 90 # No sym (E TAIL) # External symbol? if nz # Yes call isLifeE_F # Alive? jnz 90 # No call dbFetchEX # Fetch it end push (Y CDR) # Save args ld Y (L II) # Get 'msg' ld Z 0 # No classes call methodEY_FCYZ # Found? if eq # Yes ld A (L I) # Get 'obj' ld E X # 'exe' ld X (S) # and args call evMethodACEXYZ_E else 90 ld E Nil end drop pop Z pop Y pop X ret # (super ['any ..]) -> any (code 'doSuper 2) push X push Y push Z push E # Save expression ld X (EnvCls) # 'cls' ld Y (EnvKey) # 'key' null X # Any? ldnz X (X) # Yes: First class ldz X (This) # No: 'This' ld X (X) # Get class definition do atom (X) # Method? while z # Yes ld X (X CDR) # Skip loop do atom X # Classes? while z # Yes ld E (X) # First class ld Z X # 'cls' call methodEY_FCYZ # Found? if eq # Yes pop E # Get expression push (EnvCls) # 'cls' push (EnvKey) # 'key' ld (EnvCls) Z # Set new ld (EnvKey) Y call evExprCE_E # Evaluate expression pop (EnvKey) pop (EnvCls) pop Z pop Y pop X ret end ld X (X CDR) loop ld E Y # 'key' pop X # Expression ld Y SuperErr jmp errEXYZ # (extra ['any ..]) -> any (code 'doExtra 2) push X push Y push Z push E # Save expression ld Y (EnvKey) # Get 'key' ld X (This) # Current object call extraXY_FCYZ # Locate extra method if eq pop E # Get expression push (EnvCls) # 'cls' push (EnvKey) # 'key' ld (EnvCls) Z # Set new ld (EnvKey) Y call evExprCE_E # Evaluate expression pop (EnvKey) pop (EnvCls) pop Z pop Y pop X ret end ld E Y # 'key' pop X # Expression ld Y ExtraErr jmp errEXYZ (code 'extraXY_FCYZ 0) ld X (X) # Get class definition do atom (X) # Method? while z # Yes ld X (X CDR) # Skip loop do atom X # Classes? while z # Yes cmp X (EnvCls) # Hit current 'cls' list? if eq # Yes 10 do ld X (X CDR) # Locate method in extra classes atom X # Any? while z # No: Return 'gt' ld E (X) # Superclass ld Z X # 'cls' call methodEY_FCYZ # Found? until eq # Return 'eq' ret end push X ld X (X) # Recurse on superclass cmp S (StkLimit) # Stack check jlt stkErr call extraXY_FCYZ # Found? pop X jeq ret # Yes jgt 10 # Else try extra classes ld X (X CDR) # Try next in 'cls' list loop setc # Return 'lt' ret # (with 'sym . prg) -> any (code 'doWith 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval cmp E Nil # Non-NIL? if ne # Yes num E # Need symbol jnz symErrEX sym E jz symErrEX push (EnvBind) # Build bind frame link push (This) # Save old 'This' push This # and 'sym' link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld (This) E # Set new ld X (X CDR) # Run 'prg' prog X add S III # Drop 'eswp' + link + 'This' pop (This) # Restore value pop L # Restore link pop (EnvBind) # Restore bind link end pop X ret # (bind 'sym|lst . prg) -> any (code 'doBind 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval num E # Need sym|lst jnz argErrEX ld X (X CDR) # X on 'prg' cmp E Nil # No bindings? if eq # Yes prog X # Run 'prg' pop X ret end push (EnvBind) # Build bind frame link sym E # Single symbol? if nz # Yes push (E) # Save value push E # and 'sym' link ld (EnvBind) L # Close bind frame push 0 # Init env swap prog X # Run 'prg' add S I # Drop env swap pop L # Get link pop X # Unbind symbol pop (X) # Restore value pop L # Restore link pop (EnvBind) # Restore bind link pop X ret end do ld A (E) # Next item num A # Need symbol or pair jnz argErrAX ld C (A) # Get VAL or CAR sym A # Symbol? if nz # Yes push C # Save value push A # and 'sym' else push (C) # Save value push C # and 'sym' ld (C) (A CDR) # Set new value end ld E (E CDR) # More items? atom E until nz # No link ld (EnvBind) L # Close bind frame push 0 # Init env swap prog X # Run 'prg' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop X ret # (job 'lst . prg) -> any (code 'doJob 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval cmp E Nil # Empty env 'lst'? if ne # No push (EnvBind) # Build bind frame link ld A E # Get 'lst' do ld C (A) # Next cell push ((C)) # Save value push (C) # and sym ld ((C)) (C CDR) # Set new value ld A (A CDR) atom A # More cells? until nz # No link ld (EnvBind) L # Close bind frame push 0 # Init env swap end link push E # 'lst' link ld X (X CDR) # X on 'prg' prog X # Run 'prg' add S I # Drop link pop C # Retrieve 'lst' pop L # Unlink cmp C Nil # Empty env 'lst'? if ne # No add S I # Drop env swap lea X ((L) -II) # X on bindings do # Unbind symbols ld A (X) # Next symbol ld ((C) CDR) (A) # Store value in env ld (A) (X I) # Restore value ld C (C CDR) sub X II # Reverse stacked order cmp X L # More? until lt # No drop # Restore link pop (EnvBind) # Restore bind link end pop X ret # (let sym 'any . prg) -> any # (let (sym 'any ..) . prg) -> any (code 'doLet 2) push X push Y ld X (E CDR) # Args ld Y (X) # First arg ld X (X CDR) push (EnvBind) # Build bind frame link sym Y # Single symbol? if nz # Yes push (Y) # Save old value push Y # and 'sym' link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld E (X) # Eval 'any' eval ld (Y) E # Set new value ld X (X CDR) # Run 'prg' prog X add S I # Drop env swap pop L # Get link pop X # Unbind symbol pop (X) # Restore value pop L # Restore link pop (EnvBind) # Restore bind link pop Y pop X ret end do ld A (Y) # Next sym push (A) # Save old value push A # and sym link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld E ((Y CDR)) # Eval 'any' eval ld ((Y)) E # Set new value ld Y ((Y CDR) CDR) # More symbols? atom Y while z # Yes pop A # Drop env swap pop L # and link loop prog X # Run 'prg' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop Y pop X ret # (let? sym 'any . prg) -> any (code 'doLetQ 2) push X push Y ld X (E CDR) # Args ld Y (X) # Get 'sym' ld X (X CDR) ld E (X) # Eval 'any' eval cmp E Nil # NIL? if ne # No push (EnvBind) # Build bind frame link push (Y) # Save old value push Y # and 'sym' link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld (Y) E # Set new value ld X (X CDR) # Run 'prg' prog X add S I # Drop env swap pop L # Get link pop X # Unbind symbol pop (X) # Restore value pop L # Restore link pop (EnvBind) # Restore bind link end pop Y pop X ret # (use sym . prg) -> any # (use (sym ..) . prg) -> any (code 'doUse 2) push X push Y ld X (E CDR) # Args ld Y (X) # First arg ld X (X CDR) push (EnvBind) # Build bind frame link sym Y # Single symbol? if nz # Yes push (Y) # Save old value push Y # and 'sym' link ld (EnvBind) L # Close bind frame push 0 # Init env swap prog X # Run 'prg' add S I # Drop env swap pop L # Get link pop X # Unbind symbol pop (X) # Restore value pop L # Restore link pop (EnvBind) # Restore bind link pop Y pop X ret end do ld A (Y) # Next sym push (A) # Save old value push A # and sym ld Y (Y CDR) # More symbols? atom Y until nz # No link ld (EnvBind) L # Close bind frame push 0 # Init env swap prog X # Run 'prg' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link pop Y pop X ret # (and 'any ..) -> any (code 'doAnd 2) push X ld X (E CDR) # Args do ld E (X) # Eval next eval cmp E Nil # NIL? while ne # No ld (At) E ld X (X CDR) # X on rest atom X # Done? until nz # Yes pop X ret # (or 'any ..) -> any (code 'doOr 2) push X ld X (E CDR) # Args do ld E (X) # Eval next eval cmp E Nil # NIL? if ne # No ld (At) E pop X ret end ld X (X CDR) # X on rest atom X # Done? until nz # Yes pop X ret # (nand 'any ..) -> flg (code 'doNand 2) push X ld X (E CDR) # Args do ld E (X) # Eval next eval cmp E Nil # NIL? if eq # Yes ld E TSym # Return T pop X ret end ld (At) E ld X (X CDR) # X on rest atom X # Done? until nz # Yes ld E Nil # Return NIL pop X ret # (nor 'any ..) -> flg (code 'doNor 2) push X ld X (E CDR) # Args do ld E (X) # Eval next eval cmp E Nil # NIL? if ne # No ld (At) E ld E Nil # Return NIL pop X ret end ld X (X CDR) # X on rest atom X # Done? until nz # Yes ld E TSym # Return T pop X ret # (xor 'any 'any) -> flg (code 'doXor 2) ld E (E CDR) push (E CDR) # Push rest ld E (E) # Eval first eval cmp E Nil # NIL? if eq # Yes pop E # Get rest ld E (E) # Eval second eval cmp E Nil # NIL again? ldnz E TSym # No ret end pop E # Get rest ld E (E) # Eval second eval cmp E Nil # NIL? ld E Nil ldz E TSym # Yes ret # (bool 'any) -> flg (code 'doBool 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E Nil # NIL? ldnz E TSym # No ret # (not 'any) -> flg (code 'doNot 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E Nil # NIL? jeq retT # Yes ld (At) E ld E Nil ret # (nil . prg) -> NIL (code 'doNil 2) push X ld X (E CDR) # Get 'prg' exec X # Execute it ld E Nil # Return NIL pop X ret # (t . prg) -> T (code 'doT 2) push X ld X (E CDR) # Get 'prg' exec X # Execute it ld E TSym # Return T pop X ret # (prog . prg) -> any (code 'doProg 2) push X ld X (E CDR) # Get 'prg' prog X # Run it pop X ret # (prog1 'any1 . prg) -> any1 (code 'doProg1 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval ld (At) E link push E # Result link ld X (X CDR) # Get 'prg' exec X # Execute it ld E (L I) # Get result drop pop X ret # (prog2 'any1 'any2 . prg) -> any2 (code 'doProg2 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval ld X (X CDR) # Eval second ld E (X) eval ld (At) E link push E # Result link ld X (X CDR) # Get 'prg' exec X # Execute it ld E (L I) # Get result drop pop X ret # (if 'any1 'any2 . prg) -> any (code 'doIf 2) ld E (E CDR) push (E CDR) # Push rest ld E (E) # Eval condition eval cmp E Nil if ne # Non-NIL ld (At) E pop E # Get rest ld E (E) # Consequent eval/ret end xchg X (S) # Get rest in X ld X (X CDR) # Else prog X pop X ret # (if2 'any1 'any2 'any3 'any4 'any5 . prg) -> any (code 'doIf2 2) ld E (E CDR) push (E CDR) # Push rest ld E (E) # Eval first condition 'any1' eval cmp E Nil if eq # NIL xchg X (S) # Get rest in X ld E (X) # Eval second condition 'any2' eval cmp E Nil if eq # Also NIL ld X ((((X CDR) CDR) CDR) CDR) # Run 'prg' prog X pop X ret end ld (At) E ld X (((X CDR) CDR) CDR) # Eval 'any5' ld E (X) pop X eval/ret end ld (At) E # 'any1' is non-Nil xchg X (S) # Get rest in X ld E (X) # Eval second condition 'any2' eval cmp E Nil if eq # NIL ld X ((X CDR) CDR) # Eval 'any4' ld E (X) pop X eval/ret end ld (At) E # Both are non-Nil ld X (X CDR) # Eval 'any3' ld E (X) pop X eval/ret # (ifn 'any1 'any2 . prg) -> any (code 'doIfn 2) ld E (E CDR) push (E CDR) # Push body ld E (E) # Eval condition eval cmp E Nil if eq # NIL pop E # Get rest ld E (E) # Consequent eval/ret end ld (At) E xchg X (S) # Get rest in X ld X (X CDR) # Else prog X pop X ret # (when 'any . prg) -> any (code 'doWhen 2) ld E (E CDR) push (E CDR) # Push body ld E (E) # Get condition eval # Eval condition cmp E Nil if eq # NIL add S I # Drop rest ret end ld (At) E xchg X (S) # Run body prog X pop X ret # (unless 'any . prg) -> any (code 'doUnless 2) ld E (E CDR) push (E CDR) # Push body ld E (E) # Get condition eval # Eval condition cmp E Nil if ne # NIL ld (At) E add S I # Drop rest ld E Nil # Return NIL ret end xchg X (S) # Run body prog X pop X ret # (cond ('any1 . prg1) ('any2 . prg2) ..) -> any (code 'doCond 2) push X ld X E # Clauses in X do ld X (X CDR) # Next clause atom X # Any? while z # Yes ld E ((X)) # Eval CAR eval cmp E Nil if ne # Non-NIL ld (At) E ld X ((X) CDR) # Run body prog X pop X ret end loop ld E Nil # Return NIL pop X ret # (nond ('any1 . prg1) ('any2 . prg2) ..) -> any (code 'doNond 2) push X ld X E # Clauses in X do ld X (X CDR) # Next clause atom X # Any? while z # Yes ld E ((X)) # Eval CAR eval cmp E Nil if eq # NIL ld X ((X) CDR) # Run body prog X pop X ret end ld (At) E loop ld E Nil # Return NIL pop X ret # (case 'any (any1 . prg1) (any2 . prg2) ..) -> any (code 'doCase 2) push X ld X (E CDR) # Arguments in X ld E (X) # Eval argument item eval ld (At) E do ld X (X CDR) # Next clause atom X # Any? while z # Yes ld C ((X)) # Item(s) in C cmp C TSym # Catch-all? jeq 10 # Yes ld A (At) # Equal to argument item? ld E C call equalAE_F if eq # Yes 10 ld X ((X) CDR) # Run body prog X pop X ret end atom C # List of items? if z # Yes do ld A (At) # Argument item member? ld E (C) call equalAE_F if eq # Yes ld X ((X) CDR) # Run body prog X pop X ret end ld C (C CDR) # End of list? atom C until nz # Yes end loop ld E Nil # Return NIL pop X ret # (casq 'any (any1 . prg1) (any2 . prg2) ..) -> any (code 'doCasq 2) push X ld X (E CDR) # Arguments in X ld E (X) # Eval argument item eval ld (At) E do ld X (X CDR) # Next clause atom X # Any? while z # Yes ld C ((X)) # Item(s) in C cmp C TSym # Catch-all? jeq 10 # Yes cmp C E # Equal to argument item? if eq # Yes 10 ld X ((X) CDR) # Run body prog X pop X ret end atom C # List of items? if z # Yes do cmp (C) E # Argument item member? if eq # Yes ld X ((X) CDR) # Run body prog X pop X ret end ld C (C CDR) # End of list? atom C until nz # Yes end loop ld E Nil # Return NIL pop X ret # (state 'var (sym|lst exe [. prg]) ..) -> any (code 'doState 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'var' eval link push E # 'var' link call needVarEX # Need variable do ld Y (Y CDR) # Next clause atom Y # Any? while z # Yes ld X (Y) # Get clause in X ld E (X) # Get sym|lst in E cmp E TSym # T? jeq 10 # Yes ld A ((L I)) # 'var's value cmp A E # Same? jeq 10 # Yes do # 'memq' atom E # List? while z # Yes cmp A (E) # Member? while ne # No ld E (E CDR) loop if eq # Yes 10 ld X (X CDR) # Eval 'exe' ld E (X) eval cmp E Nil if ne # Non-NIL ld ((L I)) E # Set target state ld (At) E drop ld X (X CDR) # Get body in X pop Y prog X # Run body pop X ret end end loop drop pop Y pop X ret # (while 'any . prg) -> any (code 'doWhile 2) push X push Y ld X (E CDR) # X arguments link push Nil # Result link do ld E (X) # Eval condition eval cmp E Nil while ne # Non-NIL ld (At) E ld Y (X CDR) # Run body prog Y ld (L I) E # Save result loop ld E (L I) # Get result drop pop Y pop X ret # (until 'any . prg) -> any (code 'doUntil 2) push X push Y ld X (E CDR) # X arguments link push Nil # Result link do ld E (X) # Eval condition eval cmp E Nil while eq # NIL ld Y (X CDR) # Run body prog Y ld (L I) E # Save result loop ld (At) E ld E (L I) # Get result drop pop Y pop X ret # (at '(cnt1 . cnt2|NIL) . prg) -> any (code 'doAt 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval atom E # Need pair jnz pairErrEX cmp (E CDR) Nil # CDR? jeq 10 # No ld A (E) # Get 'cnt1' cnt A # Need short jz cntErrAX ld C (E CDR) # Get 'cnt2' cnt C # Need short jz cntErrCX add A (hex "10") # Increment cmp A C # Reached count? if lt # No ld (E) A 10 ld E Nil else ld (E) ZERO ld Y (Y CDR) # Run body prog Y end pop Y pop X ret # (do 'flg|cnt ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any (code 'doDo 2) push X push Y push Z ld X (E CDR) # Args ld E (X) # Eval 'flg|cnt' ld X (X CDR) # Body eval cmp E Nil # Ever? if ne # Yes cnt E # Short number? jz loopX # No: Non-NIL 'flg' shr E 4 # Normalize if gt # Greater zero push E # Count do ld Y X # Loop body call loopY_FE while nz dec (S) # Decrement count until z add S I # Drop count else ld E Nil # Return NIL if zero end end pop Z pop Y pop X ret # (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any (code 'doLoop 2) push X push Y push Z ld X (E CDR) # Body : loopX do ld Y X # Body in Y do ld E (Y) # Next expression atom E # Pair? if z # Yes ld A (E) # Get CAR cmp A Nil # NIL? if eq # Yes ld Z (E CDR) # Sub-body in Z ld E (Z) eval # Evaluate condition cmp E Nil # NIL? if eq # Yes ld Y (Z CDR) # Run sub-body prog Y pop Z pop Y pop X ret end ld (At) E else cmp A TSym # T? if eq # Yes ld Z (E CDR) # Sub-body in Z ld E (Z) eval # Evaluate condition cmp E Nil # NIL? if ne # No ld (At) E ld Y (Z CDR) # Run sub-body prog Y pop Z pop Y pop X ret end else call evListE_E # Else evaluate expression end end end ld Y (Y CDR) atom Y # Finished one pass? until nz # Yes loop # (for sym 'cnt ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any # (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any # (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any (code 'doFor 2) push X push Y push Z ld X (E CDR) # X on args ld Y (X) # Y on first arg ld X (X CDR) push (EnvBind) # Build bind frame link atom Y # 'sym'? if nz # Yes # (for sym 'cnt|lst ..) push (Y) # Save old value push Y # and 'sym' link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld E (X) # Eval 'cnt|lst' eval link push E # 'cnt|lst' link ld X (X CDR) # X on body ld A E ld E Nil # Preload NIL num A # Number? if nz # Yes test A SIGN # Negative? if z # No ld (Y) ZERO # Init 'sym' to zero do ld A ((L V)) # Get value of 'sym' add A (hex "10") # Increment cmp A (L I) # Greater than 'num'? while le # No ld ((L V)) A # Set incremented value of 'sym' ld Y X # Loop body call loopY_FE until z end else do ld A (L I) # Get 'lst' atom A # Any? while z # Yes ld (L I) (A CDR) ld ((L V)) (A) # Set value ld Y X # Loop body call loopY_FE until z end drop add S I # Drop env swap pop L # Get link else ld Z (Y CDR) # CDR of first arg atom Z # 'sym'? if nz # Yes # (for (sym2 . sym) 'lst ..) push (Z) # Value of 'sym' push Z # 'sym' ld Z (Y) push (Z) # Value of 'sym2' push Z # 'sym2' link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld E (X) # Eval 'lst' eval link push E # 'lst' link ld (Z) ZERO # Init 'sym2' to zero ld X (X CDR) # X on body do ld A (L I) # Get 'lst' atom A # Any? while z # Yes ld (L I) (A CDR) ld ((L VII)) (A) # Set value of 'sym' add ((L V)) (hex "10") # Increment 'sym2' ld Y X # Loop body call loopY_FE until z drop add S I # Drop env swap pop L # Get link pop X # Unbind 'sym2' pop (X) # Restore value else ld Z (Y) # CAR of first arg ld Y (Y CDR) atom Z # 'sym'? if nz # Yes # (for (sym ..) ..) push (Z) # Save old value push Z # and 'sym' link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld E (Y) # Eval 'any1' init-expression eval ld (Z) E # Set new value link push Nil # Result link push (Y CDR) # (any2 . prg) do ld E ((S)) # Evaluate condition eval cmp E Nil # NIL? if eq # Yes ld E (L I) # Get result break T end ld (At) E ld Y X # Loop body call loopY_FE while nz ld (L I) E # Keep result ld Y ((S) CDR) # 'prg' re-init? atom Y if z # Yes prog Y ld ((L V)) E # Set new value end loop drop add S I # Drop env swap pop L # Get link else # (for ((sym2 . sym) ..) ..) ld C (Z CDR) # 'sym' push (C) # Save old value push C # and 'sym' ld C (Z) # 'sym2' push (C) # Value of 'sym2' push C # and 'sym2' link ld (EnvBind) L # Close bind frame push 0 # Init env swap ld E (Y) # Eval 'any1' init-expression eval ld ((Z CDR)) E # Set new value of 'sym' ld ((Z)) ZERO # Init 'sym2' to zero link push Nil # Result link push (Y CDR) # (any2 . prg) do add ((L V)) (hex "10") # Increment 'sym2' ld E ((S)) # Evaluate condition eval cmp E Nil # NIL? if eq # Yes ld E (L I) # Get result break T end ld (At) E ld Y X # Loop body call loopY_FE while nz ld (L I) E # Keep result ld Y ((S) CDR) # 'prg' re-init? atom Y if z # Yes prog Y ld ((L VII)) E # Set new value end loop drop add S I # Drop env swap pop L # Get link pop X # Unbind 'sym2' pop (X) # Restore value end end end pop X # Unbind 'sym' pop (X) # Restore value pop L # Restore link pop (EnvBind) # Restore bind link pop Z pop Y pop X ret (code 'loopY_FE 0) # Z do ld E (Y) # Next expression num E # Number? if z # No sym E # Symbol? if nz # Yes ld E (E) # Get value else ld A (E) # Else get CAR cmp A Nil # NIL? if eq # Yes ld Z (E CDR) # Sub-body in Z ld E (Z) eval # Evaluate condition cmp E Nil # NIL? if eq # Yes ld Y (Z CDR) # Run sub-body prog Y setz # Return 'z' ret end ld (At) E ld E Nil else cmp A TSym # T? if eq # Yes ld Z (E CDR) # Sub-body in Z ld E (Z) eval # Evaluate condition cmp E Nil # NIL? if ne # No ld (At) E ld Y (Z CDR) # Run sub-body prog Y setz # Return 'z' ret end else call evListE_E # Else evaluate expression end end end end ld Y (Y CDR) atom Y # Done? until nz # Yes ret # Return 'nz' # (catch 'any . prg) -> any (code 'doCatch 2) push X push Y push Z push L ld X (E CDR) ld E (X) # Eval tag eval sub S "EnvEnd-Env" # Build catch frame save (Env) (EnvEnd) (S) # Save environment push ZERO # 'fin' push E # 'tag' push (Catch) # Link ld (Catch) S # Close catch frame ld X (X CDR) # Run body prog X : caught pop (Catch) # Restore catch link add S (pack II "+(EnvEnd-Env)") # Clean up pop L pop Z pop Y pop X ret # (throw 'sym 'any) (code 'doThrow 2) ld X E ld Y (X CDR) ld E (Y) # Get sym ld Y (Y CDR) eval # Evaluate tag ld Z E # into Z ld E (Y) # Get value eval # Keep thrown value in E ld C (Catch) # Search catch frames do null C # Any? jz throwErrZX # No cmp (C I) TSym # Catch-all? while ne # No cmp Z (C I) # Found tag? while ne # No ld C (C) # Next frame loop push E # Save thrown value call unwindC_Z # Unwind environments pop E ld S Z # Restore stack jmp caught # Return E (code 'throwErrZX) ld E Z ld Y ThrowErr jmp errEXYZ # (finally exe . prg) -> any (code 'doFinally 2) push X sub S "EnvEnd-Env" # Build catch frame save (Env) (EnvEnd) (S) # Save environment ld X (E CDR) push (X) # 'exe' -> 'fin' ld X (X CDR) push 0 # 'tag' push (Catch) # Link ld (Catch) S # Close catch frame prog X # Run body link push E # Result link ld E (S V) # Get 'fin' eval # Evaluate it ld E (L I) # Get result drop pop (Catch) # Restore catch link add S (pack II "+(EnvEnd-Env)") # Clean up pop X ret # (co 'sym [. prg]) -> any (code 'doCo 2) push X ld X (E CDR) # Get tag ld E (X) # Eval 'sym' eval atom (X CDR) # 'prg'? if z # Yes push Y push Z push L sub S "EnvMid-EnvCo" # Space for env ld Y (Stack1) # Search through stack segments ld C (Stacks) # Segment count do null C # Any? while nz # Yes null (Y -I) # In use? if nz # Yes cmp E (Y -I) # Found tag? if eq # Yes null (Y -II) # Already active? jz reentErrEX # Yes push Y # Resume coroutine: Save 'seg' push (StkLimit) # and 'lim' push (EnvCo7) # Link ld (EnvCo7) S # Close coroutine frame ld Z S # Point Z to main frame save (EnvCo) (EnvMid) (Z III) # Save environment ld E Nil # Final 'yield's return value : resumeCoroutine ld S (Y -II) # Restore stack pointer ld (Y -II) 0 # Mark as active lea A (Y 4096) # Set stack limit sub A (StkSize) ld (StkLimit) A load (EnvCo) (EnvMid) (Y (pack -II "-(EnvMid-EnvCo)")) # Restore environment ld X Catch # Pointer to catch frames do null (X) # More locals? while nz # Yes ld X (X) # Next frame pointer loop ld (X) (Z (pack III "+(Catch-EnvCo)")) # Join ld X (EnvBind) # Reversed bindings ld C (Z (pack III "+(EnvBind-EnvCo)")) # Main bindings do null X # More reversed bindings? while nz # Yes ld Y (X) # Link address in Y null (X -I) # Env swap zero? if z # Yes lea A (Y -II) # End of bindings in A do xchg ((A)) (A I) # Exchange symbol value with saved value sub A II cmp A X # More? until lt # No end ld A (Y I) # Get down link ld (Y I) C # Undo reversal ld C X ld X A loop ld (EnvBind) C # Set local bindings ld X EnvInFrames # Pointer to input frames null (X) # Any locals? if z # No ld (Chr) (Z (pack III "+(Chr-EnvCo)")) # Adapt In ld (Get_A) (Z (pack III "+(Get_A-EnvCo)")) ld (InFile) (Z (pack III "+(InFile-EnvCo)")) else do ld X (X) # Next frame pointer null (X) # More locals? until z # No end ld (X) (Z (pack III "+(EnvInFrames-EnvCo)")) # Join ld X EnvOutFrames # Pointer to output frames null (X) # Any locals? if z # No ld (PutB) (Z (pack III "+(PutB-EnvCo)")) # Adapt Out ld (OutFile) (Z (pack III "+(OutFile-EnvCo)")) else do ld X (X) # Next frame pointer null (X) # More locals? until z # No end ld (X) (Z (pack III "+(EnvOutFrames-EnvCo)")) # Join ld X EnvApply # Local apply stack do null (X) # Any? while nz # Yes ld X ((X)) # Follow link loop ld (X) (Z (pack III "+(EnvApply-EnvCo)")) # Join pop X # Get saved L null X # Any? if nz # Yes ld Y (X) # Pointer to link do ld A (Y) # Get link null A # Found end? while nz # No ld Y (A) # Next frame loop ld (Y) (Z (pack III "+(EnvMid-EnvCo)")) # Link to main stack ld L X end pop Z pop Y pop X ret end dec C # Decrement count end sub Y (StkSize) # Next segment loop ld Y (Stack1) # Find unused stack segment ld C (Stacks) # Segment count null C # Starting first coroutine? if z # Yes lea A (Y 4096) # Set stack limit cmp S A # Check it jlt stkErr ld (StkLimit) A else do null (Y -I) # Found free segment? while nz # No sub Y (StkSize) # Next segment dec C # Any? until z # Yes end inc (Stacks) # Increment segment count push Y # Save 'seg' push (StkLimit) # and 'lim' push (EnvCo7) # Link ld (EnvCo7) S # Close coroutine frame save (EnvCo) (EnvMid) (S III) # Save environment ld (EnvMake) 0 # Init local 'make' env ld (EnvYoke) 0 lea A (Y 4096) # Calculate stack limit sub A (StkSize) ld (StkLimit) A ld S Y # Set stack pointer push E # Save 'tag' push 0 # Mark 'stk' as active sub S "EnvMid-EnvCo" # Space for 'env' ld X (X CDR) link push X # Save 'prg' link prog X # Run 'prg' ld S (EnvCo7) # Not yielded: Restore stack pointer load (Env) (EnvMid) (S (pack III "+(Env-EnvCo)")) # Restore environment pop (EnvCo7) # Restore coroutine link pop (StkLimit) # 'lim' ld (Y -I) 0 # Mark segment as unused dec (Stacks) # Last coroutine? if z # Yes ld (StkLimit) 0 # Clear stack limit end add S (pack I "+(EnvMid-EnvCo)") # Clean up pop L pop Z pop Y pop X ret end ld X (Stack1) # Search through stack segments ld C (Stacks) # Segment count do null C # Any? while nz # Yes null (X -I) # In use? if nz # Yes cmp E (X -I) # Found tag? if eq # Yes null (X -II) # Active? ldz E Nil if nz # No ld C (X (pack -II "-(EnvMid-EnvInFrames)")) # Open input frames call closeCoFilesC ld C (X (pack -II "-(EnvMid-EnvOutFrames)")) # Open output frames call closeCoFilesC ld (X -I) 0 # Mark segment as unused dec (Stacks) # Last coroutine? if z # Yes ld (StkLimit) 0 # Clear stack limit end ld E TSym # Return T end pop X ret end dec C # Decrement count end sub X (StkSize) # Next segment loop ld E Nil # Return NIL pop X ret # (yield 'any ['sym]) -> any (code 'doYield 2) push X push Y push Z ld X E ld Y (E CDR) ld E (Y) # Eval 'any' eval link push E # Result link ld Y (Y CDR) # Next arg ld E (Y) eval # Eval optional 'sym' ld Y 0 # Preload "no target" cmp E Nil # Any? if ne # Yes ld Y (Stack1) # Search for target coroutine ld C (Stacks) # Segment count do null C # Any? jz yieldErrEX # No null (Y -I) # In use? if nz # Yes cmp E (Y -I) # Found tag? break eq # Yes dec C # Decrement count end sub Y (StkSize) # Next segment loop null (Y -II) # Already active? jz reentErrEX # Yes end ld E (L I) # Get result drop ld Z (EnvCo7) # Get main null Z # Any? if z # No null Y # Target coroutine? jz yieldErrX # No push L # Else resume with argument sub S "EnvMid-EnvCo" # Space for env push Y # Save 'seg' push (StkLimit) # and 'lim' push Z # Link (NULL) ld (EnvCo7) S # Close coroutine frame ld Z S # Point Z to main frame save (EnvCo) (EnvMid) (Z III) # Save environment jmp resumeCoroutine # Resume end null L # Stack? if nz # Yes ld C (Z (pack III "+(EnvMid-EnvCo)")) # Main routine's link cmp L C # Local stack? ldz L 0 if ne # Yes ld X (L) # Pointer to link do ld A (X) # Get link null A # Any? jz 10 # No cmp A C # Reached main routine's link? while ne # No ld X (A) # Follow link loop ld (X) 0 # Clear link end end 10 push L # End of segment push Y # Save taget coroutine ld X EnvApply # Pointer to apply stack do ld A (X) cmp A (Z (pack III "+(EnvApply-EnvCo)")) # Local apply stack? while ne # Yes lea X ((A) I) # Get link loop ld (X) 0 # Cut off ld X EnvOutFrames # Pointer to output frames do cmp (X) (Z (pack III "+(EnvOutFrames-EnvCo)")) # More locals? while ne # Yes ld X (X) # Next frame pointer loop ld (X) 0 # Cut off ld X EnvInFrames # Pointer to input frames do cmp (X) (Z (pack III "+(EnvInFrames-EnvCo)")) # More locals? while ne # Yes ld X (X) # Next frame pointer loop ld (X) 0 # Cut off ld C 0 # Back link ld X (EnvBind) # Reverse bindings null X # Any? if nz # Yes do cmp X (Z (pack III "+(EnvBind-EnvCo)")) # Reached main routine's bindings? while ne # No ld Y X # Keep bind frame in Y null (X -I) # Env swap zero? if z # Yes add X I # X on bindings do xchg ((X)) (X I) # Exchange symbol value with saved value add X II cmp X (Y) # More? until eq # No end ld A (Y) # A on bind link ld X (A I) # X on next frame ld (A I) C # Set back link ld C Y loop end ld (EnvBind) C # Store back link in coroutine's env ld X Catch # Pointer to catch frames do cmp (X) (Z (pack III "+(Catch-EnvCo)")) # More locals? while ne # Yes ld X (X) # Next frame pointer loop ld (X) 0 # Cut off pop Y # Restore taget coroutine ld X (Z II) # Get 'seg' ld (X -II) S # Save stack pointer save (EnvCo) (EnvMid) (X (pack -II "-(EnvMid-EnvCo)")) # Save environment null Y # Target coroutine? if z # No null (EnvInFrames) # Adapt In? if nz # Yes ld (Chr) (Z (pack III "+(Chr-EnvCo)")) ld (Get_A) (Z (pack III "+(Get_A-EnvCo)")) ld (InFile) (Z (pack III "+(InFile-EnvCo)")) end null (EnvOutFrames) # Adapt Out? if nz # Yes ld (PutB) (Z (pack III "+(PutB-EnvCo)")) ld (OutFile) (Z (pack III "+(OutFile-EnvCo)")) end ld S Z # Set stack pointer load (Env) (EnvMid) (Z (pack III "+(Env-EnvCo)")) # Restore environment pop (EnvCo7) # Restore coroutine link pop (StkLimit) # 'lim' add S (pack I "+(EnvMid-EnvCo)") # Clean up pop L pop Z pop Y pop X ret end ld (Z II) Y # Set new 'seg' jmp resumeCoroutine # Resume (code 'closeCoFilesC 0) do null C while nz null (C II) # 'pid'? if nz # Yes cc close((C I)) # Close 'fd' call waitFileC # Wait for pipe process if necessary end ld C (C) loop ret # (! . exe) -> any (code 'doBreak 2) ld E (E CDR) # exe cmp (Dbg) Nil # Debug? if ne # Yes call brkLoadE_E # Enter debug breakpoint end eval/ret (code 'brkLoadE_E) null (Break) # Already in breakpoint? if z # No cc isatty(0) # STDIN nul4 # on a tty? if nz # Yes cc isatty(1) # STDOUT nul4 # on a tty? if nz # Yes push X push Y push (EnvBind) # Build bind frame link push (Up) # Bind '^' push Up ld (Up) E # to expression push (Run) # Bind '*Run' to NIL push Run ld (Run) Nil push (At) # Save '@' push At link ld (EnvBind) L # Close bind frame ld (Break) L # Set break env push 0 # Init env swap sub S IV # OutFrame ld Y S ld (Y I) 1 # fd = stdout ld (Y II) 0 # pid = 0 call pushOutFilesY call printE # Print expression call newline ld B (char "!") # Prompt ld E Nil # REPL ld X 0 # Runtime expression call loadBEX_E call popOutFiles add S (+ IV III) # Drop outFrame, env swap, bind link and '@' pop (At) # Restore '@' pop A pop (Run) # '*Run' pop A ld E (Up) # runtime expression pop (Up) # and '^' pop L # Restore link pop (EnvBind) # Restore bind link ld (Break) 0 # Leave breakpoint pop Y pop X end end end ret # (e . prg) -> any (code 'doE 2) push X push Y ld X E null (Break) # Breakpoint? jz brkErrX # No link push (Dbg) # Save '*Dbg' push (At) # '@' push (Run) # and '*Run' link ld (Dbg) Nil # Switch off debug mode ld C (Break) # Get break env ld (At) (C II) # Set '@' ld (Run) (C IV) # and '*Run' call popOutFiles # Leave debug I/O env ld Y (EnvInFrames) # Keep InFrames call popInFiles ld X (X CDR) # 'prg'? atom X if z # Yes prog X else ld E (Up) # Get '^' eval end call pushInFilesY # Restore debug I/O env lea Y ((Break) -V) call pushOutFilesY pop L # Restore debug env pop (Run) pop (At) pop (Dbg) pop L pop Y pop X ret # ($ sym|lst lst . prg) -> any (code 'doTrace 2) push X ld X (E CDR) # Get args cmp (Dbg) Nil # Debug? if eq # No ld X ((X CDR) CDR) # Get 'prg' prog X # Run it else push Y push Z push (OutFile) # Save output channel ld (OutFile) ((OutFiles) II) # Set to OutFiles[2] (stderr) push (PutB) # Save 'put' ld (PutB) putStdoutB # Set new ld Y (X) # Get 'sym|lst' ld X (X CDR) ld Z (X CDR) # Get 'prg' inc (EnvTrace) # Increment trace level ld C (EnvTrace) # Get it call traceCY # Print trace information ld C Trc1 # Print " :" call outStringC ld X (X) # Get 'lst' do atom X # List? while z # Yes call space ld E (X) # Print value of CAR ld E (E) call printE ld X (X CDR) loop cmp X Nil # Last CDR is NIL? if ne # No cmp X At # Variable arguments? if ne # No call space ld E (X) # Print value call printE else ld X (EnvNext) # VarArgs do cmp X (EnvArgs) # Any? while ne # Yes call space sub X I # Next ld E (X) # Next arg call printE loop end end call newline ld (PutB) (S) # Restore 'put' ld (OutFile) (S I) # and output channel prog Z # Run 'prg' ld (OutFile) ((OutFiles) II) # Set output channel again ld (PutB) putStdoutB ld C (EnvTrace) # Get trace level dec (EnvTrace) # Decrement it call traceCY # Print trace information ld C Trc2 # Print " = " call outStringC call printE_E # Print result call newline pop (PutB) # Restore 'put' pop (OutFile) # and output channel pop Z pop Y end pop X ret (code 'traceCY) cmp C 64 # Limit to 64 if gt ld C 64 end do call space # Output spaces dec C # 'cnt' times until sz push E atom Y # 'sym'? if nz # Yes ld E Y # Print symbol call printE else ld E (Y) # Print method call printE call space ld E (Y CDR) # Print class call printE call space ld E (This) # Print 'This' call printE end pop E ret # (call 'any ..) -> flg (code 'doCall 2) push X push Z ld X (E CDR) # X on args push E # Save expression push 0 # End-of-buffers marker call evSymX_E # Pathname call pathStringE_SZ # Write to stack buffer do ld X (X CDR) # Arguments? atom X while z # Yes push Z # Buffer chain call evSymX_E # Next argument call bufStringE_SZ # Write to stack buffer loop push Z ld Z S # Point to chain ld X Z push 0 # NULL terminator do lea A (X I) # Buffer pointer push A # Push to vector ld X (X) # Follow chain null (X) # Done? until z # Yes ld X (X I) # Retrieve expression call flushAll # Flush all output channels cc fork() # Fork child process nul4 # In child? if z # Yes cc setpgid(0 0) # Set process group cc execvp((S) S) # Execute program jmp execErrS # Error if failed end js forkErrX do ld S Z # Clean up buffers pop Z # Chain null Z # End? until z # Yes ld Z A # Keep pid in Z cc setpgid(Z 0) # Set process group null (Termio) # Raw mode? if nz # Yes cc tcsetpgrp(0 Z) # Set terminal process group end do # Re-use expression stack entry do cc waitpid(Z S WUNTRACED) # Wait for child nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? jne waitPidErrX # No null (Signal) # Signal? if nz # Yes call sighandlerX end loop null (Termio) # Raw mode? if nz # Yes cc getpgrp() # Set terminal process group cc tcsetpgrp(0 A) end call wifstoppedS_F # WIFSTOPPED(S)? if ne # No ld4 (S) # Result? or A A ld E TSym # Return 'flg' ldnz E Nil add S I # Drop expression pop Z pop X ret end ld B (char "+") # Prompt ld E Nil # REPL call loadBEX_E null (Termio) # Raw mode? if nz # Yes cc tcsetpgrp(0 Z) # Set terminal process group end cc kill(Z SIGCONT) loop # (tick (cnt1 . cnt2) . prg) -> any (code 'doTick 2) push X push (TickU) # User ticks push (TickS) # System ticks cc times(Tms) # Get ticks push (Tms TMS_UTIME) # User time push (Tms TMS_STIME) # User time ld E (E CDR) push (E) # Save pointer to count pair ld X (E CDR) prog X # Run 'prg' pop X # Get count pair cc times(Tms) # Get ticks again ld A (Tms TMS_UTIME) # User time sub A (S I) # Subtract previous user time sub A (TickU) # Subtract user ticks add A (S III) # Adjust by saved ticks add (TickU) A # Save new user ticks shl A 4 # Adjust to short number add (X) A # Add to 'cnt1' ld A (Tms TMS_STIME) # System time sub A (S) # Subtract previous system time sub A (TickS) # Subtract system ticks add A (S II) # Adjust by saved ticks add (TickS) A # Save new system ticks shl A 4 # Adjust to short number add (X CDR) A # Add to 'cnt2' add S IV # Drop locals pop X ret # (ipid) -> pid | NIL (code 'doIpid 2) ld C (EnvInFrames) # OutFrames? null C if nz ld E (C II) # 'pid' cmp E 1 # 'pid' > 1? if gt # Yes shl E 4 # Make short number or E CNT ret end end ld E Nil # Return NIL ret # (opid) -> pid | NIL (code 'doOpid 2) ld C (EnvOutFrames) # OutFrames? null C if nz ld E (C II) # 'pid' cmp E 1 # 'pid' > 1? if gt # Yes shl E 4 # Make short number or E CNT ret end end ld E Nil # Return NIL ret # (kill 'pid ['cnt]) -> flg (code 'doKill 2) push X push Y ld X E ld Y (E CDR) # Y on args call evCntXY_FE # Eval 'pid' ld Y (Y CDR) # Second arg? atom Y if nz # No cc kill(E SIGTERM) # Send TERM signal else push E # Save signal number call evCntXY_FE # Eval 'cnt' cc kill(pop E) # Send signal end nul4 # OK? ld E TSym # Yes ldnz E Nil # No pop Y pop X ret # (fork) -> pid | NIL (code 'doFork 2) push X ld X E # Get expression call forkLispX_FE # Fork child process if c ld E Nil # In child else shl E 4 # In parent or E CNT # Return PID end pop X ret (code 'forkLispX_FE 0) call flushAll # Flush all output channels null (Spkr) # Not listening for children yet? if z # Yes cc pipe(SpMiPipe) # Open speaker/microphone pipe nul4 # OK? jnz pipeErrX ld4 (SpMiPipe) # Read end ld (Spkr) A # into the speaker call closeOnExecAX ld4 (SpMiPipe 4) # Write end call closeOnExecAX end sub S II # Create 'hear' and 'tell' pipes cc pipe(S) # Open 'hear' pipe nul4 # OK? jnz pipeErrX cc pipe(&(S 8)) # Open 'tell' pipe nul4 # OK? jnz pipeErrX ld4 (S) # Read end of 'hear' call closeOnExecAX ld4 (S 4) # Write end call closeOnExecAX ld4 (S 8) # Read end of 'tell' call closeOnExecAX ld4 (S 12) # Write end call closeOnExecAX ld C 0 # Index ld A (Child) # Find a free child slot do cmp C (Children) # Tried all children? while ne # No null (A) # Found empty 'pid'? while nz # No add A VI # Increment by sizeof(child) add C VI loop cc fork() # Fork child process nul4 # In child? js forkErrX if z # Yes ld (Slot) C # Set child index ld (Spkr) 0 # No children yet ld4 (SpMiPipe 4) # Set microphone to write end ld (Mic) A ld4 (S 4) # Close write end of 'hear' call closeAX ld4 (S 8) # Close read end of 'tell' call closeAX ld4 (SpMiPipe) # Close read end call closeAX ld A (Hear) # Already hearing? null A if nz # Yes call closeAX # Close it ld A (Hear) call closeInFileA ld A (Hear) call closeOutFileA end ld4 (S) # Read end of 'hear' ld (Hear) A call initInFileA_A # Create input file ld A (Tell) # Telling? null A if nz # Yes call closeAX end ld4 (S 12) # Write end of 'tell' ld (Tell) A ld E (Child) # Iterate children ld C (Children) # Count do sub C VI # More? while ge # Yes null (E) # 'pid'? if nz # Yes cc close((E I)) # Close 'hear' cc close((E II)) # Close 'tell' cc free((E V)) # Free buffer end add E VI # Increment by sizeof(child) loop ld (Children) 0 # No children cc free((Child)) ld (Child) 0 ld A (EnvInFrames) # Clear pids in InFrames do null A # More frames? while nz # Yes ld (A II) 0 # Clear 'pid' ld A (A) # Follow link loop ld A (EnvOutFrames) # Clear pids in OutFrames do null A # More frames? while nz # Yes ld (A II) 0 # Clear 'pid' ld A (A) # Follow link loop ld A (Catch) # Clear 'finally' expressions in Catch frames do null A # More frames? while nz # Yes ld (A II) ZERO # Clear 'fin' ld A (A) # Follow link loop cc free((Termio)) # Give up terminal control ld (Termio) 0 set (PRepl) (Repl) # Set parent REPL flag ld (PPid) (Pid) # Set parent process ID cc getpid() # Get new process ID shl A 4 # Make short number or A CNT ld (Pid) A # Set new process ID ld E (Fork) # Run '*Fork' call execE ld (Fork) Nil # Clear '*Fork' add S II # Drop 'hear' and 'tell' pipes setc # Return "in child" ret end cmp C (Children) # Children table full? ldnz E A # No: Get 'pid' into E if eq # Yes push A # Save child's 'pid' ld A (Child) # Get vector ld E C # Children add E (* 8 VI) # Eight more slots ld (Children) E call allocAE_A # Extend vector ld (Child) A add A E # Point A to the end ld E 8 # Init eight new slots do sub A VI # Decrement pointer ld (A) 0 # Clear 'pid' dec E # Done? until z # Yes pop E # Get 'pid' end add C (Child) # Point C to free 'child' entry ld (C) E # Set 'pid' ld4 (S) # Close read end of 'hear' call closeAX ld4 (S 4) # Write end of 'hear' ld (C II) A # Into 'tell' call nonblockingA_A # Set to non-blocking ld4 (S 8) # Read end of 'tell' ld (C I) A # Into 'hear' ld4 (S 12) # Close write end of 'tell' call closeAX ld (C III) 0 # Init buffer offset ld (C IV) 0 # buffer count ld (C V) 0 # No buffer yet add S II # Drop 'hear' and 'tell' pipes clrc # Return "in parent" ret # (bye 'cnt|NIL) (code 'doBye 2) ld X E ld E (E CDR) ld E (E) eval # Get exit code cmp E Nil if eq ld E 0 # Zero if NIL else call xCntEX_FE end # Exit (code 'byeE) nul (InBye) # Re-entered? if z # No set (InBye) 1 push E # Save exit code ld C 0 # Top frame call unwindC_Z # Unwind ld E (Bye) # Run exit expression(s) call execE pop E # Restore exit code end call flushAll # Flush all output channels (code 'finishE) call setCooked # Set terminal to cooked mode cc exit(E) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/gc.l0000644000000000000000000006063212265263724014666 0ustar rootroot# 17oct13abu # (c) Software Lab. Alexander Burger # Mark data (code 'markE 0) ld X 0 # Clear TOS do do cnt E # Short number? while z # No ld A E # Get cell pointer in A off A 15 test (A CDR) 1 # Already marked? while nz # No off (A CDR) 1 # Mark cell big E # Bigum? if nz # Yes ld C (A CDR) # Second digit do cnt C # Any? while z # Yes test (C BIG) 1 # Marked? while nz # Yes off (C BIG) 1 # Else mark it ld C (C BIG) # Next digit loop break T end ld C E # Previous item ld E (A) # Get CAR or X 1 # First visit ld (A) X # Keep TOS ld X C # TOS on previous loop do ld A X # TOS cell pointer in A and A -16 # Empty? jz ret # Yes test (A) 1 # Second visit? while z # Yes ld C X # TMP ld X (A CDR) # TOS up ld (A CDR) E # Restore CDR ld E C # E up loop ld C (A) # Up pointer ld (A) E # Restore CAR ld E (A CDR) # Get CDR off C 1 # Set second visit ld (A CDR) C # Store up pointer loop # Reserve cells (code 'needC 0) ld A (Avail) # Get avail list do null A # Enough free cells? jeq gc # No: Collect garbage ld A (A) dec C until z ret # Garbage collector (code 'gc 0) push A # Save push C push E push X push Y push Z ld (DB) ZERO # Cut off DB root ### Prepare all cells ### ld X Nil # Symbol table or (X) 1 # Set mark bit add X 32 # Skip padding do or (X) 1 # Set mark bit add X II # Next symbol cmp X GcSymEnd until gt ld X (Heaps) # Heap pointer do ld C CELLS do or (X CDR) 1 # Set mark bit add X II # Next cell dec C # Done? until z # Yes ld X (X) # Next heap null X # Done? until eq # Yes ### Mark ### ld Y GcMark # Mark globals do ld E (Y) # Next global call markE # Mark it add Y I cmp Y GcMarkEnd # Done? until eq # Yes ### Mark Env ### ld E (EnvIntern) # Mark current namespace call markE ### Mark stack(s) ### ld Y L do null Y # End of stack? while ne # No ld Z (Y) # Keep end of frame in Z do add Y I # End of frame? cmp Y Z while ne # No ld E (Y) # Next item call markE # Mark it loop ld Y (Y) # Next frame loop ld Y (Catch) # Catch frames do null Y # Any? while ne # Yes ld E (Y I) # Mark 'tag' null E # Any? if ne call markE # Yes end ld E (Y II) # Mark 'fin' call markE ld Y (Y) # Next frame loop ld Y (Stack1) # Search through stack segments ld C (Stacks) # Segment count do null C # Any? while nz # Yes null (Y -I) # In use? if nz # Yes push C # Save count null (Y -II) # Active? if z # Yes ld E (Y -I) # Mark 'tag' call markE else push Y # ld Y ((Y -II)) # Else get saved L do ld Z (Y) # Keep end of frame in Z do add Y I # End of frame? cmp Y Z while ne # No ld E (Y) # Next item call markE # Mark it loop ld Y (Y) # Next frame null Y # End of stack? until eq # Yes ld Y ((S) (pack -II "-(EnvMid-Catch)")) # Saved catch frames do null Y # Any? while ne # Yes ld E (Y I) # Mark 'tag' null E # Any? if ne call markE # Yes end ld E (Y II) # Mark 'fin' call markE ld Y (Y) # Next frame loop pop Y end pop C dec C # Decrement count end sub Y (StkSize) # Next segment loop # Mark externals ld Y Extern ld Z 0 # Clear TOS do do off (Y CDR) 1 # Clear mark bit ld A (Y CDR) # Get subtrees off (A CDR) 1 # Clear mark bit atom (A CDR) # Right subtree? while z # Yes ld C Y # Go right ld Y (A CDR) # Invert tree ld (A CDR) Z # TOS ld Z C loop do ld E (Y) # Get external symbol test (E) 1 # Already marked? if nz # No ld A (E TAIL) num A # Any properties? if z # Yes off A (| SYM 1) # Clear 'extern' tag and mark bit do ld A (A CDR) # Skip property off A 1 # Clear mark bit num A # Find name until nz end rcl A 1 # Dirty or deleted? if c # Yes call markE # Mark external symbol end end ld A (Y CDR) # Left subtree? atom (A) if z # Yes ld C Y # Go left ld Y (A) # Invert tree ld (A) Z # TOS or C SYM # First visit ld Z C break T end do ld A Z # TOS null A # Empty? jeq 10 # Done sym A # Second visit? if z # Yes ld C (A CDR) # Nodes ld Z (C CDR) # TOS on up link ld (C CDR) Y ld Y A break T end off A SYM # Set second visit ld C (A CDR) # Nodes ld Z (C) ld (C) Y ld Y A loop loop loop 10 ld A Db1 # DB root object ld (DB) A # Restore '*DB' test (A) 1 # Marked? if nz # No ld (A) Nil # Clear ld (A TAIL) DB1 # Set to "not loaded" end ld Y Extern # Clean up ld Z 0 # Clear TOS 20 do do ld A (Y CDR) atom (A CDR) # Right subtree? while z # Yes ld C Y # Go right ld Y (A CDR) # Invert tree ld (A CDR) Z # TOS ld Z C loop do test ((Y)) 1 # External symbol marked? if nz # No: Remove it ld A (Y CDR) # Get subtrees atom A # Any? if nz # No or (Y CDR) 1 # Set mark bit again ld Y A # Use NIL jmp 40 # Already traversed end atom (A) # Left branch? if nz # No or (Y CDR) 1 # Set mark bit again ld Y (A CDR) # Use right branch jmp 40 # Already traversed end atom (A CDR) # Right branch? if nz # No or (Y CDR) 1 # Set mark bit again ld Y (A) # Use left branch jmp 20 end ld A (A CDR) # A on right branch ld X (A CDR) # X on sub-branches atom (X) # Left? if nz # No ld (Y) (A) # Insert right sub-branch ld ((Y CDR) CDR) (X CDR) jmp 30 # Traverse left branch end ld X (X) # Left sub-branch do ld C (X CDR) # More left branches? atom (C) while z # Yes ld A X # Go down left ld X (C) loop ld (Y) (X) # Insert left sub-branch ld ((A CDR)) (C CDR) end 30 ld A (Y CDR) # Left subtree? atom (A) if z # Yes ld C Y # Go left ld Y (A) # Invert tree ld (A) Z # TOS or C SYM # First visit ld Z C break T end 40 do ld A Z # TOS null A # Empty? jeq 50 # Done sym A # Second visit? if z # Yes ld C (A CDR) # Nodes ld Z (C CDR) # TOS on up link ld (C CDR) Y ld Y A break T end off A SYM # Set second visit ld C (A CDR) # Nodes ld Z (C) ld (C) Y ld Y A loop loop loop 50 ### Clean up ### ld Y (Stack1) # Search through stack segments ld C (Stacks) # Segment count do null C # Any? while nz # Yes null (Y -I) # In use? if nz # Yes test ((Y -I)) 1 # 'tag' symbol gone? if nz # Yes ld (Y -I) 0 # Mark segment as unused dec (Stacks) # Last coroutine? if z # Yes ld (StkLimit) 0 # Clear stack limit end else null (Y -II) # Active? if nz # No ld X (Y (pack -II "-(EnvMid-EnvApply)")) # Saved apply stack do null X # End of stack? while ne # No ld Z (X) # Keep end of frame in Z add X II do off (X) 1 # Clear add X II # Next gc mark cmp X Z # End of frame? until ge # Yes ld X (Z I) # Next frame loop end end dec C # Decrement count end sub Y (StkSize) # Next segment loop ld Y (EnvApply) # Apply stack do null Y # End of stack? while ne # No ld Z (Y) # Keep end of frame in Z add Y II do off (Y) 1 # Clear add Y II # Next gc mark cmp Y Z # End of frame? until ge # Yes ld Y (Z I) # Next frame loop ### Sweep ### ld X 0 # Avail list ld Y (Heaps) # Heap list in Y ld C (GcCount) # Get cell count null C if ne # Non-zero: do lea Z (Y (- HEAP II)) # Z on last cell in chunk do test (Z CDR) 1 # Free cell? if nz # Yes ld (Z) X # Link avail ld X Z dec C end sub Z II cmp Z Y # Done? until lt # Yes ld Y (Y HEAP) # Next heap null Y until eq # All heaps done ld (Avail) X # Set new Avail do null C # Count minimum reached? while ns # No call heapAlloc # Allocate heap sub C CELLS loop else # Zero: Try to free heaps ld E Heaps # Heap list link pointer in E do ld A X # Keep avail list ld C CELLS # Counter lea Z (Y (- HEAP II)) # Z on last cell in chunk do test (Z CDR) 1 # Free cell? if nz # Yes ld (Z) X # Link avail ld X Z dec C end sub Z II cmp Z Y # Done? until lt # Yes null C # Remaining cells? if nz # Yes lea E (Y HEAP) # Point to link of next heap ld Y (E) # Next heap else ld X A # Reset avail list ld Y (Y HEAP) # Next heap cc free((E)) # Free empty heap ld (E) Y # Store next heap in list link end null Y # Next heap? until z # No ld (Avail) X # Set new Avail end pop Z pop Y pop X pop E pop C pop A ret # (gc ['cnt [cnt2]]) -> cnt | NIL (code 'doGc 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval # Eval cmp E Nil # Nil? if eq # Yes call gc # Collect with default else push E # Save return value call xCntEX_FE # Else get number of megabytes shl E 16 # Multiply with CELLS ld (GcCount) E # Set gc count call gc # Collect ld Y (Y CDR) # Next arg? atom Y if nz # No ld E CELLS # Standard default else call evCntXY_FE # New default shl E 16 # Multiply with CELLS end ld (GcCount) E # Set new value pop E end pop Y pop X ret ### Build cons pair ### (code 'cons_A 0) ld A (Avail) # Get avail list null A # Empty? if ne # No ld (Avail) (A) # Set new avail list ret end call gc # Collect garbage ld A (Avail) # Get avail list again ld (Avail) (A) # Set new avail list ret (code 'cons_C 0) ld C (Avail) # Get avail list null C # Empty? if ne # No ld (Avail) (C) # Set new avail list ret end call gc # Collect garbage ld C (Avail) # Get avail list again ld (Avail) (C) # Set new avail list ret (code 'cons_E 0) ld E (Avail) # Get avail list null E # Empty? if ne # No ld (Avail) (E) # Set new avail list ret end call gc # Collect garbage ld E (Avail) # Get avail list again ld (Avail) (E) # Set new avail list ret (code 'cons_X 0) ld X (Avail) # Get avail list null X # Empty? if ne # No ld (Avail) (X) # Set new avail list ret end call gc # Collect garbage ld X (Avail) # Get avail list again ld (Avail) (X) # Set new avail list ret (code 'cons_Y 0) ld Y (Avail) # Get avail list null Y # Empty? if ne # No ld (Avail) (Y) # Set new avail list ret end call gc # Collect garbage ld Y (Avail) # Get avail list again ld (Avail) (Y) # Set new avail list ret (code 'cons_Z 0) ld Z (Avail) # Get avail list null Z # Empty? if ne # No ld (Avail) (Z) # Set new avail list ret end call gc # Collect garbage ld Z (Avail) # Get avail list again ld (Avail) (Z) # Set new avail list ret (code 'consA_A 0) null (Avail) # Avail list empty? if ne # No ld A (Avail) # Get avail list ld (Avail) (A) # Set new avail list ret end link # Save A push A link call gc # Collect garbage drop ld A (Avail) # Get avail list ld (Avail) (A) # Set new avail list ret (code 'consC_A 0) ld A (Avail) # Get avail list null A # Empty? if ne # No ld (Avail) (A) # Set new avail list ret end link # Save C push C link call gc # Collect garbage drop ld A (Avail) # Get avail list again ld (Avail) (A) # Set new avail list ret (code 'consE_A 0) ld A (Avail) # Get avail list null A # Empty? if ne # No ld (Avail) (A) # Set new avail list ret end link # Save E push E link call gc # Collect garbage drop ld A (Avail) # Get avail list again ld (Avail) (A) # Set new avail list ret (code 'consX_A 0) ld A (Avail) # Get avail list null A # Empty? if ne # No ld (Avail) (A) # Set new avail list ret end link # Save X push X link call gc # Collect garbage drop ld A (Avail) # Get avail list again ld (Avail) (A) # Set new avail list ret (code 'consA_C 0) ld C (Avail) # Get avail list null C # Empty? if ne # No ld (Avail) (C) # Set new avail list ret end link # Save A push A link call gc # Collect garbage drop ld C (Avail) # Get avail list again ld (Avail) (C) # Set new avail list ret (code 'consC_C 0) null (Avail) # Avail list empty? if ne # No ld C (Avail) # Get avail list ld (Avail) (C) # Set new avail list ret end link # Save C push C link call gc # Collect garbage drop ld C (Avail) # Get avail list ld (Avail) (C) # Set new avail list ret (code 'consE_C 0) ld C (Avail) # Get avail list null C # Empty? if ne # No ld (Avail) (C) # Set new avail list ret end link # Save E push E link call gc # Collect garbage drop ld C (Avail) # Get avail list again ld (Avail) (C) # Set new avail list ret (code 'consA_E 0) ld E (Avail) # Get avail list null E # Empty? if ne # No ld (Avail) (E) # Set new avail list ret end link # Save A push A link call gc # Collect garbage drop ld E (Avail) # Get avail list again ld (Avail) (E) # Set new avail list ret (code 'consC_E 0) ld E (Avail) # Get avail list null E # Empty? if ne # No ld (Avail) (E) # Set new avail list ret end link # Save C push C link call gc # Collect garbage drop ld E (Avail) # Get avail list again ld (Avail) (E) # Set new avail list ret (code 'consE_E 0) null (Avail) # Avail list empty? if ne # No ld E (Avail) # Get avail list ld (Avail) (E) # Set new avail list ret end link # Save E push E link call gc # Collect garbage drop ld E (Avail) # Get avail list ld (Avail) (E) # Set new avail list ret (code 'consX_E 0) ld E (Avail) # Get avail list null E # Empty? if ne # No ld (Avail) (E) # Set new avail list ret end link # Save X push X link call gc # Collect garbage drop ld E (Avail) # Get avail list again ld (Avail) (E) # Set new avail list ret (code 'consA_X 0) ld X (Avail) # Get avail list null X # Empty? if ne # No ld (Avail) (X) # Set new avail list ret end link # Save A push A link call gc # Collect garbage drop ld X (Avail) # Get avail list again ld (Avail) (X) # Set new avail list ret (code 'consE_X 0) ld X (Avail) # Get avail list null X # Empty? if ne # No ld (Avail) (X) # Set new avail list ret end link # Save E push E link call gc # Collect garbage drop ld X (Avail) # Get avail list again ld (Avail) (X) # Set new avail list ret (code 'consY_X 0) ld X (Avail) # Get avail list null X # Empty? if ne # No ld (Avail) (X) # Set new avail list ret end link # Save Y push Y link call gc # Collect garbage drop ld X (Avail) # Get avail list again ld (Avail) (X) # Set new avail list ret (code 'consA_Y 0) ld Y (Avail) # Get avail list null Y # Empty? if ne # No ld (Avail) (Y) # Set new avail list ret end link # Save A push A link call gc # Collect garbage drop ld Y (Avail) # Get avail list again ld (Avail) (Y) # Set new avail list ret (code 'consA_Z 0) ld Z (Avail) # Get avail list null Z # Empty? if ne # No ld (Avail) (Z) # Set new avail list ret end link # Save A push A link call gc # Collect garbage drop ld Z (Avail) # Get avail list again ld (Avail) (Z) # Set new avail list ret (code 'consAC_E 0) ld E (Avail) # Get avail list null E # Empty? if ne # No ld (Avail) (E) # Set new avail list ret end link # Save A and C push A push C link call gc # Collect garbage drop ld E (Avail) # Get avail list again ld (Avail) (E) # Set new avail list ret ### Build symbol cells ### (code 'consSymX_E 0) cmp X ZERO # Name? jeq retNil # No ld E (Avail) # Get avail list null E # Empty? if eq # Yes link # Save name push X link call gc # Collect garbage drop ld E (Avail) # Get avail list again end ld (Avail) (E) # Set new avail list ld (E) X # Set new symbol's name or E SYM # Make symbol ld (E) E # Set value to itself ret ### Build number cells ### (code 'boxNum_A 0) ld A (Avail) # Get avail list null A # Empty? if eq # Yes call gc # Collect garbage ld A (Avail) # Get avail list again end ld (Avail) (A) # Set new avail list ld (A CDR) ZERO # Set CDR to ZERO or B BIG # Make number ret (code 'boxNum_C 0) ld C (Avail) # Get avail list null C # Empty? if eq # Yes call gc # Collect garbage ld C (Avail) # Get avail list again end ld (Avail) (C) # Set new avail list ld (C CDR) ZERO # Set CDR to ZERO or C BIG # Make number ret (code 'boxNum_E 0) ld E (Avail) # Get avail list null E # Empty? if eq # Yes call gc # Collect garbage ld E (Avail) # Get avail list again end ld (Avail) (E) # Set new avail list ld (E CDR) ZERO # Set CDR to ZERO or E BIG # Make number ret (code 'boxNum_X 0) ld X (Avail) # Get avail list null X # Empty? if eq # Yes call gc # Collect garbage ld X (Avail) # Get avail list again end ld (Avail) (X) # Set new avail list ld (X CDR) ZERO # Set CDR to ZERO or X BIG # Make number ret (code 'boxNumA_A 0) push A ld A (Avail) # Get avail list null A # Empty? if eq # Yes call gc # Collect garbage ld A (Avail) # Get avail list again end ld (Avail) (A) # Set new avail list pop (A) # Set new cell's CAR ld (A CDR) ZERO # Set CDR to ZERO or B BIG # Make number ret (code 'boxNumE_E 0) push E ld E (Avail) # Get avail list null E # Empty? if eq # Yes call gc # Collect garbage ld E (Avail) # Get avail list again end ld (Avail) (E) # Set new avail list pop (E) # Set new cell's CAR ld (E CDR) ZERO # Set CDR to ZERO or E BIG # Make number ret (code 'consNumAC_A 0) push A ld A (Avail) # Get avail list null A # Empty? if eq # Yes link # Save C push C link call gc # Collect garbage drop ld A (Avail) # Get avail list again end ld (Avail) (A) # Set new avail list pop (A) # Set new cell's CAR ld (A CDR) C # Set CDR or B BIG # Make number ret (code 'consNumAE_A 0) push A ld A (Avail) # Get avail list null A # Empty? if eq # Yes link # Save E push E link call gc # Collect garbage drop ld A (Avail) # Get avail list again end ld (Avail) (A) # Set new avail list pop (A) # Set new cell's CAR ld (A CDR) E # Set CDR or B BIG # Make number ret (code 'consNumCA_C 0) push C ld C (Avail) # Get avail list null C # Empty? if eq # Yes link # Save A push A link call gc # Collect garbage drop ld C (Avail) # Get avail list again end ld (Avail) (C) # Set new avail list pop (C) # Set new cell's CAR ld (C CDR) A # Set CDR or C BIG # Make number ret (code 'consNumCE_A 0) ld A (Avail) # Get avail list null A # Empty? if eq # Yes link # Save E push E link call gc # Collect garbage drop ld A (Avail) # Get avail list again end ld (Avail) (A) # Set new avail list ld (A) C # Set new cell's CAR ld (A CDR) E # Set CDR or B BIG # Make number ret (code 'consNumCE_C 0) push C ld C (Avail) # Get avail list null C # Empty? if eq # Yes link # Save E push E link call gc # Collect garbage drop ld C (Avail) # Get avail list again end ld (Avail) (C) # Set new avail list pop (C) # Set new cell's CAR ld (C CDR) E # Set CDR or C BIG # Make number ret (code 'consNumCE_E 0) null (Avail) # Avail list empty? if eq # Yes link # Save E push E link call gc # Collect garbage drop end push E ld E (Avail) # Get avail list ld (Avail) (E) # Set new avail list ld (E) C # Set new cell's CAR pop (E CDR) # Set CDR or E BIG # Make number ret (code 'consNumEA_A 0) null (Avail) # Avail list empty? if eq # Yes link # Save A push A link call gc # Collect garbage drop end push A ld A (Avail) # Get avail list ld (Avail) (A) # Set new avail list ld (A) E # Set new cell's CAR pop (A CDR) # Set CDR or B BIG # Make number ret (code 'consNumEA_E 0) push E ld E (Avail) # Get avail list null E # Empty? if eq # Yes link # Save A push A link call gc # Collect garbage drop ld E (Avail) # Get avail list again end ld (Avail) (E) # Set new avail list pop (E) # Set new cell's CAR ld (E CDR) A # Set CDR or E BIG # Make number ret (code 'consNumEC_E 0) push E ld E (Avail) # Get avail list null E # Empty? if eq # Yes link # Save C push C link call gc # Collect garbage drop ld E (Avail) # Get avail list again end ld (Avail) (E) # Set new avail list pop (E) # Set new cell's CAR ld (E CDR) C # Set CDR or E BIG # Make number ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/glob.l0000644000000000000000000024720412265263724015222 0ustar rootroot# 28aug13abu # (c) Software Lab. Alexander Burger (data 'Data) initData :: AV word 0 # Command line argument vector :: AV0 word 0 # Command name :: Home word 0 # Home directory :: Heaps word 0 # Heap list :: Avail word 0 # Avail list :: Buf word 0 # General 16-byte buffer word 0 : Stack0 word 0 # Initial stack pointer : Stack1 word 0 # Coroutine stack base : Stacks word 0 # Coroutine stack segment count : StkSize word STACK # Coroutine stack segment size : StkLimit word 0 # Stack limit: StackN-Size+4096 : Termio word 0 # Raw mode terminal I/O : Tv word 0 # 'timeval' structure word 0 : Time word 0 # Pointer to time structure : USec word 0 # Startup microseconds : TtyPid word 0 # Terminal process ID : InFDs word 0 # Scaled number of input files : InFiles word 0 # Input files : OutFDs word 0 # Scaled number of output files : OutFiles word 0 # Output files : PutBinBZ word 0 # Binary output function : GetBinZ_FB word 0 # Binary input function : Seed word 0 # Random seed low word 0 # Random seed high : TickU word 0 # Ticks in user time : TickS word 0 # Ticks in system time : Slot word 0 # Child index : Spkr word 0 # RPC loadspeaker : Mic word 0 # RPC microphone : SpMiPipe word 0 # Speaker/microphone pipe : Hear word 0 # RPC listener : Tell word 0 # RPC broadcaster : TellBuf word 0 # RPC buffer : Talking word 0 # Active child : Children word 0 # Scaled number of children : Child word 0 # Child array : ExtN word 0 # External symbol offset : Extn word 0 : StrX word 0 # String status : StrC word 0 : LineC word -1 : Break word 0 # Breakpoint : GcCount word CELLS # Collector count : Sep0 word (char ".") # Decimal separator : Sep3 word (char ",") # Thousand separator : BufEnd word 0 # Common buffer end pointer : Penv word Nil # Pilog environment : Pnl word Nil # Signals : Signal skip (* I SIGNALS) # Database : DBs word 0 # Scaled number of DB files : DbFile word 0 # DB file : DbFiles word 0 # DB files : DbBlock word 0 # Block buffer : MaxBlkSize word 0 # Maximum block size : BlkIndex word 0 # Block index : BlkLink word 0 # Next block : DbJnl word 0 # Journal file : DbLog word 0 # Transaction log file # GC relevant data : GcMark :: Transient word Nil # Short transient names word Nil # Long transient names : Alarm word Nil # Alarm handler : Sigio word Nil # Sigio handler : LineX word ZERO # Console line : Lisp word Nil # Lisp callbacks: tag+fun word Nil word Nil # 2 word Nil word Nil # 3 word Nil word Nil # 4 word Nil word Nil # 5 word Nil word Nil # 6 word Nil word Nil # 7 word Nil word Nil # 8 word Nil word Nil # 9 word Nil word Nil # 10 word Nil word Nil # 11 word Nil word Nil # 12 word Nil word Nil # 13 word Nil word Nil # 14 word Nil word Nil # 15 word Nil word Nil # 16 word Nil word Nil # 17 word Nil word Nil # 18 word Nil word Nil # 19 word Nil word Nil # 20 word Nil word Nil # 21 word Nil word Nil # 22 word Nil word Nil # 23 word Nil word Nil # 24 word Nil : LispEnd : GcMarkEnd # Symbol Table (data 'SymTab 0) initSym Nil "NIL" Nil word Nil # CDR when NIL is accessed as an empty list word 0 # Padding : Pico word Nil # Short internal names word Nil # Long internal names # Protected symbols initSym pico "pico" Pico initSym CPU "*CPU" TgCPU initSym OS "*OS" TgOS initSym DB "*DB" Db1 initFun Meth "meth" doMeth initFun Quote "quote" doQuote initSym TSym "T" TSym # System globals initSym ISym "I" Nil initSym NSym "N" Nil initSym SSym "S" Nil initSym CSym "C" Nil initSym BSym "B" Nil initSym Solo "*Solo" ZERO initSym PPid "*PPid" Nil initSym Pid "*Pid" 0 initSym At "@" Nil initSym At2 "@@" Nil initSym At3 "@@@" Nil initSym This "This" Nil initSym Prompt "*Prompt" Nil initSym Dbg "*Dbg" Nil initSym Zap "*Zap" Nil initSym Ext "*Ext" Nil initSym Scl "*Scl" ZERO initSym Class "*Class" Nil initSym Run "*Run" Nil initSym Hup "*Hup" Nil initSym Sig1 "*Sig1" Nil initSym Sig2 "*Sig2" Nil initSym Up "\^" Nil initSym Err "*Err" Nil initSym Msg "*Msg" Nil initSym Uni "*Uni" Nil initSym Led "*Led" Nil initSym Tsm "*Tsm" Nil initSym Adr "*Adr" Nil initSym Fork "*Fork" Nil initSym Bye "*Bye" Nil # System functions initFun NIL "raw" doRaw initFun NIL "alarm" doAlarm initFun NIL "sigio" doSigio initFun NIL "protect" doProtect initFun NIL "heap" doHeap initFun NIL "stack" doStack initFun NIL "adr" doAdr initFun NIL "env" doEnv initFun NIL "trail" doTrail initFun NIL "up" doUp initFun NIL "sys" doSys initFun NIL "quit" doQuit initFun NIL "errno" doErrno initFun NIL "native" doNative initFun NIL "struct" doStruct initFun NIL "lisp" doLisp initFun NIL "args" doArgs initFun NIL "next" doNext initFun NIL "arg" doArg initFun NIL "rest" doRest initFun NIL "date" doDate initFun NIL "time" doTime initFun NIL "usec" doUsec initFun NIL "pwd" doPwd initFun NIL "cd" doCd initFun NIL "ctty" doCtty initFun NIL "info" doInfo initFun NIL "file" doFile initFun NIL "dir" doDir initFun NIL "cmd" doCmd initFun NIL "argv" doArgv initFun NIL "opt" doOpt initFun NIL "version" doVersion # Garbage collection initFun NIL "gc" doGc # Mapping initFun NIL "apply" doApply initFun NIL "pass" doPass initFun NIL "maps" doMaps initFun NIL "map" doMap initFun NIL "mapc" doMapc initFun NIL "maplist" doMaplist initFun NIL "mapcar" doMapcar initFun NIL "mapcon" doMapcon initFun NIL "mapcan" doMapcan initFun NIL "filter" doFilter initFun NIL "extract" doExtract initFun NIL "seek" doSeek initFun NIL "find" doFind initFun NIL "pick" doPick initFun NIL "cnt" doCnt initFun NIL "sum" doSum initFun NIL "maxi" doMaxi initFun NIL "mini" doMini initFun NIL "fish" doFish initFun NIL "by" doBy # Control flow initFun NIL "as" doAs initFun NIL "lit" doLit initFun NIL "eval" doEval initFun NIL "run" doRun initFun NIL "def" doDef initFun NIL "de" doDe initFun NIL "dm" doDm initFun NIL "box" doBox initFun NIL "new" doNew initFun NIL "type" doType initFun NIL "isa" doIsa initFun NIL "method" doMethod initFun NIL "send" doSend initFun NIL "try" doTry initFun NIL "super" doSuper initFun NIL "extra" doExtra initFun NIL "with" doWith initFun NIL "bind" doBind initFun NIL "job" doJob initFun NIL "let" doLet initFun NIL "let?" doLetQ initFun NIL "use" doUse initFun NIL "and" doAnd initFun NIL "or" doOr initFun NIL "nand" doNand initFun NIL "nor" doNor initFun NIL "xor" doXor initFun NIL "bool" doBool initFun NIL "not" doNot initFun NIL "nil" doNil initFun NIL "t" doT initFun NIL "prog" doProg initFun NIL "prog1" doProg1 initFun NIL "prog2" doProg2 initFun NIL "if" doIf initFun NIL "if2" doIf2 initFun NIL "ifn" doIfn initFun NIL "when" doWhen initFun NIL "unless" doUnless initFun NIL "cond" doCond initFun NIL "nond" doNond initFun NIL "case" doCase initFun NIL "casq" doCasq initFun NIL "state" doState initFun NIL "while" doWhile initFun NIL "until" doUntil initFun NIL "at" doAt initFun NIL "do" doDo initFun NIL "loop" doLoop initFun NIL "for" doFor initFun NIL "catch" doCatch initFun NIL "throw" doThrow initFun NIL "finally" doFinally initFun NIL "co" doCo initFun NIL "yield" doYield initFun NIL "!" doBreak initFun NIL "e" doE initFun NIL "$" doTrace initFun NIL "call" doCall initFun NIL "tick" doTick initFun NIL "ipid" doIpid initFun NIL "opid" doOpid initFun NIL "kill" doKill initFun NIL "fork" doFork initFun NIL "bye" doBye # Symbol functions initFun NIL "name" doName initFun NIL "sp?" doSpQ initFun NIL "pat?" doPatQ initFun NIL "fun?" doFunQ initFun NIL "getd" doGetd initFun NIL "all" doAll initFun NIL "symbols" doSymbols initFun NIL "intern" doIntern initFun NIL "extern" doExtern initFun NIL "====" doHide initFun NIL "box?" doBoxQ initFun NIL "str?" doStrQ initFun NIL "ext?" doExtQ initFun NIL "touch" doTouch initFun NIL "zap" doZap initFun NIL "chop" doChop initFun NIL "pack" doPack initFun NIL "glue" doGlue initFun NIL "text" doText initFun NIL "pre?" doPreQ initFun NIL "sub?" doSubQ initFun NIL "val" doVal initFun NIL "set" doSet initFun NIL "setq" doSetq initFun NIL "swap" doSwap initFun NIL "xchg" doXchg initFun NIL "on" doOn initFun NIL "off" doOff initFun NIL "onOff" doOnOff initFun NIL "zero" doZero initFun NIL "one" doOne initFun NIL "default" doDefault initFun NIL "push" doPush initFun NIL "push1" doPush1 initFun NIL "pop" doPop initFun NIL "cut" doCut initFun NIL "del" doDel initFun NIL "queue" doQueue initFun NIL "fifo" doFifo initFun NIL "idx" doIdx initFun NIL "lup" doLup initFun NIL "put" doPut initFun NIL "get" doGet initFun NIL "prop" doProp initFun NIL ";" doSemicol initFun NIL "=:" doSetCol initFun NIL ":" doCol initFun NIL "::" doPropCol initFun NIL "putl" doPutl initFun NIL "getl" doGetl initFun NIL "wipe" doWipe initFun NIL "meta" doMeta initFun NIL "low?" doLowQ initFun NIL "upp?" doUppQ initFun NIL "lowc" doLowc initFun NIL "uppc" doUppc initFun NIL "fold" doFold # List processing initFun NIL "car" doCar initFun NIL "cdr" doCdr initFun NIL "caar" doCaar initFun NIL "cadr" doCadr initFun NIL "cdar" doCdar initFun NIL "cddr" doCddr initFun NIL "caaar" doCaaar initFun NIL "caadr" doCaadr initFun NIL "cadar" doCadar initFun NIL "caddr" doCaddr initFun NIL "cdaar" doCdaar initFun NIL "cdadr" doCdadr initFun NIL "cddar" doCddar initFun NIL "cdddr" doCdddr initFun NIL "caaaar" doCaaaar initFun NIL "caaadr" doCaaadr initFun NIL "caadar" doCaadar initFun NIL "caaddr" doCaaddr initFun NIL "cadaar" doCadaar initFun NIL "cadadr" doCadadr initFun NIL "caddar" doCaddar initFun NIL "cadddr" doCadddr initFun NIL "cdaaar" doCdaaar initFun NIL "cdaadr" doCdaadr initFun NIL "cdadar" doCdadar initFun NIL "cdaddr" doCdaddr initFun NIL "cddaar" doCddaar initFun NIL "cddadr" doCddadr initFun NIL "cdddar" doCdddar initFun NIL "cddddr" doCddddr initFun NIL "nth" doNth initFun NIL "con" doCon initFun NIL "cons" doCons initFun NIL "conc" doConc initFun NIL "circ" doCirc initFun NIL "rot" doRot initFun NIL "list" doList initFun NIL "need" doNeed initFun NIL "range" doRange initFun NIL "full" doFull initFun NIL "make" doMake initFun NIL "made" doMade initFun NIL "chain" doChain initFun NIL "link" doLink initFun NIL "yoke" doYoke initFun NIL "copy" doCopy initFun NIL "mix" doMix initFun NIL "append" doAppend initFun NIL "delete" doDelete initFun NIL "delq" doDelq initFun NIL "replace" doReplace initFun NIL "strip" doStrip initFun NIL "split" doSplit initFun NIL "reverse" doReverse initFun NIL "flip" doFlip initFun NIL "trim" doTrim initFun NIL "clip" doClip initFun NIL "head" doHead initFun NIL "tail" doTail initFun NIL "stem" doStem initFun NIL "fin" doFin initFun NIL "last" doLast initFun NIL "==" doEq initFun NIL "n==" doNEq initFun NIL "=" doEqual initFun NIL "<>" doNEqual initFun NIL "=0" doEq0 initFun NIL "=T" doEqT initFun NIL "n0" doNEq0 initFun NIL "nT" doNEqT initFun NIL "<" doLt initFun NIL "<=" doLe initFun NIL ">" doGt initFun NIL ">=" doGe initFun NIL "max" doMax initFun NIL "min" doMin initFun NIL "atom" doAtom initFun NIL "pair" doPair initFun NIL "circ?" doCircQ initFun NIL "lst?" doLstQ initFun NIL "num?" doNumQ initFun NIL "sym?" doSymQ initFun NIL "flg?" doFlgQ initFun NIL "member" doMember initFun NIL "memq" doMemq initFun NIL "mmeq" doMmeq initFun NIL "sect" doSect initFun NIL "diff" doDiff initFun NIL "index" doIndex initFun NIL "offset" doOffset initFun NIL "prior" doPrior initFun NIL "length" doLength initFun NIL "size" doSize initFun NIL "bytes" doBytes initFun NIL "assoc" doAssoc initFun NIL "asoq" doAsoq initFun NIL "rank" doRank initFun NIL "match" doMatch initFun NIL "fill" doFill initFun NIL "prove" doProve initFun NIL "->" doArrow initFun NIL "unify" doUnify initFun NIL "sort" doSort # Arithmetics initFun NIL "format" doFormat initFun NIL "+" doAdd initFun NIL "-" doSub initFun NIL "inc" doInc initFun NIL "dec" doDec initFun NIL "*" doMul initFun NIL "*/" doMulDiv initFun NIL "/" doDiv initFun NIL "%" doRem initFun NIL ">>" doShift initFun NIL "lt0" doLt0 initFun NIL "le0" doLe0 initFun NIL "ge0" doGe0 initFun NIL "gt0" doGt0 initFun NIL "abs" doAbs initFun NIL "bit?" doBitQ initFun NIL "&" doBitAnd initFun NIL "|" doBitOr initFun NIL "x|" doBitXor initFun NIL "sqrt" doSqrt initFun NIL "seed" doSeed initFun NIL "hash" doHash initFun NIL "rand" doRand # Input/Output initFun NIL "path" doPath initFun NIL "read" doRead initFun NIL "wait" doWait initFun NIL "sync" doSync initFun NIL "hear" doHear initFun NIL "tell" doTell initFun NIL "poll" doPoll initFun NIL "key" doKey initFun NIL "peek" doPeek initFun NIL "char" doChar initFun NIL "skip" doSkip initFun NIL "eol" doEol initFun NIL "eof" doEof initFun NIL "from" doFrom initFun NIL "till" doTill initFun NIL "line" doLine initFun NIL "lines" doLines initFun NIL "any" doAny initFun NIL "sym" doSym initFun NIL "str" doStr initFun NIL "load" doLoad initFun NIL "in" doIn initFun NIL "out" doOut initFun NIL "err" doErr initFun NIL "ctl" doCtl initFun NIL "pipe" doPipe initFun NIL "open" doOpen initFun NIL "close" doClose initFun NIL "echo" doEcho initFun NIL "prin" doPrin initFun NIL "prinl" doPrinl initFun NIL "space" doSpace initFun NIL "print" doPrint initFun NIL "printsp" doPrintsp initFun NIL "println" doPrintln initFun NIL "flush" doFlush initFun NIL "rewind" doRewind initFun NIL "ext" doExt initFun NIL "rd" doRd initFun NIL "pr" doPr initFun NIL "wr" doWr # Database initFun NIL "pool" doPool initFun NIL "journal" doJournal initFun NIL "id" doId initFun NIL "seq" doSeq initFun NIL "lieu" doLieu initFun NIL "lock" doLock initFun NIL "commit" doCommit initFun NIL "rollback" doRollback initFun NIL "mark" doMark initFun NIL "free" doFree initFun NIL "dbck" doDbck # Networking initFun NIL "port" doPort initFun NIL "accept" doAccept initFun NIL "listen" doListen initFun NIL "host" doHost initFun NIL "connect" doConnect initFun NIL "udp" doUdp : SymTabEnd # Transient symbols initSym TgCPU `*Architecture TgCPU initSym TgOS `*TargetOS TgOS # Database root symbol '{1}' word DB1 # Name : Db1 word Nil # Value :: Extern # External symbol tree root node word Db1 word Nil : GcSymEnd # Version number :: Version word (short `(car *Version)) word .+8 word (short `(cadr *Version)) word .+8 word (short `(caddr *Version)) word .+8 word (short `(cadddr *Version)) word Nil # Structures : EnvCo # Coroutine environment :: Chr word 0 # Single-char buffer :: PutB word 0 # Character output function :: Get_A word 0 # Character input function :: InFile word 0 # Input file :: OutFile word 0 # Output file : Catch word 0 # Catch frames : Env # environment : EnvBind word 0 # Bind frames (first item in Env) : EnvInFrames word 0 # Input frames : EnvOutFrames word 0 # Output frames : EnvErrFrames word 0 # Error frames : EnvCtlFrames word 0 # Control frames :: EnvIntern word pico # Current namespace of internal symbols : EnvArgs word 0 # Varargs frame : EnvNext word 0 # Next vararg : EnvCls word 0 # Method class : EnvKey word 0 # Method key : EnvApply word 0 # Apply frames : EnvMake word 0 # 'make' env : EnvYoke word 0 : CLink word 0 # Saved C link register : EnvParseX word 0 # Parser status : EnvParseC word 0 : EnvParseEOF word -1 : EnvMid # Must be aligned : EnvCo7 word 0 # Coroutines : EnvTask word Nil # Task list : EnvProtect word 0 # Signal protection : EnvTrace word 0 # Trace level : EnvEnd # Must be aligned : OrgTermio skip TERMIOS # Original termio structure : Flock skip FLOCK # File lock structure : Tms skip TMS # 'times' structure : Addr skip SOCKADDR_IN6 # Internet socket address : TBuf byte (+ INTERN 4) # 'T' in PLIO format byte (char "T") # Case mappings from the GNU Kaffe Project align 2 : CaseBlocks hx2 ("1C2" "1C2" "1C1" "12C" "12B" "1A0" "1F8" "2DC" "25F" "2EE" "215" "346" "2DC" "326" "2BC" "216") hx2 ("15F" "2D4" "376" "376" "376" "369" "FE8F" "344" "FF85" "FF65" "FDB5" "FDA1" "1B" "2C4" "1C" "47") hx2 ("FEA8" "FF8C" "235" "FEFF" "1A" "FEBF" "26" "FB20" "FE28" "113" "104" "FB61" "FB5A" "10B" "109" "FE") hx2 ("FF08" "229" "25E" "1C7" "1FC" "1DC" "FC46" "229" "FE27" "FB55" "169" "FBC8" "FC" "103" "FB68" "FB48") hx2 ("FB28" "FB08" "FAE8" "FAC8" "FAA8" "FA88" "FA68" "FA48" "65" "50" "AB" "139" "FE0E" "63" "155" "1A8") hx2 ("F669" "129" "128" "F91F" "FE56" "108" "107" "FAC0" "FC8E" "FEAD" "C6" "FCA7" "FB95" "F47D" "9F" "FB17") hx2 ("FE20" "FD28" "FB2F" "3B" "F3B9" "FE57" "FCCE" "FFBB" "F339" "FA98" "FF8B" "FF3B" "FA54" "F7E3" "FF2B" "FAD7") hx2 ("FB69" "FC3A" "FEE5" "F4C8" "FCB0" "FA88" "FDBF" "F448" "FE45" "FCC7" "FE4F" "F7F1" "F715" "F2E8" "FD9F" "F348") hx2 ("F96A" "FC02" "FD97" "F2C8" "F2A8" "F4B9" "F4B3" "EF6B" "F86A" "F84A" "FC58" "F80A" "F7EA" "FC0F" "F7AA" "EE9C") hx2 ("FB90" "F74A" "F7FA" "F70A" "F7CA" "F792" "F471" "F4D2" "F732" "F64A" "F401" "F64D" "EFA8" "F5CA" "F5AA" "ECA1") hx2 ("F569" "F54A" "F52A" "F50A" "F4EA" "F4CA" "F4AA" "F48A" "F46A" "F44A" "F42A" "F40A" "F3EA" "F3CA" "F3AA" "F38A") hx2 ("F36A" "F34A" "F32A" "F289" "F777" "F2CA" "F2AA" "F737" "EC28" "EC08" "EBE8" "EBC8" "F1EA" "F4A2" "F545" "EDC6") hx2 ("F2D7" "F14A" "E8ED" "E81E" "F0EA" "F597" "EA68" "EA48" "EA28" "EA08" "E9E8" "E9C8" "E9A8" "E988" "E968" "E948") hx2 ("E928" "E908" "E8E8" "E8C8" "E8A8" "E888" "E868" "E848" "E828" "E808" "E7E8" "E7C8" "E7A8" "E788" "E768" "E748") hx2 ("E728" "E708" "E6E8" "E6C8" "E6A8" "E688" "E668" "E648" "E628" "E608" "E5E8" "E5C8" "E5A8" "E588" "E568" "E548") hx2 ("E55F" "E53F" "E51F" "E4FF" "EFD7" "E4BF" "E49F" "E485" "EF87" "EF57" "EF57" "EF57" "EF57" "EF47" "E1AD" "EF46") hx2 ("EF46" "EF46" "E1E0" "E3DD" "EF06" "E9D9" "EBEB" "E244" "EED4" "EF65" "E1F5" "EF45" "EEE9" "EF7C" "EE74" "EF70") hx2 ("EF7D" "EF78" "EE91" "EFD3" "EE7D" "EE25" "EE27" "EF65" "EFDD" "EE96" "EFD3" "EFE1" "EF69" "DF88" "DF68" "DF48") hx2 ("ED2B" "ED3D" "ED19" "EF1C" "EF08" "ED47" "ED3D" "ED33" "EC2B" "EC0B" "EBEB" "EBCB" "EBCE" "EA7C" "EB69" "EB6C") hx2 ("E9B6" "EB0B" "EAEB" "E9E9" "DCA8" "DC88" "DC68" "DC48" "E910" "EA23" "EB58" "EB4F" "EB45" "EAE5" "DB68" "DB48") hx2 ("E92B" "E90B" "E8EB" "E8CB" "E8AB" "E88B" "E86B" "E84B" "DA28" "DA08" "D9E8" "D9C8" "D9A8" "D988" "D968" "D948") hx2 ("D928" "D908" "D8E8" "D8C8" "D8A8" "D888" "D868" "D848" "D828" "D808" "D7E8" "D7C8" "D7A8" "D788" "D768" "D748") hx2 ("D728" "D708" "D6E8" "D6C8" "D6A8" "D688" "D668" "D648" "D628" "D608" "D5E8" "D5C8" "D5A8" "D588" "D568" "D548") hx2 ("D528" "D508" "D4E8" "D4C8" "E2B1" "E28B" "E26B" "E270" "E22B" "E20B" "E1EB" "E1CB" "E1AB" "E18B" "E18E" "DD8F") hx2 ("E3A8" "DFD3" "D929" "D90A" "E348" "D8C9" "D8AA" "DCD7" "DCB2" "D681" "D82A" "D80A" "E268" "CEDE" "D168" "D148") hx2 ("E116" "E0E9" "E1CB" "E0B7" "E0B7" "E15E" "DF17" "E034" "E013" "DFF3" "DFD3" "DE6C" "DF93" "DF73" "DF55" "DF34") hx2 ("D56A" "D54A" "D52A" "D50A" "D4EA" "D4CA" "D4AA" "D48A" "D46A" "D44A" "D42A" "D40A" "D3EA" "D3CA" "D3AA" "D38A") hx2 ("D36A" "D34A" "D32A" "D30A" "D2EA" "D2CA" "D2AA" "D28A" "D26A" "D24A" "D22A" "D20A" "D1EA" "D1CA" "D1AA" "D18A") hx2 ("D16A" "D14A" "D12A" "D10A" "D0EA" "D0CA" "D0AA" "D08A" "D06A" "D04A" "D02A" "D00A" "CFEA" "CFCA" "CFAA" "CF8A") hx2 ("CF6A" "CF4A" "CF2A" "CF0A" "CEEA" "CECA" "CEAA" "CE8A" "CE6A" "CE4A" "CE2A" "CE0A" "CDEA" "CDCA" "CDAA" "CD8A") hx2 ("CD6A" "CD4A" "CD2A" "CD0A" "CCEA" "CCCA" "CCAA" "CC8A" "CC6A" "CC4A" "CC2A" "CC0A" "CBEA" "CBCA" "CBAA" "CB8A") hx2 ("CB6A" "CB4A" "CB2A" "CB0A" "CAEA" "CACA" "CAAA" "CA8A" "CA6A" "CA4A" "CA2A" "CA0A" "C9EA" "C9CA" "C9AA" "C98A") hx2 ("C96A" "C94A" "C92A" "C90A" "C8EA" "C8CA" "C8AA" "C88A" "C86A" "C84A" "C82A" "C80A" "C7EA" "C7CA" "C7AA" "C78A") hx2 ("C76A" "C74A" "C72A" "C70A" "C6EA" "C6CA" "C6AA" "C68A" "C66A" "C64A" "C62A" "C60A" "C5EA" "C5CA" "C5AA" "C58A") hx2 ("C56A" "C54A" "C52A" "C50A" "C4EA" "C4CA" "C4AA" "C48A" "C46A" "C44A" "C42A" "C40A" "C3EA" "C3CA" "C3AA" "C38A") hx2 ("C36A" "C34A" "C32A" "C30A" "C2EA" "C2CA" "C2AA" "C28A" "C26A" "C24A" "C22A" "C20A" "C1EA" "C1CA" "C1AA" "C18A") hx2 ("C16A" "C14A" "C12A" "C10A" "C0EA" "C0CA" "C0AA" "C08A" "C06A" "C04A" "C02A" "C00A" "BFEA" "BFCA" "BFAA" "BF8A") hx2 ("BF6A" "BF4A" "BF2A" "BF0A" "BEEA" "BECA" "BEAA" "BE8A" "BE6A" "BE4A" "BE2A" "BE0A" "BDEA" "BDCA" "BDAA" "BD8A") hx2 ("BD6A" "BD4A" "BD2A" "BD0A" "BCEA" "BCCA" "BCAA" "BC8A" "BC6A" "BC4A" "BC2A" "BC0A" "BBEA" "B2E0" "B568" "B548") hx2 ("BB6A" "BB4A" "BB2A" "BB0A" "BAEA" "BACA" "BAAA" "BA8A" "BA6A" "BA4A" "BA2A" "BA0A" "B9EA" "B9CA" "B9AA" "B98A") hx2 ("B96A" "B94A" "B92A" "B90A" "B8EA" "B8CA" "B8AA" "B88A" "B86A" "B84A" "B82A" "B80A" "B7EA" "B7CA" "B7AA" "B78A") hx2 ("B76A" "B74A" "B72A" "B70A" "B6EA" "B6CA" "B6AA" "B68A" "B66A" "B64A" "B62A" "B60A" "B5EA" "B5CA" "B5AA" "B58A") hx2 ("B56A" "B54A" "B52A" "B50A" "B4EA" "B4CA" "B4AA" "B48A" "B46A" "B44A" "B42A" "B40A" "B3EA" "B3CA" "B3AA" "B38A") hx2 ("B36A" "B34A" "B32A" "B30A" "B2EA" "B2CA" "B2AA" "B28A" "B26A" "B24A" "B22A" "B20A" "B1EA" "B1CA" "B1AA" "B18A") hx2 ("B16A" "B14A" "B12A" "B10A" "B0EA" "B0CA" "B0AA" "B08A" "B06A" "B04A" "B02A" "B00A" "AFEA" "AFCA" "AFAA" "AF8A") hx2 ("AF6A" "AF4A" "AF2A" "AF0A" "AEEA" "AECA" "AEAA" "AE8A" "AE6A" "AE4A" "AE2A" "AE0A" "ADEA" "ADCA" "ADAA" "AD8A") hx2 ("AD6A" "AD4A" "AD2A" "AD0A" "ACEA" "ACCA" "ACAA" "AC8A" "AC6A" "AC4A" "AC2A" "AC0A" "ABEA" "ABCA" "ABAA" "AB8A") hx2 ("AB6A" "AB4A" "AB2A" "AB0A" "AAEA" "AACA" "AAAA" "AA8A" "AA6A" "AA4A" "AA2A" "AA0A" "A9EA" "A9CA" "A9AA" "A98A") hx2 ("A96A" "A94A" "A92A" "A90A" "A8EA" "A8CA" "A8AA" "A88A" "A86A" "A84A" "A82A" "A80A" "A7EA" "A7CA" "A7AA" "A78A") hx2 ("A76A" "A74A" "A72A" "A70A" "A6EA" "A6CA" "A6AA" "A68A" "A66A" "A64A" "A62A" "A60A" "A5EA" "A5CA" "A5AA" "A58A") hx2 ("A56A" "A54A" "A52A" "A50A" "A4EA" "A4CA" "A4AA" "A48A" "A46A" "A44A" "A42A" "A40A" "A3EA" "A3CA" "A3AA" "A38A") hx2 ("A36A" "A34A" "A32A" "A30A" "A2EA" "A2CA" "A2AA" "A28A" "A26A" "A24A" "A22A" "A20A" "A1EA" "A1CA" "A1AA" "A18A") hx2 ("A16A" "A14A" "A12A" "A10A" "A0EA" "A0CA" "A0AA" "A08A" "A06A" "A04A" "A02A" "A00A" "9FEA" "9FCA" "9FAA" "9F8A") hx2 ("9F6A" "9F4A" "9F2A" "9F0A" "9EEA" "9ECA" "9EAA" "9E8A" "9E6A" "9E4A" "9E2A" "9E0A" "9DEA" "9DCA" "9DAA" "9D8A") hx2 ("9D6A" "9D4A" "9D2A" "9D0A" "9CEA" "9CCA" "9CAA" "9C8A" "9C6A" "9C4A" "9C2A" "9C0A" "9BEA" "9BCA" "9BAA" "9B8A") hx2 ("9B6A" "9B4A" "9B2A" "9B0A" "9AEA" "9ACA" "9AAA" "9A8A" "9A6A" "9A4A" "9A2A" "9A0A" "99EA" "99CA" "99AA" "998A") hx2 ("996A" "994A" "992A" "990A" "98EA" "98CA" "98AA" "988A" "986A" "984A" "982A" "980A" "97EA" "97CA" "97AA" "978A") hx2 ("976A" "974A" "972A" "970A" "96EA" "96CA" "96AA" "968A" "966A" "964A" "962A" "960A" "95EA" "95CA" "95AA" "958A") hx2 ("956A" "954A" "952A" "950A" "94EA" "94CA" "94AA" "948A" "946A" "944A" "942A" "940A" "93EA" "93CA" "93AA" "938A") hx2 ("936A" "934A" "932A" "930A" "92EA" "92CA" "92AA" "928A" "926A" "924A" "922A" "920A" "91EA" "91CA" "91AA" "918A") hx2 ("916A" "914A" "912A" "910A" "90EA" "90CA" "90AA" "908A" "906A" "904A" "902A" "900A" "8FEA" "8FCA" "8FAA" "8F8A") hx2 ("8F6A" "8F4A" "8F2A" "8F0A" "8EEA" "8ECA" "8EAA" "8E8A" "8E6A" "8E4A" "8E2A" "8E0A" "8DEA" "8DCA" "8DAA" "8D8A") hx2 ("8D6A" "8D4A" "8D2A" "8D0A" "8CEA" "8CCA" "8CAA" "8C8A" "8C6A" "8C4A" "8C2A" "8C0A" "8BEA" "8BCA" "8BAA" "8B8A") hx2 ("8B6A" "8B4A" "8B2A" "8B0A" "8AEA" "8ACA" "8AAA" "8A8A" "8A6A" "8A4A" "8A2A" "8A0A" "89EA" "89CA" "89AA" "898A") hx2 ("896A" "894A" "892A" "890A" "88EA" "88CA" "88AA" "888A" "886A" "884A" "882A" "880A" "87EA" "87CA" "87AA" "878A") hx2 ("876A" "874A" "872A" "870A" "86EA" "86CA" "86AA" "868A" "866A" "864A" "862A" "860A" "85EA" "85CA" "85AA" "858A") hx2 ("856A" "854A" "852A" "850A" "84EA" "84CA" "84AA" "848A" "846A" "844A" "842A" "840A" "83EA" "83CA" "83AA" "838A") hx2 ("836A" "834A" "832A" "830A" "82EA" "82CA" "82AA" "828A" "826A" "824A" "822A" "820A" "81EA" "81CA" "81AA" "818A") hx2 ("816A" "814A" "812A" "810A" "80EA" "80CA" "80AA" "808A" "806A" "804A" "802A" "800A" "7FEA" "7FCA" "7FAA" "7F8A") hx2 ("7F6A" "7F4A" "7F2A" "7F0A" "7EEA" "7ECA" "7EAA" "7E8A" "7E6A" "7E4A" "7E2A" "7E0A" "7DEA" "7DCA" "7DAA" "7D8A") hx2 ("7D6A" "7D4A" "7D2A" "7D0A" "7CEA" "7CCA" "7CAA" "7C8A" "7C6A" "7C4A" "7C2A" "7C0A" "7BEA" "7BCA" "7BAA" "7B8A") hx2 ("7B6A" "7B4A" "7B2A" "7B0A" "7AEA" "7ACA" "7AAA" "7A8A" "7A6A" "7A4A" "7A2A" "7A0A" "79EA" "79CA" "79AA" "798A") hx2 ("796A" "794A" "792A" "790A" "78EA" "78CA" "78AA" "788A" "786A" "784A" "782A" "780A" "77EA" "77CA" "77AA" "778A") hx2 ("776A" "774A" "772A" "770A" "76EA" "76CA" "76AA" "768A" "766A" "764A" "762A" "760A" "75EA" "75CA" "75AA" "758A") hx2 ("756A" "754A" "752A" "750A" "74EA" "74CA" "74AA" "748A" "746A" "744A" "742A" "740A" "73EA" "73CA" "73AA" "738A") hx2 ("736A" "734A" "732A" "730A" "72EA" "72CA" "72AA" "728A" "726A" "724A" "722A" "720A" "71EA" "71CA" "71AA" "718A") hx2 ("716A" "714A" "712A" "710A" "70EA" "70CA" "70AA" "708A" "706A" "704A" "702A" "700A" "6FEA" "6FCA" "6FAA" "6F8A") hx2 ("6F6A" "6F4A" "6F2A" "6F0A" "6EEA" "6ECA" "6EAA" "6E8A" "6E6A" "6E4A" "6E2A" "6E0A" "6DEA" "6DCA" "6DAA" "6D8A") hx2 ("6D6A" "6D4A" "6D2A" "6D0A" "6CEA" "6CCA" "6CAA" "6C8A" "6C6A" "6C4A" "6C2A" "6C0A" "6BEA" "6BCA" "6BAA" "6B8A") hx2 ("6B6A" "6B4A" "6B2A" "6B0A" "6AEA" "6ACA" "6AAA" "6A8A" "6A6A" "6A4A" "6A2A" "6A0A" "69EA" "60F0" "6368" "6348") hx2 ("696A" "694A" "692A" "690A" "68EA" "68CA" "68AA" "688A" "686A" "684A" "682A" "680A" "67EA" "67CA" "67AA" "678A") hx2 ("676A" "674A" "672A" "670A" "66EA" "66CA" "66AA" "668A" "666A" "664A" "662A" "660A" "65EA" "65CA" "65AA" "658A") hx2 ("656A" "654A" "652A" "650A" "6B26" "6DE1" "6E9C" "5E48" "5E28" "5E08" "5DE8" "5DC8" "5DA8" "5D88" "5D68" "5D48") hx2 ("5D28" "5D08" "5CE8" "5CC8" "5CA8" "5C88" "5C68" "5C48" "5C28" "5C08" "5BE8" "5BC8" "5BA8" "5B88" "5B68" "5B48") hx2 ("5B28" "5B08" "5AE8" "5AC8" "5AA8" "5A88" "5A68" "5A48" "5A28" "5A08" "59E8" "59C8" "59A8" "5988" "5968" "5948") hx2 ("5928" "5908" "58E8" "58C8" "58A8" "5888" "5868" "5848" "5828" "5808" "57E8" "57C8" "57A8" "5788" "5768" "5748") hx2 ("5D6A" "5D4A" "5D2A" "5D0A" "5CEA" "5CCA" "5CAA" "5C8A" "5C6A" "5C4A" "5C2A" "5C0A" "5BEA" "5BCA" "5BAA" "5B8A") hx2 ("5B6A" "5B4A" "5B2A" "5B0A" "5AEA" "5ACA" "5AAA" "5A8A" "5A6A" "5A4A" "5A2A" "5A0A" "59EA" "59CA" "59AA" "598A") hx2 ("596A" "594A" "592A" "590A" "58EA" "58CA" "58AA" "588A" "586A" "584A" "582A" "580A" "57EA" "57CA" "57AA" "578A") hx2 ("576A" "574A" "572A" "570A" "56EA" "56CA" "56AA" "568A" "566A" "564A" "562A" "560A" "55EA" "55CA" "55AA" "558A") hx2 ("556A" "554A" "552A" "550A" "54EA" "54CA" "54AA" "548A" "546A" "544A" "542A" "540A" "53EA" "53CA" "53AA" "538A") hx2 ("536A" "534A" "532A" "530A" "52EA" "52CA" "52AA" "528A" "526A" "524A" "522A" "520A" "51EA" "51CA" "51AA" "518A") hx2 ("516A" "514A" "512A" "510A" "50EA" "50CA" "50AA" "508A" "506A" "504A" "502A" "500A" "4FEA" "4FCA" "4FAA" "4F8A") hx2 ("4F6A" "4F4A" "4F2A" "4F0A" "4EEA" "4ECA" "4EAA" "4E8A" "4E6A" "4E4A" "4E2A" "4E0A" "4DEA" "4DCA" "4DAA" "4D8A") hx2 ("4D6A" "4D4A" "4D2A" "4D0A" "4CEA" "4CCA" "4CAA" "4C8A" "4C6A" "4C4A" "4C2A" "4C0A" "4BEA" "4BCA" "4BAA" "4B8A") hx2 ("4B6A" "4B4A" "4B2A" "4B0A" "4AEA" "4ACA" "4AAA" "4A8A" "4A6A" "4A4A" "4A2A" "4A0A" "49EA" "49CA" "49AA" "498A") hx2 ("496A" "494A" "492A" "490A" "48EA" "48CA" "48AA" "488A" "486A" "484A" "482A" "480A" "47EA" "47CA" "47AA" "478A") hx2 ("476A" "474A" "472A" "470A" "46EA" "46CA" "46AA" "468A" "466A" "464A" "462A" "460A" "45EA" "45CA" "45AA" "458A") hx2 ("456A" "454A" "452A" "450A" "44EA" "44CA" "44AA" "448A" "446A" "444A" "442A" "440A" "43EA" "43CA" "43AA" "438A") hx2 ("436A" "434A" "432A" "430A" "42EA" "42CA" "42AA" "428A" "426A" "424A" "422A" "420A" "41EA" "41CA" "41AA" "418A") hx2 ("416A" "414A" "412A" "410A" "40EA" "40CA" "40AA" "408A" "406A" "404A" "402A" "400A" "3FEA" "3FCA" "3FAA" "3F8A") hx2 ("3F6A" "3F4A" "3F2A" "3F0A" "3EEA" "3ECA" "3EAA" "3E8A" "3E6A" "3E4A" "3E2A" "3E0A" "3DEA" "3DCA" "3DAA" "3D8A") hx2 ("3D6A" "3D4A" "3D2A" "3D0A" "3CEA" "3CCA" "3CAA" "3C8A" "3C6A" "3C4A" "3C2A" "3C0A" "3BEA" "3BCA" "3BAA" "3B8A") hx2 ("3B6A" "3B4A" "3B2A" "3B0A" "3AEA" "3ACA" "3AAA" "3A8A" "3A6A" "3A4A" "3A2A" "3A0A" "39EA" "39CA" "39AA" "398A") hx2 ("396A" "394A" "392A" "390A" "38EA" "38CA" "38AA" "388A" "386A" "384A" "382A" "380A" "37EA" "37CA" "37AA" "378A") hx2 ("376A" "374A" "372A" "370A" "36EA" "36CA" "36AA" "368A" "366A" "364A" "362A" "360A" "35EA" "35CA" "35AA" "358A") hx2 ("356A" "354A" "352A" "350A" "34EA" "34CA" "34AA" "348A" "346A" "344A" "342A" "340A" "33EA" "33CA" "33AA" "338A") hx2 ("336A" "334A" "332A" "330A" "32EA" "32CA" "32AA" "328A" "326A" "324A" "322A" "320A" "31EA" "28F2" "2B68" "2B48") hx2 ("3C2B" "3C0B" "3BEB" "3BCB" "3BAB" "3B8B" "3B6B" "3B4B" "3B2B" "3B0B" "3AEB" "3ACB" "3AAB" "3A8B" "3A6B" "3A4B") hx2 ("3A2B" "3A0B" "39EB" "39CB" "39AB" "398B" "396B" "394B" "392B" "390B" "38EB" "38CB" "38AB" "388B" "386B" "384B") hx2 ("382B" "380B" "37EB" "37CB" "37AB" "378B" "376B" "374B" "372B" "370B" "36EB" "36CB" "36AB" "368B" "366B" "364B") hx2 ("362B" "360B" "35EB" "35CB" "35AB" "358B" "356B" "354B" "352B" "350B" "34EB" "34CB" "34AB" "348B" "346B" "344B") hx2 ("344B" "342B" "340B" "33EB" "33CB" "33AB" "338B" "336B" "334B" "332B" "330B" "32EB" "32CB" "32AB" "328B" "326B") hx2 ("324B" "322B" "320B" "31EB" "31CB" "31AB" "318B" "316B" "314B" "312B" "310B" "30EB" "30CB" "30AB" "308B" "306B") hx2 ("304B" "302B" "300B" "2FEB" "2FCB" "2FAB" "2F8B" "2F6B" "2F4B" "2F2B" "2F0B" "2EEB" "2ECB" "2EAB" "2E8B" "2E6B") hx2 ("2E4B" "2E2B" "2E0B" "2DEB" "2DCB" "2DAB" "2D8B" "2D6B" "2D4B" "2D2B" "2D0B" "2CEB" "2CCB" "2CAB" "2C8B" "2C6B") hx2 ("2C4B" "2C2B" "2C0B" "2BEB" "2BCB" "2BAB" "2B8B" "2B6B" "2B4B" "2B2B" "2B0B" "2AEB" "2ACB" "2AAB" "2A8B" "2A6B") hx2 ("2A4B" "2A2B" "2A0B" "29EB" "29CB" "29AB" "298B" "296B" "294B" "292B" "290B" "28EB" "28CB" "28AB" "288B" "286B") hx2 ("284B" "282B" "280B" "27EB" "27CB" "27AB" "278B" "276B" "274B" "272B" "270B" "26EB" "26CB" "26AB" "268B" "266B") hx2 ("264B" "262B" "260B" "25EB" "25CB" "25AB" "258B" "256B" "254B" "252B" "250B" "24EB" "24CB" "24AB" "248B" "246B") hx2 ("244B" "242B" "240B" "23EB" "23CB" "23AB" "238B" "236B" "234B" "232B" "230B" "22EB" "22CB" "22AB" "228B" "226B") hx2 ("224B" "222B" "220B" "21EB" "21CB" "21AB" "218B" "216B" "214B" "212B" "210B" "20EB" "20CB" "20AB" "208B" "206B") hx2 ("204B" "202B" "200B" "1FEB" "1FCB" "1FAB" "1F8B" "1F6B" "1F4B" "1F2B" "1F0B" "1EEB" "1ECB" "1EAB" "1E8B" "1E6B") hx2 ("1E4B" "1E2B" "1E0B" "1DEB" "1DCB" "1DAB" "1D8B" "1D6B" "1D4B" "1D2B" "1D0B" "1CEB" "1CCB" "1CAB" "1C8B" "1C6B") hx2 ("1C4B" "1C2B" "1C0B" "1BEB" "1BCB" "1BAB" "1B8B" "1B6B" "106A" "104A" "102A" "100A" "FEA" "FCA" "FAA" "F8A") hx2 ("F6A" "668" "8E8" "8C8" "8A8" "888" "868" "848" "7D7" "194B" "7B6" "D1C" "CFC" "CB2" "CA9" "C9C") hx2 ("C7C" "C5C" "C3C" "C1C" "BFC" "BDC" "BBC" "B9C" "B7C" "B5E" "B2C" "B1C" "AB8" "ADC" "A9C" "2C2") hx2 ("528" "166B" "1667" "3FF" "9FC" "9DC" "9BC" "659" "BB8" "15A7" "FC6" "1C0" "1B1" "9CB" "82C" "1285") : CaseData hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082") hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3E80" "3E80" "3001" "3082" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "5B88" "5B88" "3E80" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "5198" "3E80" "3E80" "3E80" "3E80" "4606" "3E80" "3E80" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "3E80" "3E80") hx2 ("3E80" "3E80" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202") hx2 ("5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202" "5202") hx2 ("5202" "2E82" "3E80" "5198" "2A14" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4686" "4606" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "1A1B" "1A1B" "3E80" "3E80" "3E80" "3E80" "4584" "3E80" "3E80" "3E80" "298") hx2 ("3E80" "298" "6615" "6696" "298" "1A97" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("4584" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "4584") hx2 ("4584" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "4584") hx2 ("4584" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "2E82") hx2 ("7282" "2E82" "3E80" "2E82" "4902" "7481" "7481" "7481" "7481" "7383" "1A1B" "1A1B" "1A1B" "6D82" "6D82" "4902") hx2 ("4902" "3E80" "3E80" "2E82" "4902" "6E01" "6E01" "7501" "7501" "3E80" "1A1B" "1A1B" "1A1B" "1B02" "1B82" "1C02") hx2 ("1C82" "1D02" "1D82" "1E02" "1E82" "1F02" "1F82" "2002" "2082" "2102" "2182" "2202" "2282" "2302" "2382" "2402") hx2 ("2482" "2502" "2582" "2602" "2682" "2702" "2782" "455" "C99" "4D6" "C99" "F" "F" "F" "F" "F") hx2 ("10F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F") hx2 ("F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "8F" "10F" "8F" "18F" "10F") hx2 ("F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "F" "10F" "10F") hx2 ("10F" "8F" "20C" "298" "298" "318" "39A" "318" "298" "298" "455" "4D6" "298" "519" "598" "614") hx2 ("598" "698" "709" "789" "809" "889" "909" "989" "A09" "A89" "B09" "B89" "598" "298" "C59" "C99") hx2 ("C59" "298" "D01" "D81" "E01" "E81" "F01" "F81" "1001" "1081" "1101" "1181" "1201" "1281" "1301" "1381") hx2 ("1401" "1481" "1501" "1581" "1601" "1681" "1701" "1781" "1801" "1881" "1901" "1981" "455" "298" "4D6" "1A1B") hx2 ("1A97" "298" "298" "298" "C99" "455" "4D6" "3E80" "298" "298" "298" "298" "298" "298" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("282C" "298" "39A" "39A" "39A" "39A" "289C" "289C" "1A1B" "289C" "2902" "29DD" "C99" "2A14" "289C" "1A1B") hx2 ("2A9C" "519" "2B0B" "2B8B" "1A1B" "2C02" "289C" "298" "1A1B" "2C8B" "2902" "2D5E" "2D8B" "2D8B" "2D8B" "298") hx2 ("298" "519" "614" "C99" "C99" "C99" "3E80" "298" "39A" "318" "298" "3E80" "3E80" "3E80" "3E80" "5405") hx2 ("5405" "5405" "3E80" "5405" "3E80" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "4606" "3E80" "501C" "501C" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81") hx2 ("4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "4F81" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01") hx2 ("2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "C99") hx2 ("2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E82" "2E82" "2E82" "4902" "4902" "2E82" "2E82" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "2E82" "2E82" "2E82" "2E82" "2E82" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "5305" "4606" "5305" "5305" "3E80" "5305" "5305" "3E80" "5305" "5305" "5305" "5305") hx2 ("5305" "5305" "5305" "5305" "5305" "5305" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5398" "5405" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "5087" "5087" "4606" "5087" "5087" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "2D8B" "2D8B" "2D8B" "2D8B" "2D8B" "2D8B" "2D8B" "2D8B") hx2 ("2D8B" "2D8B" "2D8B" "2D8B" "840B" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "2E82" "3001") hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001") hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "4606") hx2 ("4606" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "1A1B") hx2 ("1A1B" "4701" "298" "4781" "4781" "4781" "3E80" "4801" "3E80" "4881" "4881" "4902" "2E01" "2E01" "2E01" "2E01") hx2 ("2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2F02" "2F02" "2F02" "2F02") hx2 ("2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02") hx2 ("2F02" "2F02" "2F02" "C99" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F82" "2F02" "2F02" "4A82" "2F02") hx2 ("2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "4B02" "4B82" "4B82" "3E80" "4C02" "4C82" "4D01" "4D01") hx2 ("4D01" "4D82" "4E02" "2902" "3E80" "3E80" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082") hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "2E82" "3B81" "3C03" "3C82" "3001" "3082" "3D81" "3E01" "3001" "3082") hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3101" "3182") hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "2902" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001") hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "4E82" "4F02" "3D02" "2902" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B10" "5B10" "5B10" "5B10" "5B10" "5B10" "7F0B" "3E80" "3E80") hx2 ("3E80" "7F8B" "800B" "808B" "810B" "818B" "820B" "519" "519" "C99" "455" "4D6" "2902" "3301" "3001" "3082") hx2 ("3001" "3082" "3381" "3001" "3082" "3401" "3401" "3001" "3082" "2902" "3481" "3501" "3581" "3001" "3082" "3401") hx2 ("3601" "3682" "3701" "3781" "3001" "3082" "2902" "2902" "3701" "3801" "2902" "3881" "3A85" "3A85" "3A85" "3A85") hx2 ("3B81" "3C03" "3C82" "3B81" "3C03" "3C82" "3B81" "3C03" "3C82" "3001" "3082" "3001" "3082" "3001" "3082" "3001") hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3D02" "3001" "3082" "501C" "4606" "4606" "4606") hx2 ("4606" "3E80" "5087" "5087" "3E80" "3E80" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082") hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3201" "3001") hx2 ("3082" "3001" "3082" "3001" "3082" "3282" "3001" "3082" "3001" "3082" "3001" "3082" "3901" "3001" "3082" "3901") hx2 ("2902" "2902" "3001" "3082" "3901" "3001" "3082" "3981" "3981" "3001" "3082" "3001" "3082" "3A01" "3001" "3082") hx2 ("2902" "3A85" "3001" "3082" "2902" "3B02" "4D01" "3001" "3082" "3001" "3082" "3E80" "3E80" "3001" "3082" "3E80") hx2 ("3E80" "3001" "3082" "3E80" "3E80" "3E80" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082") hx2 ("3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "598" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "5398" "3E80" "3E80" "3E80" "5398" "5398" "5398" "5398" "5398" "5398" "5398" "5398" "5398") hx2 ("5398" "5398" "5398" "5398" "5398" "3E80" "5B10" "5405" "4606" "5405" "5405" "5405" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "3E80" "3E80" "5B10" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01") hx2 ("4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01") hx2 ("4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "4D01" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80") hx2 ("3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "2902" "2902" "2902" "3F02" "3F82" "2902" "4002" "4002" "2902" "4082") hx2 ("2902" "4102" "2902" "2902" "2902" "2902" "4002" "2902" "2902" "4182" "2902" "2902" "2902" "2902" "4202" "4282") hx2 ("2902" "2902" "2902" "2902" "2902" "4282" "2902" "2902" "4302" "2902" "2902" "4382" "2902" "2902" "2902" "2902") hx2 ("2902" "2902" "2902" "2902" "2902" "2902" "4402" "2902" "2902" "4402" "2902" "2902" "2902" "2902" "4402" "2902") hx2 ("4482" "4482" "2902" "2902" "2902" "2902" "2902" "2902" "4502" "2902" "2902" "2902" "2902" "2902" "2902" "2902") hx2 ("2902" "2902" "2902" "2902" "2902" "2902" "2902" "3E80" "3E80" "4584" "4584" "4584" "4584" "4584" "4584" "4584") hx2 ("4584" "4584" "1A1B" "1A1B" "4584" "4584" "4584" "4584" "4584" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B" "1A1B") hx2 ("1A1B" "1A1B" "4584" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101") hx2 ("5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "5101" "3E80" "3E80" "4584" "5198" "5198") hx2 ("5198" "5198" "5198" "5198" "2E01" "2E01" "3E80" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01" "2E01") hx2 ("4982" "4A02" "4A02" "4A02" "4902" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02" "2F02") hx2 ("2F02" "2F02" "2F02" "2F02" "2F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02" "4F02") hx2 ("4F02" "4F02" "4F02" "4F02" "4F02" "4606" "4606" "4606" "4606" "4606" "5198" "4606" "4606" "3A85" "3A85" "3A85") hx2 ("3A85" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "3E80" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "4606" "3E80" "4606" "4606" "4606" "5298" "4606" "4606" "5298" "4606" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5305" "5305" "5305" "5305" "5305" "5305" "5305") hx2 ("5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "3E80" "3E80" "3E80" "3E80" "3E80" "5305" "5305") hx2 ("5305" "5298" "5298" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5C89" "5D09") hx2 ("5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "640B" "648B" "650B" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85") hx2 ("3E80" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606") hx2 ("5B88" "5B88" "5B88" "5B88" "3E80" "4606" "4606" "4606" "3E80" "4606" "4606" "4606" "4606" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606") hx2 ("5B88" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3E80") hx2 ("3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80") hx2 ("3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "5B88" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "5C09" "5C89" "5D09") hx2 ("5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "501C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5509" "5589" "5609" "5689" "5709" "5789" "5809" "5889" "5909") hx2 ("5989" "318" "5A18" "5A18" "5398" "3E80" "3E80" "4606" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "3E80" "3E80" "5405" "5405" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "5405" "5405" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405") hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "6615" "6696" "5484" "5405") hx2 ("5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "5405" "4606" "4606" "4606" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B88" "5B88" "5198" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3E80" "3A85" "3E80" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "5198" "5198" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606" "5484" "5484") hx2 ("4606" "4606" "289C" "4606" "4606" "4606" "4606" "3E80" "3E80" "709" "789" "809" "889" "909" "989" "A09") hx2 ("A89" "B09" "B89" "5405" "5405" "5405" "5A9C" "5A9C" "3E80" "3A85" "3A85" "3A85" "3E80" "3A85" "3E80" "3A85") hx2 ("3E80" "3E80" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "4606" "3A85" "3A85" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "3E80" "4606" "4606" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "4606" "3A85" "5B88" "5B88") hx2 ("5B88" "5B88" "5B88" "3E80" "4606" "5B88" "5B88" "3E80" "5B88" "5B88" "4606" "4606" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "5B88" "5B88" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3E80" "5198" "5198") hx2 ("5198" "5198" "5198" "5198" "5198" "5198" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "640B") hx2 ("670B" "678B" "680B" "688B" "690B" "698B" "6A0B" "6A8B" "648B" "6B0B" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85") hx2 ("3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "4606" "3A85" "5B88" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "5B88" "5B88" "5B88" "5B88" "4606" "3E80" "3E80" "3A85" "4606" "4606" "4606" "4606") hx2 ("3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "4606") hx2 ("3E80" "5B88" "5B88" "5B88" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85") hx2 ("3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3E80" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3E80" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "4606" "3A85" "3A85" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "39A" "39A" "39A" "39A" "39A" "39A" "39A") hx2 ("39A" "39A" "39A" "39A" "39A" "39A" "39A" "39A" "39A" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "4606" "4606" "5198" "5198" "5C09") hx2 ("5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "5198" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "298" "298" "318" "39A" "318" "298" "298") hx2 ("6615" "6696" "298" "519" "598" "614" "598" "698" "709" "789" "809" "889" "909" "989" "A09" "A89") hx2 ("B09" "B89" "598" "298" "C99" "C99" "C99" "298" "298" "298" "298" "298" "298" "2A14" "298" "298") hx2 ("298" "298" "5B10" "5B10" "5B10" "5B10" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009") hx2 ("6089" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3E80" "3E80" "3E80" "3E80" "5B88" "4606" "4606" "4606" "4606" "3E80" "3E80" "5B88" "5B88" "3E80" "3E80") hx2 ("5B88" "5B88" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B88" "3E80" "3E80" "3E80") hx2 ("3E80" "3A85" "3A85" "3E80" "3A85" "3E80" "3E80" "3A85" "3A85" "3E80" "3A85" "3E80" "3E80" "3A85" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3E80" "3A85" "3A85") hx2 ("3E80" "3A85" "3A85" "3E80" "3E80" "4606" "3E80" "5B88" "5B88" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "4606") hx2 ("4606" "3E80" "3E80" "4606" "4606" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3E80" "3A85" "3A85" "4606" "4606" "3E80" "3E80" "5C09" "5C89") hx2 ("5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "3A85" "3A85" "39A" "39A" "610B" "618B" "620B" "628B") hx2 ("630B" "638B" "501C" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3E80" "3E80" "4606" "3A85" "5B88" "5B88" "4606" "4606" "4606" "4606" "4606" "3E80" "4606" "4606") hx2 ("5B88" "3E80" "5B88" "5B88" "4606" "3E80" "3E80" "3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009") hx2 ("6089" "630B" "630B" "630B" "630B" "630B" "630B" "630B" "630B" "630B" "630B" "501C" "4606" "501C" "4606" "501C") hx2 ("4606" "6615" "6696" "6615" "6696" "5B88" "5B88" "4606" "4606" "4606" "3E80" "3E80" "3E80" "5B88" "5B88" "3E80") hx2 ("3E80" "5B88" "5B88" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "5B88" "3E80" "3E80") hx2 ("3E80" "3E80" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3E80" "5B88" "4606") hx2 ("4606" "4606" "4606" "5B88" "4606" "3E80" "3E80" "3E80" "4606" "4606" "5B88" "4606" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "5B88" "5B88" "5B88" "4606" "4606" "4606" "4606" "4606" "4606" "4606") hx2 ("5B88" "5B88" "3E80" "3E80" "3E80" "5B88" "5B88" "5B88" "3E80" "5B88" "5B88" "5B88" "4606" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B88" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3E80" "4584" "3E80" "4606" "4606" "4606" "4606" "4606" "4606" "3E80" "3E80" "5C09") hx2 ("5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "3E80" "3E80" "3A85" "3A85" "3E80" "3E80" "3E80") hx2 ("3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "4606" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "5087" "5087" "5087" "5B88" "4606" "4606" "4606" "3E80") hx2 ("3E80" "5B88" "5B88" "5B88" "3E80" "5B88" "5B88" "5B88" "4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "5B88" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "4606" "3E80" "3E80" "3E80" "3E80" "5B88" "5B88" "5B88" "4606" "4606" "4606") hx2 ("3E80" "4606" "3E80" "5B88" "5B88" "5B88" "5B88" "5B88" "5B88" "5B88" "5B88" "4606" "5B88" "5B88" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "4606" "5198" "5198" "5198" "5198" "5198" "5198" "5198") hx2 ("39A" "5198" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "4584" "4606" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "4606" "5198" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009" "6089" "5198") hx2 ("5198" "3E80" "3E80" "3E80" "3E80" "3A85" "501C" "501C" "501C" "5198" "5198" "5198" "5198" "5198" "5198" "5198") hx2 ("5198" "65B8" "5198" "5198" "5198" "5198" "5198" "5198" "501C" "501C" "501C" "501C" "501C" "4606" "4606" "501C") hx2 ("501C" "501C" "501C" "501C" "501C" "4606" "501C" "501C" "501C" "501C" "501C" "501C" "3E80" "3E80" "501C" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "1A97" "4584" "4584" "4584" "3E80" "5C09" "5C89" "5D09" "5D89" "5E09" "5E89" "5F09" "5F89" "6009") hx2 ("6089" "5198" "5198" "5198" "5198" "5198" "5198" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "5B88" "5B88" "4606") hx2 ("4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "20C" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "6615" "6696" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "5198" "5198" "5198" "6B8B" "6C0B" "6C8B" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("4606" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001") hx2 ("3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "3001" "3082" "2E82" "2E82" "2E82") hx2 ("2E82" "2E82" "6D02" "3E80" "3E80" "3E80" "3E80" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6E01") hx2 ("6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6E01") hx2 ("6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "3E80" "3E80" "6E01") hx2 ("6E01" "6E01" "6E01" "6E01" "6E01" "3E80" "3E80" "2E82" "6D82" "4902" "6D82" "4902" "6D82" "4902" "6D82" "3E80") hx2 ("6E01" "3E80" "6E01" "3E80" "6E01" "3E80" "6E01" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6D82" "6E01") hx2 ("6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6E01" "6E82" "6E82" "6F02" "6F02" "6F02" "6F02" "6F82" "6F82" "7002") hx2 ("7002" "7082" "7082" "7102" "7102" "3E80" "3E80" "7182" "7182" "7182" "7182" "7182" "7182" "7182" "7182" "7203") hx2 ("7203" "7203" "7203" "7203" "7203" "7203" "7203" "7182" "7182" "7182" "7182" "7182" "7182" "7182" "7182" "7203") hx2 ("7203" "7203" "7203" "7203" "7203" "7203" "7203" "6D82" "6D82" "2E82" "7282" "2E82" "3E80" "2E82" "4902" "6E01") hx2 ("6E01" "7301" "7301" "7383" "1A1B" "7402" "1A1B" "1B02" "1B82" "1C02" "1C82" "1D02" "1D82" "1E02" "1E82" "1F02") hx2 ("1F82" "2002" "2082" "2102" "2182" "2202" "2282" "2302" "2382" "2402" "2482" "2502" "2582" "2602" "2682" "2702") hx2 ("2782" "6615" "C99" "6696" "C99" "3E80" "6D82" "6D82" "4902" "4902" "2E82" "7582" "2E82" "4902" "6E01" "6E01") hx2 ("7601" "7601" "7681" "1A1B" "1A1B" "1A1B" "3E80" "3E80" "2E82" "7282" "2E82" "3E80" "2E82" "4902" "7701" "7701") hx2 ("7781" "7781" "7383" "1A1B" "1A1B" "3E80" "20C" "20C" "20C" "20C" "20C" "20C" "20C" "782C" "20C" "20C") hx2 ("20C" "788C" "5B10" "5B10" "7910" "7990" "2A14" "7A34" "2A14" "2A14" "2A14" "2A14" "298" "298" "7A9D" "7B1E") hx2 ("6615" "7A9D" "7A9D" "7B1E" "6615" "7A9D" "298" "298" "298" "298" "298" "298" "298" "298" "7B8D" "7C0E") hx2 ("7C90" "7D10" "7D90" "7E10" "7E90" "782C" "318" "318" "318" "318" "318" "298" "298" "298" "298" "29DD") hx2 ("2D5E" "298" "298" "298" "298" "1A97" "7F0B" "2C8B" "2B0B" "2B8B" "7F8B" "800B" "808B" "810B" "818B" "820B") hx2 ("519" "519" "C99" "455" "4D6" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3E80" "3E80" "3E80" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "4D01" "289C" "289C" "289C" "289C" "4D01" "289C" "289C" "2902" "4D01") hx2 ("4D01" "4D01" "2902" "2902" "4D01" "4D01" "4D01" "2902" "289C" "4D01" "289C" "289C" "289C" "4D01" "4D01" "4D01") hx2 ("4D01" "4D01" "289C" "289C" "A20A" "A28A" "A30A" "A38A" "A40A" "A48A" "A50A" "A58A" "A60A" "4606" "4606" "4606") hx2 ("4606" "4606" "4606" "2A14" "4584" "4584" "4584" "4584" "4584" "289C" "289C" "A68A" "A70A" "A78A" "3E80" "3E80") hx2 ("3E80" "289C" "289C" "289C" "289C" "3E80" "289C" "289C" "289C" "289C" "3E80" "3E80" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "C99" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "C99" "C99" "289C" "289C" "C99" "289C" "C99" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "C99" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "948A" "950A" "958A" "960A" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "C99" "C99" "C99" "C99" "C99" "289C" "289C") hx2 ("289C" "289C" "289C" "C99" "C99" "289C" "289C" "289C" "289C" "4D01" "289C" "8281" "289C" "4D01" "289C" "8301") hx2 ("8381" "4D01" "4D01" "2A9C" "2902" "4D01" "4D01" "289C" "4D01" "2902" "3A85" "3A85" "3A85" "3A85" "2902" "289C") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "848A" "850A" "858A" "860A" "868A" "870A" "878A" "880A" "888A" "890A" "898A") hx2 ("8A0A" "8A8A" "8B0A" "8B8A" "8C0A" "8C8A" "8D0A" "8D8A" "8E0A" "8E8A" "8F0A" "8F8A" "900A" "908A" "910A" "918A") hx2 ("920A" "928A" "930A" "938A" "940A" "C99" "C99" "C59" "C59" "C99" "C99" "C59" "C59" "C59" "C59" "C59") hx2 ("C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C99" "C99") hx2 ("C99" "C99" "C99" "C59" "C59" "C59" "C59" "C99" "C99" "C99" "C99" "C99" "C99" "C99" "C99" "C99") hx2 ("C59" "C59" "C59" "C59" "C59" "C99" "C99" "C59" "C59" "C99" "C99" "C99" "C99" "C59" "C59" "C59") hx2 ("C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C99" "C99" "C59" "C59" "C59" "C59") hx2 ("C99" "C99" "C99" "C99" "C99" "C59" "C99" "C99" "C99" "C99" "C99" "C99" "C99" "289C" "289C" "C99") hx2 ("289C" "289C" "C99" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "C99" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "3E80" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "C99" "C59" "C59") hx2 ("C59" "C59" "C99" "C99" "C99" "C59" "C59" "C59" "C59" "C59" "C59" "C99" "C99" "C99" "C59" "519") hx2 ("519" "C99" "C59" "C59" "C99" "C99" "C99" "C59" "C59" "C59" "C59" "C99" "C59" "C99" "C59" "C99") hx2 ("C99" "C99" "C99" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C99" "C99" "C99" "C99") hx2 ("C99" "C59" "C99" "C59" "C59" "C59" "C59" "C59" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "455") hx2 ("4D6" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "501C" "501C" "501C" "501C") hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") hx2 ("501C" "501C" "501C" "3E80" "3E80" "3E80" "3E80" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "9C1C" "9C1C" "9C1C") hx2 ("9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C1C" "9C9C" "9C9C" "9C9C") hx2 ("9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "9C9C" "7F0B" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "C59" "C99" "C59" "C99" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C99") hx2 ("C99" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59" "C59") hx2 ("C59" "C59" "C59" "C99" "C99" "C59" "C59" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "39A" "39A" "C99" "1A1B" "289C" "39A" "39A" "3E80" "289C" "C99" "C99") hx2 ("C99" "C99" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "5B10" "5B10") hx2 ("5B10" "289C" "289C" "3E80" "3E80" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "3E80" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "3E80" "289C" "3E80" "289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "289C" "3E80") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "840B" "9D0B" "9D8B" "9E0B" "9E8B" "9F0B" "9F8B" "A00B" "A08B" "A10B" "840B") hx2 ("9D0B" "9D8B" "9E0B" "9E8B" "9F0B" "9F8B" "A00B" "A08B" "A10B" "289C" "3E80" "3E80" "3E80" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "C59" "C59" "C59" "C59" "289C" "289C" "289C" "289C" "289C" "289C" "289C") hx2 ("289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "289C" "501C" "289C") hx2 ("289C" "289C" "289C" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "630B" "630B" "630B" "630B" "630B" "630B" "630B") hx2 ("630B" "630B" "630B" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") hx2 ("501C" "501C" "501C" "3E80" "3E80" "3E80" "501C" "610B" "618B" "620B" "628B" "A80B" "A88B" "A90B" "A98B" "AA0B") hx2 ("640B" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C") hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "289C" "3E80" "289C" "289C") hx2 ("289C" "3E80" "289C" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "2C8B" "2B0B" "2B8B" "7F8B") hx2 ("800B" "808B" "810B" "818B" "820B" "968B" "970B" "978B" "980B" "988B" "990B" "998B" "9A0B" "9A8B" "9B0B" "9B8B") hx2 ("2C8B" "2B0B" "2B8B" "7F8B" "800B" "808B" "810B" "818B" "820B" "968B" "970B" "978B" "980B" "988B" "990B" "998B") hx2 ("9A0B" "9A8B" "9B0B" "9B8B" "501C" "501C" "501C" "501C" "20C" "298" "298" "298" "289C" "4584" "3A85" "A18A") hx2 ("455" "4D6" "455" "4D6" "455" "4D6" "455" "4D6" "455" "4D6" "289C" "289C" "455" "4D6" "455" "4D6") hx2 ("455" "4D6" "455" "4D6" "2A14" "6615" "6696" "6696" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "3E80" "3E80") hx2 ("3E80" "4606" "4606" "1A1B" "1A1B" "4584" "4584" "3E80" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85") hx2 ("3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3A85" "3E80" "501C" "501C" "630B" "630B" "630B" "630B" "501C" "501C") hx2 ("501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "501C" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "AA93" "AA93" "AA93" "AA93" "AA93") hx2 ("AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93") hx2 ("AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AA93" "AB12" "AB12" "AB12" "AB12" "AB12") hx2 ("AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12") hx2 ("AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "AB12" "5305" "5305" "5305" "5305" "5305") hx2 ("5305" "5305" "5305" "5305" "519" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305" "5305") hx2 ("5305" "5305" "3E80" "5305" "5305" "5305" "5305" "5305" "3E80" "5305" "3E80" "4606" "4606" "4606" "4606" "3E80") hx2 ("3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "3E80" "298" "2A14" "2A14" "1A97" "1A97") hx2 ("6615" "6696" "6615" "6696" "6615" "6696" "6615" "6696" "6615" "6696" "6615" "6696" "3E80" "3E80" "3E80" "3E80") hx2 ("298" "298" "298" "298" "1A97" "1A97" "1A97" "598" "298" "598" "3E80" "298" "598" "298" "298" "2A14") hx2 ("6615" "6696" "6615" "6696" "6615" "6696" "318" "298" "D01" "D81" "E01" "E81" "F01" "F81" "1001" "1081") hx2 ("1101" "1181" "1201" "1281" "1301" "1381" "1401" "1481" "1501" "1581" "1601" "1681" "1701" "1781" "1801" "1881") hx2 ("1901" "1981" "6615" "298" "6696" "1A1B" "1A97") : CaseUpper hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0") hx2 ("FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0" "FFE0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "2E7" "0" "0" "0" "0" "0" "FFE0" "79") hx2 ("0" "FFFF" "0" "FF18" "0" "FED4" "0" "0" "0" "0" "0" "0" "0" "61" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "38" "0" "FFFF" "FFFE" "FFB1" "0" "0" "0" "FF2E" "FF32") hx2 ("FF33" "FF36" "FF35" "FF31" "FF2F" "FF2D" "FF2B" "FF2A" "FF26" "FF27" "FF25" "0" "0" "54" "0" "0") hx2 ("0" "0" "0" "FFDA" "FFDB" "FFE1" "FFC0" "FFC1" "FFC2" "FFC7" "0" "FFD1" "FFCA" "FFAA" "FFB0" "0") hx2 ("0" "0" "0" "0" "FFD0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "FFC5" "8" "0" "4A" "56" "64") hx2 ("80" "70" "7E" "8" "0" "9" "0" "0" "E3DB" "0" "0" "7" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0") hx2 ("FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "FFF0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "FFE6" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0") : CaseLower hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "20" "20" "20" "20" "20" "20") hx2 ("20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20" "20") hx2 ("20" "20" "20" "20" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "20" "0" "0" "0") hx2 ("1" "0" "FF39" "0" "FF87" "0" "D2" "CE" "CD" "4F" "CA" "CB" "CF" "0" "D3" "D1") hx2 ("D5" "D6" "DA" "D9" "DB" "0" "0" "2" "1" "0" "0" "FF9F" "FFC8" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "26" "25") hx2 ("40" "3F" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "50") hx2 ("0" "0" "30" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "FFF8" "0" "0" "0") hx2 ("0" "0" "0" "0" "FFF8" "0" "FFB6" "FFF7" "0" "FFAA" "FF9C" "0" "FF90" "FFF9" "FF80" "FF82") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "E2A3" "DF41" "DFBA" "0" "10" "10" "10" "10" "10" "10" "10") hx2 ("10" "10" "10" "10" "10" "10" "10" "10" "10" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "1A" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0" "0") hx2 ("0" "0" "0" "0" "0" "0" "0") # Bytes :: Tio byte 0 # Terminal I/O : Repl byte 0 # REPL flag : PRepl byte 0 # Parent REPL : Jam byte 0 # Error jam : InBye byte 0 # Exit status : Sync byte 0 # Family IPC synchronization : Month bytes (31 31 28 31 30 31 30 31 31 30 31 30 31) # Strings :: _r_ asciz "r" :: _w_ asciz "w" :: _a_ asciz "a" :: _ap_ asciz "a+" :: _dot_ asciz "." ### System messages ### # main.l : Giveup asciz "%d %s\\n" : ExecErr asciz "%s: Can't exec\\n" : AllocErr asciz "No memory" : PidSigMsg asciz "%d SIG-%d\\n" : QuitMsg asciz "%s" : CbErr asciz "Too many callbacks" # flow.l : HashBlank asciz "# " : Redefined asciz " redefined\\n" : SuperErr asciz "Bad super" : ExtraErr asciz "Bad extra" : ThrowErr asciz "Tag not found" : Trc1 asciz " :" : Trc2 asciz " = " # io.l : SetFD asciz "SETFD %s" : Delim ascii " \\t\\n\\r\\\"'(),[]`~{}" : DelimEnd : Arrow asciz "-> " # db.l : RolbLog asciz "Last transaction not completed: Rollback\n" : IgnLog asciz "Discarding incomplete transaction.\n" : CircFree asciz "Circular free list" : BadChain asciz "Bad chain" : BadCount asciz "Bad count" # err.l : ErrTok asciz "!? " : Dashes asciz " -- " : ProtErr asciz "Protected symbol" : SymNsErr asciz "Bad symbol namespace" : StkErr asciz "Stack overflow" : ArgErr asciz "Bad argument" : NumErr asciz "Number expected" : CntErr asciz "Small number expected" : SymErr asciz "Symbol expected" : ExtErr asciz "External symbol expected" : PairErr asciz "Cons pair expected" : AtomErr asciz "Atom expected" : LstErr asciz "List expected" : VarErr asciz "Variable expected" : DivErr asciz "Div/0" : RenErr asciz "Can't rename" : MakeErr asciz "Not making" : ReentErr asciz "Reentrant coroutine" : YieldErr asciz "No coroutine" : MsgErr asciz "Bad message" : BrkErr asciz "No Break" : OpenErr asciz "Open error: %s" : CloseErr asciz "Close error: %s" : PipeErr asciz "Pipe error: %s" : ForkErr asciz "Can't fork" : WaitPidErr asciz "wait pid" : BadFdErr asciz "Bad FD" : NoFdErr asciz "No current fd" : EofErr asciz "EOF Overrun" : SuparErr asciz "Super parentheses mismatch" : BadInput asciz "Bad input '%c'" : BadDot asciz "Bad dotted pair" : SelectErr asciz "Select error: %s" : WrBytesErr asciz "bytes write: %s" : WrChildErr asciz "child write: %s" : WrSyncErr asciz "sync write: %s" : WrJnlErr asciz "Journal write: %s" : WrLogErr asciz "Log write: %s" : TruncErr asciz "Log truncate error: %s" : DbSyncErr asciz "DB fsync error: %s" : TrSyncErr asciz "Transaction fsync error: %s" : LockErr asciz "File lock: %s" : DbfErr asciz "Bad DB file" : JnlErr asciz "Bad Journal" : IdErr asciz "Bad ID" : DbRdErr asciz "DB read: %s" : DbWrErr asciz "DB write: %s" : DbSizErr asciz "DB Oversize" : TellErr asciz "Tell PIPE_BUF" : IpSocketErr asciz "IP socket error: %s" : IpGetsocknameErr asciz "IP getsockname error: %s" : IpV6onlyErr asciz "IP IPV6_V6ONLY error: %s" : IpReuseaddrErr asciz "IP SO_REUSEADDR error: %s" : IpBindErr asciz "IP bind error: %s" : IpListenErr asciz "IP listen error: %s" : UdpOvflErr asciz "UDP overflow" : UndefErr asciz "Undefined" : DlErr asciz "[DLL] %s" # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/ht.l0000644000000000000000000004031112265263724014700 0ustar rootroot# 13mar13abu # (c) Software Lab. Alexander Burger (data 'HtData) initData ### Hypertext I/O functions ### : HtLt asciz "<" : HtGt asciz ">" : HtAmp asciz "&" : HtQuot asciz """ : HtNbsp asciz " " : HtEsc ascii " \\\"#%&:;<=>?_" (equ HTESC 12) (code 'HtCode) initCode # (ht:Prin 'sym ..) -> sym (code 'Prin 2) push X push Y push Z ld X (E CDR) # Args do ld E (X) # Eval next eval num E # Number? jnz 20 # Yes atom E # Pair? jz 20 # Yes sym (E TAIL) # External symbol? if nz # Yes 20 call prinE_E # Plain print else push E # Save return value call bufStringE_SZ # Write to stack buffer ld Y S # Point to string do nul (Y) # Null byte? while nz # No ld B (Y) # Next byte cmp B (char "<") # Escape special characters if eq ld C HtLt # "<" call outStringC else cmp B (char ">") if eq ld C HtGt # ">" call outStringC else cmp B (char "&") if eq ld C HtAmp # "&" call outStringC else cmp B (char "\"") if eq ld C HtQuot # """ call outStringC else cmp B (hex "FF") if eq ld B (hex "EF") call (PutB) ld B (hex "BF") call (PutB) ld B (hex "BF") call (PutB) else ld C A # Save char call (PutB) # Output it test C (hex "80") # Double byte? if nz # Yes inc Y # Next ld B (Y) # Output second byte call (PutB) test C (hex "20") # Triple byte? if nz # Yes inc Y # Next ld B (Y) # Output third byte call (PutB) end end end end end end end inc Y # Increment string pointer loop ld S Z # Drop buffer pop E end ld X (X CDR) # X on rest atom X # More? until nz # No pop Z pop Y pop X ret (code 'putHexB 0) # E ld E A # Save B ld B (char "%") # Prefix with "%" call (PutB) ld A E # Get B shr B 4 # Get upper nibble and B 15 cmp B 9 # Letter? if gt # Yes add B 7 end add B (char "0") call (PutB) # Output upper nibble ld A E # Get B again and B 15 # Get lower nibble cmp B 9 # Letter? if gt # Yes add B 7 end add B (char "0") jmp (PutB) # Output lower nibble (code 'htFmtE 0) cmp E Nil # NIL? if ne # No num E # Number? if nz # Yes ld B (char "+") # Prefix with "+" call (PutB) jmp prinE # and print it end push X atom E # List? if z # Yes ld X E do ld B (char "_") # Prefix with "_" call (PutB) ld E (X) # Print next item call htFmtE ld X (X CDR) # End of list? atom X until nz # Yes else # Symbol ld X (E TAIL) call nameX_X # Get name cmp X ZERO # Any? if ne # Yes sym (E TAIL) # External symbol? if nz # Yes ld B (char "-") # Prefix with "-" call (PutB) call prExtNmX # Print external else push Y ld Y ((EnvIntern)) call isInternEXY_F # Internal symbol? ld C 0 if eq # Yes ld B (char "$") # Prefix with "$" call (PutB) else call symByteCX_FACX # Get first byte cmp B (char "$") # Dollar, plus or minus? jeq 40 cmp B (char "+") jeq 40 cmp B (char "-") jne 50 40 call putHexB # Encode hexadecimal end do call symByteCX_FACX # Next byte while nz 50 memb HtEsc HTESC # Escape? if eq # Yes call putHexB # Encode hexadecimal else ld E A # Save char call (PutB) # Output it test E (hex "80") # Double byte? if nz # Yes call symByteCX_FACX # Next byte call (PutB) # Output second byte test E (hex "20") # Triple byte? if nz # Yes call symByteCX_FACX # Next byte call (PutB) # Output third byte end end end loop pop Y end end end pop X end ret # (ht:Fmt 'any ..) -> sym (code 'Fmt 2) push X push Y push Z ld X (E CDR) # X on args link do ld E (X) eval+ # Eval next arg push E ld X (X CDR) atom X # More args? until nz # No lea Y (L -I) # Y on first arg ld Z S # Z on last arg link call begString # Start string ld E (Y) call htFmtE # Format first arg do cmp Y Z # More args? while ne # Yes ld B (char "&") call (PutB) sub Y I # Next arg ld E (Y) call htFmtE # Format it loop call endString_E # Retrieve result drop pop Z pop Y pop X ret (code 'getHexX_A 0) ld A ((X) TAIL) # Get first hex digit call firstByteA_B sub B (char "0") # Convert cmp B 9 if gt and B (hex "DF") sub B 7 end ld X (X CDR) # Next symbol ret (code 'getUnicodeX_FAX 0) ld E X # Save X ld C 0 # Init unicode value do ld X (X CDR) ld A ((X) TAIL) # Get next character symbol call firstByteA_B cmp B (char "0") # Digit? while ge cmp B (char "9") while le # Yes sub B (char "0") # Convert push A # Save digit ld A C # Get accu mul 10 # Build decimal number pop C # Get digit add C A # New unicode value loop cmp B (char ";") # Terminator? if eq # Yes ld X (X CDR) # Skip ";" ld A C # Get value null A # Any? jnz Ret # Yes end ld X E # Restore X setz # 'z' ret (code 'headCX_FX 0) # E ld E X # Save X do inc C # Point to next char nul (C) # Any? while nz # Yes ld A ((X) TAIL) # Get next character symbol call firstByteA_B cmp B (C) # Matched? while eq # Yes ld X (X CDR) loop ldnz X E # Restore X when no match ret # 'z' if match # (ht:Pack 'lst) -> sym (code 'Pack 2) push X ld E ((E CDR)) # Eval arg eval link push E # Save link ld X E # List in X call begString # Start string do atom X # More items? while z # Yes ld E (X) # Get next character symbol ld A (E TAIL) call firstByteA_B cmp B (char "%") # Hex-escaped? if eq # Yes ld X (X CDR) # Skip "%" call getHexX_A # Get upper nibble shl A 4 ld C A # into C call getHexX_A # Get lower nibble or A C # Combine call (PutB) # Output else ld X (X CDR) # Next symbol cmp B (char "&") # Ampersand? if ne # No call outNameE # Normal output else ld C HtLt # "<" call headCX_FX if eq ld B (char "<") call (PutB) else ld C HtGt # ">" call headCX_FX if eq ld B (char ">") call (PutB) else ld C HtAmp # "&" call headCX_FX if eq ld B (char "&") call (PutB) else ld C HtQuot # """ call headCX_FX if eq ld B (char "\"") call (PutB) else ld C HtNbsp # " " call headCX_FX if eq ld B (char " ") call (PutB) else ld A ((X) TAIL) # Get next byte call firstByteA_B cmp B (char "#") # Hash? jne 40 # No call getUnicodeX_FAX # Unicode? if nz # Yes call mkCharA_A # Make symbol ld E A call outNameE # Output unicode char else 40 ld B (char "&") # Else ouput an ampersand call (PutB) end end end end end end end end loop call endString_E # Retrieve result drop pop X ret ### Read content length bytes ### # (ht:Read 'cnt) -> lst (code 'Read 2) push X ld X E ld E ((E CDR)) # E on arg call evCntEX_FE # Eval 'cnt' if nsz # > 0 ld A (Chr) # Look ahead char? null A if z # No call (Get_A) # Get next char end null A # EOF? if ns # No call getChar_A # Read first char cmp A 128 # Double byte? if ge # Yes dec E # Decrement count cmp A 2048 # Triple byte? if ge # Yes dec E # Decrement count end end dec E # Less than zero? if ns # No call mkCharA_A # First character call consA_X # Build first cell ld (X) A ld (X CDR) Nil link push X # Result link do null E # Count? if z # No ld E (L I) # Return result break T end call (Get_A) # Get next char null A # EOF? if s # Yes ld E Nil # Return NIL break T end call getChar_A cmp A 128 # Double byte? if ge # Yes dec E # Decrement count cmp A 2048 # Triple byte? if ge # Yes dec E # Decrement count end end dec E # Less than zero? if s # Yes ld E Nil # Return NIL break T end call mkCharA_A # Build next character call consA_C # And next cell ld (C) A ld (C CDR) Nil ld (X CDR) C # Append to result ld X C loop ld (Chr) 0 # Clear look ahead char drop pop X ret end end end ld E Nil # Return NIL pop X ret ### Chunked Encoding ### (equ CHUNK 4000) (data 'Chunk 0) word 0 # Chunk size count word 0 # Saved Get_A function word 0 # Saved PutB function skip CHUNK # Chunk buffer : Newlines asciz "0\\r\\n\\r\\n" (code 'chrHex_AF 0) ld A (Chr) cmp B (char "0") # Decimal digit? if ge cmp B (char "9") if le sub B 48 # Yes ret # 'nc' end end and B (hex "DF") # Force upper case cmp B (char "A") # Hex letter? if ge cmp B (char "F") if le sub B 55 # Yes ret # 'nc' end end ld A 0 sub A 1 # -1 ret # 'c' (code 'chunkSize 0) push X ld X Chunk # Get Chunk null (Chr) # 'Chr'? if z # No ld A (X I) # Call saved 'get' call (A) end call chrHex_AF # Read encoded count ld (X) A # Save in count if ge # >= 0 do ld A (X I) # Call saved 'get' call (A) call chrHex_AF # Read encoded count while ge # >= 0 ld C (X) # Get count shl C 4 # Combine or C A ld (X) C loop do cmp (Chr) 10 # Fine linefeed while ne null (Chr) # EOF? js 90 # Return ld A (X I) # Call saved 'get' call (A) loop ld A (X I) # Call saved 'get' call (A) null (X) # Count is zero? if z # Yes ld A (X I) # Call saved 'get' call (A) # Skip '\r' of empty line ld (Chr) 0 # Discard '\n' end end 90 pop X ret (code 'getChunked_A 0) push Y ld Y Chunk # Get Chunk null (Y) # Count <= 0 if sz # Yes ld A -1 # Return EOF ld (Chr) A else ld A (Y I) # Call saved 'get' call (A) dec (Y) # Decrement count if z ld A (Y I) # Call saved 'get' call (A) ld A (Y I) # Skip '\n', '\r' call (A) call chunkSize end end pop Y ret # (ht:In 'flg . prg) -> any (code 'In 2) push X ld X (E CDR) # Args ld E (X) # Eval 'flg' eval ld X (X CDR) # X on 'prg' cmp E Nil # 'flg? if eq # No prog X # Run 'prg' else push Y ld Y Chunk # Get Chunk ld (Y I) (Get_A) # Save current 'get' ld (Get_A) getChunked_A # Set new call chunkSize prog X # Run 'prg' ld (Get_A) (Y I) # Restore 'get' ld (Chr) 0 # Clear look ahead char pop Y end pop X ret (code 'outHexA 0) cmp A 15 # Single digit? if gt # No push A shr A 4 # Divide by 16 call outHexA # Recurse pop A and B 15 end cmp B 9 # Digit? if gt # No add B 39 # Make lower case letter end add B (char "0") # Make ASCII digit jmp (PutB) (code 'wrChunkY 0) # X ld (PutB) (Y II) # Restore 'put' ld A (Y) # Get count call outHexA # Print as hex ld B 13 # Output 'return' call (PutB) ld B 10 # Output 'newline' call (PutB) lea X (Y III) # X on chunk buffer do ld B (X) # Next byte from chunk buffer call (PutB) # Output inc X # Increment pointer dec (Y) # Decrement 'Cnt' until z ld B 13 # Output 'return' call (PutB) ld B 10 # Output 'newline' call (PutB) ld (Y II) (PutB) # Save 'put' ld (PutB) putChunkedB # Set new ret (code 'putChunkedB 0) push X push Y ld Y Chunk # Get Chunk lea X (Y III) # X on chunk buffer add X (Y) # Count index ld (X) B # Store byte inc (Y) # Increment count cmp (Y) CHUNK # Max reached? if eq # Yes call wrChunkY # Write buffer end pop Y pop X ret # (ht:Out 'flg . prg) -> any (code 'Out 2) push X ld X (E CDR) # Args ld E (X) # Eval 'flg' eval ld X (X CDR) # X on 'prg' cmp E Nil # 'flg? if eq # No prog X # Run 'prg' else push Y ld Y Chunk # Get Chunk ld (Y) 0 # Clear count ld (Y II) (PutB) # Save current 'put' ld (PutB) putChunkedB # Set new prog X # Run 'prg' null (Y) # Count? if nz # Yes call wrChunkY # Write rest end ld (PutB) (Y II) # Restore 'put' ld C Newlines # Output termination string call outStringC pop Y end ld A (OutFile) # Flush OutFile call flushA_F # OK? pop X ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/io.l0000644000000000000000000040573612265263724014714 0ustar rootroot# 27oct13abu # (c) Software Lab. Alexander Burger # Close file descriptor (code 'closeAX) cc close(A) nul4 # OK? jz Ret # Yes ld E A # Get file descriptor shl E 4 # Make short number or E CNT jmp closeErrEX # Lock/unlock file (code 'unLockFileAC) st2 (Flock L_TYPE) # 'l_type' ld (Flock L_START) 0 # Start position ('l_whence' is SEEK_SET) shr A 16 # Get length ld (Flock L_LEN) A # Length cc fcntl(C F_SETLK Flock) # Try to unlock ret (code 'wrLockFileC) ld A F_WRLCK # Write lock, length 0 jmp lockFileAC (code 'rdLockFileC) ld A F_RDLCK # Read lock, length 0 (code 'lockFileAC) st2 (Flock L_TYPE) # 'l_type' ld (Flock L_START) 0 # Start position ('l_whence' is SEEK_SET) shr A 16 # Get length ld (Flock L_LEN) A # Length do cc fcntl(C F_SETLKW Flock) # Try to lock nul4 # OK? jns Ret # Yes call errno_A cmp A EINTR # Interrupted? jne lockErr # No loop # Set the close-on-exec flag (code 'closeOnExecAX) cc fcntl(A F_SETFD FD_CLOEXEC) nul4 # OK? jns Ret # Yes ld Y SetFD jmp errnoEXY # Set file descriptor to non-blocking / blocking (code 'nonblockingA_A) push C ld C A # Keep fd cc fcntl(C F_GETFL 0) # Get file status flags push A # Save flags or A O_NONBLOCK cc fcntl(C F_SETFL A) # Set file status flags pop A # Return old flags pop C ret # Initialize input file (code 'initInFileA_A) # E ld C 0 # No name : initInFileAC_A xchg A C : initInFileCA_A push A # Save 'name' push C # and 'fd' shl C 3 # Vector index cmp C (InFDs) # 'fd' >= 'InFDs'? if ge # Yes push X ld X (InFDs) # Keep old 'InFDs' ld E C # Get vector index add E I # Plus 1 ld (InFDs) E # Store new 'InFDs' ld A (InFiles) # Get vector call allocAE_A # Extend vector ld (InFiles) A add X A # X on beg add A E # A on end do ld (X) 0 # Clear new range add X I cmp X A until eq pop X end add C (InFiles) # Get vector ld A (C) # Old inFile (should be NULL!) ld E (+ VII BUFSIZ) # sizeof(inFile) call allocAE_A ld (C) A # New inFile pop (A) # Set 'fd' ld (A I) 0 # Clear 'ix' ld (A II) 0 # Clear 'cnt' ld (A III) 0 # Clear 'next' ld C 1 ld (A IV) C # line = 1 ld (A V) C # src = 1 pop (A VI) # Set filename ret # Initialize output file (code 'initOutFileA_A) ld C A push A # Save 'fd' cc isatty(A) push A # Save 'tty' flag shl C 3 # Vector index cmp C (OutFDs) # 'fd' >= 'OutFDs'? if ge # Yes push X ld X (OutFDs) # Keep old 'OutFDs' ld E C # Get vector index add E I # Plus 1 ld (OutFDs) E # Store new 'OutFDs' ld A (OutFiles) # Get vector call allocAE_A # Extend vector ld (OutFiles) A add X A # X on beg add A E # A on end do ld (X) 0 # Clear new range add X I cmp X A until eq pop X end add C (OutFiles) # Get vector ld A (C) # Old outFile (should be NULL!) ld E (+ III BUFSIZ) # sizeof(outFile) call allocAE_A ld (C) A # New outFile pop (A II) # Set 'tty' ld (A I) 0 # Clear 'ix' pop (A) # Set 'fd' ret # Close input file (code 'closeInFileA 0) shl A 3 # Vector index cmp A (InFDs) # 'fd' < 'InFDs'? if lt # Yes push X add A (InFiles) # Get vector ld X (A) null X # Any? if nz # Yes cmp X (InFile) # Current Infile? if eq # Yes ld (InFile) 0 # Clear it end ld (A) 0 # Clear slot cc free((X VI)) # Free filename cc free(X) # And inFile end pop X end ret # Close output file (code 'closeOutFileA 0) shl A 3 # Vector index cmp A (OutFDs) # 'fd' < 'OutFDs'? if lt # Yes push X add A (OutFiles) # Get vector ld X (A) null X # Any? if nz # Yes cmp A (OutFile) # Current Outfile? if eq # Yes ld (OutFile) 0 # Clear it end ld (A) 0 # Clear slot cc free(X) # And outFile end pop X end ret # Wait for pipe process if necessary (code 'waitFileC 0) cmp (C II) 1 # 'pid' > 1? if gt # Yes do cc waitpid((C II) 0 0) # Wait for pipe process nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? jne closeErrX null (Signal) # Signal? if nz # Yes call sighandler0 end loop end ret # Interruptible read (code 'slowZ_F) ld (Z I) 0 # Clear 'ix' ld (Z II) 0 # Clear 'cnt' do cc read((Z) &(Z VII) BUFSIZ) # Read into buffer null A # OK? if ns # Yes ld (Z II) A # Set new 'cnt' ret # Return 'ge' end call errno_A cmp A EINTR # Interrupted? if ne # No setz # Return 'z' ret end null (Signal) # Signal? if nz # Yes call sighandler0 end loop (code 'slowNbC_FA) ld (C I) 0 # Clear 'ix' ld (C II) 0 # Clear 'cnt' do ld A (C) # Set non-blocking call nonblockingA_A push A # Save old file status flags cc read((C) &(C VII) BUFSIZ) # Read into buffer xchg A (S) cc fcntl((C) F_SETFL A) # Restore file status flags pop A # Get 'read' return value null A # OK? if nsz # Yes ld (C II) A # Set new 'cnt' ret # Return 'ge' end if z # Closed dec (C I) # 'ix' = 'cnt' = -1 dec (C II) setz # Return 'z' ret end call errno_A cmp A EAGAIN # No data available? if eq # Yes clrz # Return 'lt' setc ret end cmp A EINTR # Interrupted? if ne # No setz # Return 'z' ret end null (Signal) # Signal? if nz # Yes call sighandler0 end loop (code 'rdBytesCEX_F) do do cc read(C X E) # Read into buffer null A # OK? while sz # No jz Ret # EOF call errno_A cmp A EINTR # Interrupted? jne Retz # No: Return 'z' null (Signal) # Signal? if nz # Yes call sighandler0 end loop add X A # Increment buffer pointer sub E A # Decrement count until z null A # 'nsz' ret (code 'rdBytesNbCEX_F) do ld A C # Set non-blocking call nonblockingA_A push A # Save old file status flags cc read(C X E) # Read into buffer xchg A (S) cc fcntl(C F_SETFL A) # Restore file status flags pop A # Get 'read' return value null A # OK? if nsz # Yes do sub E A # Decrement count if z # Got all null A # Return 'gt' (A is non-zero) ret end add X A # Increment buffer pointer do cc read(C X E) # Read into buffer null A # OK? while sz # No jz Ret # EOF call errno_A cmp A EINTR # Interrupted? jne Retz # No: Return 'z' null (Signal) # Signal? if nz # Yes call sighandler0 end loop loop end jz Ret # EOF call errno_A cmp A EAGAIN # No data available? if eq # Yes clrz # Return 'lt' setc ret end cmp A EINTR # Interrupted? jne Retz # No: Return 'z' null (Signal) # Signal? if nz # Yes call sighandler0 end loop (code 'wrBytesCEX_F) do cc write(C X E) # Write buffer null A # OK? if ns # Yes sub E A # Decrement count jz Ret # Return 'z' if OK add X A # Increment buffer pointer else call errno_A cmp A EBADF # Bad file number? jeq retnz # Return 'nz' cmp A EPIPE # Broken pipe? jeq retnz # Return 'nz' cmp A ECONNRESET # Connection reset by peer? jeq retnz # Return 'nz' cmp A EINTR # Interrupted? if ne # No cmp C 2 # stderr? jne wrBytesErr # No ld E 2 # Exit error code jmp byeE end null (Signal) # Signal? if nz # Yes call sighandler0 end end loop (code 'clsChildY 0) cmp (Y) (Talking) # Currently active? if eq # Yes ld (Talking) 0 # Clear end ld (Y) 0 # Clear 'pid' cc close((Y I)) # Close 'hear' cc close((Y II)) # and 'tell' cc free((Y V)) # Free buffer ret (code 'wrChildCXY) # E ld E (Y IV) # Get buffer count null E # Any? if z # No do cc write((Y II) X C) # Write buffer to 'tell' pipe null A # OK? if ns # Yes sub C A # Decrement count jz Ret # Done add X A # Increment buffer pointer else call errno_A cmp A EAGAIN # Would block? break eq # Yes cmp A EPIPE # Broken pipe? jeq clsChildY # Close child cmp A ECONNRESET # Connection reset by peer? jeq clsChildY # Close child cmp A EINTR # Interrupted? jne wrChildErr # No end loop end ld A (Y V) # Get buffer add E C # Increment count add E 4 # plus count size call allocAE_A # Extend buffer ld (Y V) A # Store ld E (Y IV) # Get buffer count again add E A # Point to new count ld A C # Store new st4 (E) add E 4 # Point to new data movn (E) (X) C # Copy data add C 4 # Total new size add (Y IV) C # Add to buffer count ret (code 'flushA_F 0) null A # Output file? if nz # Yes push E ld E (A I) # Get 'ix' null E # Any? if nz # Yes push C push X ld (A I) 0 # Clear 'ix' ld C (A) # Get 'fd' lea X (A III) # Buffer pointer call wrBytesCEX_F # Write buffer pop X pop C end pop E end ret # Return 'z' if OK (code 'flushAll) # C ld C 0 # Iterate output files do cmp C (OutFDs) # 'fd' < 'OutFDs'? while lt ld A C # Get vector index add A (OutFiles) # Get OutFile ld A (A) call flushA_F # Flush it add C I # Increment vector index loop ret ### Low level I/O ### (code 'stdinByte_A) push Z ld Z ((InFiles)) # Get stdin null Z # Open? if nz # Yes call getBinaryZ_FB # Get byte if nc zxt pop Z ret end end cc isatty(0) # STDIN nul4 # on a tty? if z # No ld A -1 # Return EOF pop Z ret end ld E 0 # Exit OK jmp byeE (code 'getBinaryZ_FB 0) ld A (Z I) # Get 'ix' cmp A (Z II) # Equals 'cnt'? if eq # Yes null A # Closed? js retc # Yes call slowZ_F # Read into buffer jz retc # EOF (c) ld A 0 # 'ix' end inc (Z I) # Increment 'ix' add A Z # Fetch byte (nc) ld B (A VII) # from buffer ret # nc # Add next byte to a number (code 'byteNumBCX_CX 0) zxt big X # Big number? if z # No: Direct buffer pointer # xxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxS010 # 59 51 43 35 27 19 11 3 cmp C 67 # Short full? if eq # Yes ld C (X) # Get short number shr C 3 # De-normalize, keep sign bit shl A 4 # New digit or A CNT # Make short number call consNumCA_C # Box number ld (X) C ld X C ld C 12 # Next digit in bignum ret end cmp C 59 # Short digit full? if eq # Yes cmp A 32 # Fit into 5 bits? if ge # No ld C (X) # Get short number shr C 3 # De-normalize, keep sign bit shl A 56 # Combine byte with digit or A C call boxNumA_A # Box number ld (X) A ld X A ld C 4 # Start next digit in bignum ret end end shl A C # Shift byte to character position or (X) A # Combine with short number add C 8 # Increment position ret end cmp C 68 # Last short full? if eq # Yes ld C (X BIG) # Get short number shr C 4 # De-normalize shl A 4 # New digit or A CNT # Make short number call consNumCA_C # Box number ld (X BIG) C ld X C ld C 12 # Next digit in bignum ret end cmp C 60 # Short digit full? if eq # Yes cmp A 16 # Fit into 4 bits? if ge # No ld C (X BIG) # Get short number shr C 4 # De-normalize shl A 56 # Combine byte with digit or A C call boxNumA_A # Box number ld (X BIG) A ld X A ld C 4 # Next digit in bignum ret end end shl A C # Shift byte to character position or (X BIG) A # Combine with name digit add C 8 # Increment position ret # Read binary expression (code 'binReadZ_FE) call (GetBinZ_FB) # Tag byte? jc ret # No nul B # NIX? jz retNil # Return NIL zxt test B (hex "FC") # Atomic? if z # No ld E A cmp B BEG # Begin a list? jne retnc # No: Return DOT or END (also in B) call binReadZ_FE # Else read list jc ret push X call consE_X # First cell ld (X) E ld (X CDR) Nil link push X # Save it link do call binReadZ_FE # Next item jc 10 # EOF cmp E END # Any? while ne # Yes cmp E DOT # Dotted pair? if eq cmp B DOT # Only if B is also DOT (to distinguish from Zero) if eq # Yes call binReadZ_FE # Get CDR if c # EOF 10 drop pop X ret # Return 'c' end cmp E END # Circular list? ldz E (L I) # Yes: Get first cell ld (X CDR) E # Store in last cell break T # 'nc' (E > END) end end call consE_C # Append next cell ld (C) E ld (C CDR) Nil ld (X CDR) C ld X C loop ld E (L I) # Return list drop # Return 'nc' pop X ret end push X link push ZERO # Result ld X S link ld E A # Get tag byte shr E 2 # Count and A 3 # Tag if z # NUMBER ld C 3 # Build signed number cmp E 63 # More than one chunk? if eq # Yes do do call (GetBinZ_FB) # Next byte? jc 90 # No call byteNumBCX_CX dec E # Decrement count until z call (GetBinZ_FB) # Next count? jc 90 # No zxt ld E A cmp B 255 # Another chunk? until ne # No or B B # Empty? jz 20 # Yes end do call (GetBinZ_FB) # Next byte? jc 90 # No call byteNumBCX_CX # (B is zero (not DOT) if Zero) dec E # Decrement count until z 20 ld E (L I) # Get result big E # Big number? if nz # Yes ld X (E DIG) # Keep lowest digit ld A E # Half result call halfA_A ld E X # Sign bit and E 1 shl E 3 or E A # Set in result end else # INTERN, TRANSIENT or EXTERN push A # Tag ld C 4 # Build name cmp E 63 # More than one chunk? if eq # Yes do do call (GetBinZ_FB) # Next byte? jc 90 # No call byteSymBCX_CX dec E # Decrement count until z call (GetBinZ_FB) # Next count? jc 90 # No zxt ld E A cmp B 255 # Another chunk? until ne # No or B B # Empty? jz 30 # Yes end do call (GetBinZ_FB) # Next byte? jc 90 # No call byteSymBCX_CX dec E # Decrement count until z 30 ld X (L I) # Get name pop A # Get tag cmp A TRANSIENT # Transient? if eq # Yes call consSymX_E # Build symbol else cmp A INTERN # Internal? if eq # Yes push Y call findSymX_E # Find or create it pop Y else # External null (Extn) # External symbol offset? if nz # Yes ld A X # Get file number shr A 24 # Lower 8 bits ld C A # into C and C (hex "FF") shr A 12 # Upper 8 bits and A (hex "FF00") or A C add A (Extn) # Add external symbol offset shl A 24 ld C A # Lower result bits shl A 12 or A C and A (hex "000FF000FF000000") # Mask file number and X (hex "FFF00FFF00FFFFFF") # Mask object ID or X A # Combine end call externX_E # New external symbol end end end clrc 90 drop pop X ret # Binary print next byte from a number (code 'prByteCEXY 0) null C # New round? if z # Yes cnt X # Short number? if z # No ld E (X DIG) # Next digit ld X (X BIG) else ld E X # Get short shr E 4 # Normalize end shr Y 1 # Get overflow bit rcl E 1 # Shift into digit rcl Y 1 # Keep new overflow bit ld C 8 # Init count end ld A E # Output next byte call (PutBinBZ) shr E 8 # Shift to next dec C # Decrement count ret # Binary print short number (code 'prCntCE 0) ld A E do shr A 8 # More bytes? while nz # Yes add C 4 # Increment count loop ld A C # Output tag byte call (PutBinBZ) shr C 2 # Discard tag bits do ld A E # Next data byte shr E 8 call (PutBinBZ) # Output data byte dec C # More? until z # No ret # Binary print expression (code 'prTellEZ 0) ld (PutBinBZ) putTellBZ # Set binary print function ld (Extn) 0 # Set external symbol offset to zero call binPrintEZ ret (code 'prE) ld (PutBinBZ) putStdoutB # Set binary print function (code 'binPrintEZ) cnt E # Short number? if nz # Yes ld C 4 # Count significant bytes (adjusted to tag) shr E 3 # Normalize jmp prCntCE # Output 'cnt' end big E # Big number? if nz # Yes push X push Y push E # Save signed number off E SIGN # Make positive ld X E # Keep in X ld A 8 # Count 8 significant bytes do ld C (E DIG) # Keep digit ld E (E BIG) # More cells? cnt E while z # Yes add A 8 # Increment count by 8 loop shr E 4 # Normalize short shl C 1 # Get most significant bit of last digit addc E E # Any significant bits in short number? if nz # Yes do inc A # Increment count shr E 8 # More bytes? until z # No end pop Y # Get sign shr Y 3 # into lowest bit ld C 0 # Init byte count cmp A 63 # Single chunk? if lt # Yes push A # Count shl A 2 # Adjust to tag byte call (PutBinBZ) # Output tag byte do call prByteCEXY # Output next data byte dec (S) # More? until z # No else sub A 63 # Adjust count push A # Count ld B (* 4 63) # Output first tag byte call (PutBinBZ) push 63 # and first 63 data bytes do call prByteCEXY # Output next data byte dec (S) # More? until z # No do cmp (S I) 255 # Count greater or equal 255? while ge # Yes ld A 255 # Next chunk ld (S) A # and the next 255 data bytes call (PutBinBZ) # Output count byte do call prByteCEXY # Output next data byte dec (S) # More? until z # No sub (S I) 255 # Decrement counter loop add S I # Drop second count ld A (S) # Retrieve count call (PutBinBZ) # Output last count do sub (S) 1 # More? while ge # Yes call prByteCEXY # Output next data byte loop end add S I # Drop count pop Y pop X ret end sym E # Symbol? if nz # Yes cmp E Nil # NIL? if eq # Yes ld B NIX # Output NIX jmp (PutBinBZ) end sym (E TAIL) # External symbol? if nz # Yes ld E (E TAIL) call nameE_E # Get name null (Extn) # External symbol offset? if nz # Yes ld A E # Get file number shr A 24 # Lower 8 bits ld C A # into C and C (hex "FF") shr A 12 # Upper 8 bits and A (hex "FF00") or A C sub A (Extn) # Subtract external symbol offset shl A 24 ld C A # Lower result bits shl A 12 or A C and A (hex "000FF000FF000000") # Mask file number and E (hex "FFF00FFF00FFFFFF") # Mask object ID or E A # Combine end shl E 2 # Strip status bits shr E 6 # Normalize ld C (+ 4 EXTERN) # Count significant bytes (adjusted to tag) jmp prCntCE # Output external name end push X push Y ld X (E TAIL) call nameX_X # Get name cmp X ZERO # Any? if eq # No ld B NIX # Output NIX call (PutBinBZ) else ld Y ((EnvIntern)) call isInternEXY_F # Internal symbol? ld C INTERN # Yes ldnz C TRANSIENT # No cnt X # Short name? if nz # Yes add C 4 # Count significant bytes (adjusted to tag) ld E X # Get name shr E 4 # Normalize call prCntCE # Output internal or transient name else # Long name ld E X # Into E ld A 8 # Count significant bytes do ld E (E BIG) # More cells? cnt E while z # Yes add A 8 # Increment count loop shr E 4 # Any significant bits in short name? if nz # Yes do inc A # Increment count shr E 8 # More bytes? until z # No end ld E A # Keep count in E cmp A 63 # Single chunk? if lt # Yes shl A 2 # Adjust to tag byte or A C # Combine with tag call (PutBinBZ) # Output tag byte ld C 0 do call symByteCX_FACX # Next data byte call (PutBinBZ) # Output it dec E # More? until z # No else ld B (* 4 63) # Output first tag byte or A C # Combine with tag call (PutBinBZ) sub E 63 # Adjust count push E # Count ld E 63 # and first 63 data bytes ld C 0 do call symByteCX_FACX # Next data byte call (PutBinBZ) # Output it dec E # More? until z # No do cmp (S) 255 # Count greater or equal 255? while ge # Yes ld A 255 # Next chunk ld E A # and the next 255 data bytes call (PutBinBZ) # Output count byte do call symByteCX_FACX # Next data byte call (PutBinBZ) # Output it dec E # More? until z # No sub (S) 255 # Decrement counter loop pop E # Retrieve count ld A E call (PutBinBZ) # Output last count do sub E 1 # More? while ge # Yes call symByteCX_FACX # Next data byte call (PutBinBZ) # Output it loop end end end pop Y pop X ret end push X push Y ld B BEG # Begin list call (PutBinBZ) ld X E # Keep list in X call circE_YF # Circular? if nz # No do ld E (X) # Next item call binPrintEZ ld X (X CDR) # NIL-terminated? cmp X Nil while ne # No atom X # Atomic tail? if nz # Yes ld B DOT # Output dotted pair call (PutBinBZ) ld E X # Output atom call binPrintEZ pop Y # Return pop X ret end loop else cmp X Y # Fully circular? if eq # Yes do ld E (X) # Output CAR call binPrintEZ ld X (X CDR) # Done? cmp X Y until eq # Yes ld B DOT # Output dotted pair call (PutBinBZ) else do # Non-circular part ld E (X) # Output CAR call binPrintEZ ld X (X CDR) # Done? cmp X Y until eq # Yes ld B DOT # Output DOT+BEG call (PutBinBZ) ld B BEG call (PutBinBZ) do # Circular part ld E (X) # Output CAR call binPrintEZ ld X (X CDR) # Done? cmp X Y until eq # Yes ld B DOT # Output DOT+END call (PutBinBZ) ld B END call (PutBinBZ) end end pop Y pop X ld B END # End list jmp (PutBinBZ) # Family IPC (code 'putTellBZ 0) ld (Z) B # Store byte inc Z # Increment pointer lea A ((TellBuf) (- PIPE_BUF 1)) # Reached (TellBuf + PIPE_BUF - 1)? cmp Z A jeq tellErr # Yes ret (code 'tellBegZ_Z 0) ld (TellBuf) Z # Set global buffer add Z 4 # 4 bytes space (PID and count) set (Z) BEG # Begin a list inc Z ret (code 'tellEndAZ) push X push Y set (Z) END # Close list inc Z ld X (TellBuf) # Get buffer st2 (X) # Store PID push A # PID ld E Z # Calculate total size sub E X ld A E # Size in A sub A 4 # without PID and count st2 (X 2) # Store in buffer count push A # Size ld C (Tell) # File descriptor null C # Any? if nz # Yes call wrBytesCEX_F # Write buffer to pipe if nz # Not successful cc close(C) # Close 'Tell' ld (Tell) 0 # Clear 'Tell' end end ld Y (Child) # Iterate children ld Z (Children) # Count do sub Z VI # More? while ge # Yes null (Y) # 'pid'? if nz # Yes ld A (S I) # Get PID null A # Any? jz 10 # Yes cmp A (Y) # Same as 'pid'? if eq # Yes 10 ld C (S) # Get size lea X ((TellBuf) 4) # and data call wrChildCXY # Write to child end end add Y VI # Increment by sizeof(child) loop add S II # Drop size and PID pop Y pop X ret (code 'unsync 0) # X ld C (Tell) # File descriptor null C # Any? if nz # Yes push 0 # Send zero ld X S # Get buffer ld E 4 # Size (PID and count) call wrBytesCEX_F # Write buffer to pipe if nz # Not successful cc close(C) # Close 'Tell' ld (Tell) 0 # Clear 'Tell' end add S I # Drop buffer end set (Sync) 0 # Clear sync flag ret (code 'rdHear_FE) push Z ld A (Hear) # Get 'hear' fd shl A 3 # Vector index add A (InFiles) # Get vector ld Z (A) # Input file ld (GetBinZ_FB) getBinaryZ_FB # Set binary read function ld (Extn) 0 # Set external symbol offset to zero call binReadZ_FE # Read item pop Z ret # Return next byte from symbol name (code 'symByteCX_FACX 0) null C # New round? if z # Yes cmp X ZERO # Done? jeq ret # Yes: Return 'z' cnt X # Short? if nz # Yes ld C X # Get short shr C 4 # Normalize ld X ZERO # Clear for next round else ld C (X DIG) # Get next digit ld X (X BIG) end end ld A C # Get byte shr C 8 # Shift out or B B # Return B zxt ret (code 'symCharCX_FACX 0) # Return next char from symbol name call symByteCX_FACX # First byte jz ret # Return 'z' if none cmp B (hex "FF") # Special? if ne # No cmp B 128 # Single byte? if ge # No test B (hex "20") # Two bytes? if z # Yes and B (hex "1F") # First byte 110xxxxx shl A 6 # xxxxx000000 push A else # Three bytes and B (hex "F") # First byte 1110xxxx shl A 6 # xxxx000000 push A call symByteCX_FACX # Second byte and B (hex "3F") # 10xxxxxx or A (S) # Combine shl A 6 # xxxxxxxxxx000000 ld (S) A end call symByteCX_FACX # Last byte and B (hex "3F") # 10xxxxxx or (S) A # Combine pop A # Get result end ret end ld A TOP # Return special "top" character or A A ret (code 'bufStringE_SZ 0) ld Z S # 8-byte-buffer push (Z) # Save return address push X # and X cmp E Nil # Empty? if ne # No ld X (E TAIL) call nameX_X # Get name ld C 0 do call symByteCX_FACX while nz ld (Z) B # Store next byte inc Z test Z 7 # Buffer full? if z # Yes sub S 8 # Extend buffer cmp S (StkLimit) # Stack check jlt stkErr movm (S) (S 8) (Z) sub Z 8 # Reset buffer pointer end loop end set (Z) 0 # Null byte add Z 8 # Round up off Z 7 pop X ret (code 'pathStringE_SZ 0) ld Z S # 8-byte-buffer push (Z) # Save return address push X # and X cmp E Nil # Empty? if ne # No ld X (E TAIL) call nameX_X # Get name ld C 0 call symByteCX_FACX # First byte if nz cmp B (char "+") # Plus? if eq ld (Z) B # Store "+" inc Z call symByteCX_FACX # Second byte jz 90 end cmp B (char "@") # Home path? if ne # No do ld (Z) B # Store byte inc Z test Z 7 # Buffer full? if z # Yes sub S 8 # Extend buffer movm (S) (S 8) (Z) sub Z 8 # Reset buffer pointer end call symByteCX_FACX # Next byte? until z # No else push E ld E (Home) # Home directory? null E if nz # Yes do ld B (E) ld (Z) B # Store next byte inc Z test Z 7 # Buffer full? if z # Yes sub S 8 # Extend buffer movm (S) (S 8) (Z) sub Z 8 # Reset buffer pointer end inc E nul (E) # More? until z # No end pop E do call symByteCX_FACX while nz ld (Z) B # Store next byte inc Z test Z 7 # Buffer full? if z # Yes sub S 8 # Extend buffer movm (S) (S 8) (Z) sub Z 8 # Reset buffer pointer end loop end end end 90 set (Z) 0 # Null byte add Z 8 # Round up off Z 7 pop X ret # (path 'any) -> sym (code 'doPath 2) push Z ld E ((E CDR)) # Get arg call evSymE_E # Evaluate to a symbol call pathStringE_SZ # Write to stack buffer ld E S # Make transient symbol call mkStrE_E ld S Z # Drop buffer pop Z ret # Add next char to symbol name (code 'charSymACX_CX 0) cmp A (hex "80") # ASCII?? jlt byteSymBCX_CX # Yes: 0xxxxxxx cmp A (hex "800") # Double-byte? if lt # Yes push A # 110xxxxx 10xxxxxx shr A 6 # Upper five bits and B (hex "1F") or B (hex "C0") call byteSymBCX_CX # Add first byte pop A and B (hex "3F") # Lower 6 bits or B (hex "80") jmp byteSymBCX_CX # Add second byte end cmp A TOP # Special "top" character? if eq # Yes ld B (hex "FF") jmp byteSymBCX_CX end push A # 1110xxxx 10xxxxxx 10xxxxxx shr A 12 # Hightest four bits and B (hex "0F") or B (hex "E0") call byteSymBCX_CX # Add first byte ld A (S) shr A 6 # Middle six bits and B (hex "3F") or B (hex "80") call byteSymBCX_CX # Add second byte pop A and B (hex "3F") # Lowest 6 bits or B (hex "80") # Add third byte # Add next byte to symbol name (code 'byteSymBCX_CX 0) zxt big X # Long name? if z # No: Direct buffer pointer # 0000.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx.xxxxxxx0010 # 60 52 44 36 28 20 12 4 cmp C 60 # Short digit full? if ne # No shl A C # Shift byte to character position or (X) A # Combine with name digit add C 8 # Increment position ret end ld C (X) # Get short number shr C 4 # De-normalize shl A 56 # Combine byte with digit or C A call boxNum_A # Box number ld (A DIG) C ld (X) A ld X A ld C 4 # Start new digit ret end cmp C 60 # Short digit full? if ne # No shl A C # Shift byte to character position or (X BIG) A # Combine with name digit add C 8 # Increment position ret end ld C (X BIG) # Get short number shr C 4 # De-normalize shl A 56 # Combine byte with digit or C A call boxNum_A # Box number ld (A DIG) C ld (X BIG) A ld X A ld C 4 # Start new digit ret (code 'currFdX_C 0) ld C (EnvInFrames) # InFrames or OutFrames? or C (EnvOutFrames) jz noFdErrX # No (code 'currFd_C) ld C (EnvOutFrames) # OutFrames? null C if z # No ld C (EnvInFrames) # Use InFrames else null (EnvInFrames) # InFrames? if nz # Both cmp C (EnvInFrames) # OutFrames > InFrames? if gt # Yes ld C (EnvInFrames) # Take InFrames end end end ld C (C I) # Get 'fd' ret (code 'rdOpenEXY) cmp E Nil # Standard input? if eq # Yes ld (Y I) 0 # fd = stdin ld (Y II) 0 # pid = 0 else num E # Descriptor? if nz # Yes cnt E # Need short jz cntErrEX ld (Y II) 0 # pid = 0 ld A E # Get fd shr A 4 # Normalize if c # Negative ld C (EnvInFrames) # Fetch from input frames do ld C (C) # Next frame null C # Any? jz badFdErrEX # No dec A # Found frame? until z # Yes ld A (C I) # Get fd from frame end ld (Y I) A # Store 'fd' shl A 3 # Vector index cmp A (InFDs) # 'fd' >= 'InFDs'? jge badFdErrEX # Yes add A (InFiles) # Get vector ld A (A) # Input file null A # Any? jz badFdErrEX # No else push Z sym E # File name? if nz # Yes ld (Y II) 1 # pid = 1 call pathStringE_SZ do ld B (S) # First char cmp B (char "+") # Plus? if eq # Yes cc open(&(S 1) (| O_APPEND O_CREAT O_RDWR) (oct "0666")) else cc open(S O_RDONLY) end nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? jne openErrEX # No null (Signal) # Signal? if nz # Yes call sighandlerX end loop ld (Y I) A # Save 'fd' ld B (S) # First char cmp B (char "+") # Plus? if eq # Yes cc strdup(&(S 1)) # Duplicate name else cc strdup(S) # Duplicate name end ld C (Y I) # Get 'fd' call initInFileCA_A ld A (Y I) # Get fd call closeOnExecAX ld S Z # Drop buffer else # Else pipe push X push 0 # End-of-buffers marker ld X E # Get list ld E (X) # Pathname call xSymE_E # Make symbol call pathStringE_SZ # Write to stack buffer do ld X (X CDR) # Arguments? atom X while z # Yes push Z # Buffer chain ld E (X) # Next argument call xSymE_E # Make symbol call bufStringE_SZ # Write to stack buffer loop push Z ld Z S # Point to chain ld X Z push 0 # NULL terminator do lea A (X I) # Buffer pointer push A # Push to vector ld X (X) # Follow chain null (X) # Done? until z # Yes ld X (X I) # Retrieve X push A # Create 'pipe' structure cc pipe(S) # Open pipe nul4 # OK? jnz pipeErrX ld4 (S) # Get pfd[0] call closeOnExecAX ld4 (S 4) # Get pfd[1] call closeOnExecAX cc fork() # Fork child process ld (Y II) A # Set 'pid' nul4 # In child? js forkErrX if z # Yes cc setpgid(0 0) # Set process group ld4 (S) # Close read pipe call closeAX ld4 (S 4) # Get write pipe cmp A 1 # STDOUT_FILENO? if ne # No cc dup2(A 1) # Dup to STDOUT_FILENO ld4 (S 4) # Close write pipe call closeAX end add S I # Drop 'pipe' structure cc execvp((S) S) # Execute program jmp execErrS # Error if failed end cc setpgid(A 0) # Set process group ld4 (S 4) # Close write pipe call closeAX ld4 (S) # Get read pipe ld (Y I) A # Set 'fd' call initInFileA_A add S I # Drop 'pipe' structure do ld S Z # Clean up buffers pop Z # Chain null Z # End? until z # Yes pop X end pop Z end end ret (code 'wrOpenEXY) cmp E Nil # Standard output? if eq # Yes ld (Y I) 1 # fd = stdout ld (Y II) 0 # pid = 0 else num E # Descriptor? if nz # Yes cnt E # Need short jz cntErrEX ld (Y II) 0 # pid = 0 ld A E # Get fd shr A 4 # Normalize if c # Negative ld C (EnvOutFrames) # Fetch from output frames do ld C (C) # Next frame null C # Any? jz badFdErrEX # No dec A # Found frame? until z # Yes ld A (C I) # Get fd from frame end ld (Y I) A # Store 'fd' shl A 3 # Vector index cmp A (OutFDs) # 'fd' >= 'OutFDs'? jge badFdErrEX # Yes add A (OutFiles) # Get vector ld A (A) # Slot? null A # Any? jz badFdErrEX # No else push Z sym E # File name? if nz # Yes ld (Y II) 1 # pid = 1 call pathStringE_SZ do ld B (S) # First char cmp B (char "+") # Plus? if eq # Yes cc open(&(S 1) (| O_APPEND O_CREAT O_WRONLY) (oct "0666")) else cc open(S (| O_CREAT O_TRUNC O_WRONLY) (oct "0666")) end nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? jne openErrEX # No null (Signal) # Signal? if nz # Yes call sighandlerX end loop ld (Y I) A # Save 'fd' call initOutFileA_A ld A (Y I) # Get fd call closeOnExecAX ld S Z # Drop buffer else # Else pipe push X push 0 # End-of-buffers marker ld X E # Get list ld E (X) # Pathname call xSymE_E # Make symbol call pathStringE_SZ # Write to stack buffer do ld X (X CDR) # Arguments? atom X while z # Yes push Z # Buffer chain ld E (X) # Next argument call xSymE_E # Make symbol call bufStringE_SZ # Write to stack buffer loop push Z ld Z S # Point to chain ld X Z push 0 # NULL terminator do lea A (X I) # Buffer pointer push A # Push to vector ld X (X) # Follow chain null (X) # Done? until z # Yes ld X (X I) # Retrieve X push A # Create 'pipe' structure cc pipe(S) # Open pipe nul4 # OK? jnz pipeErrX ld4 (S) # Get pfd[0] call closeOnExecAX ld4 (S 4) # Get pfd[1] call closeOnExecAX cc fork() # Fork child process ld (Y II) A # Set 'pid' nul4 # In child? js forkErrX if z # Yes cc setpgid(0 0) # Set process group ld4 (S 4) # Close write pipe call closeAX ld4 (S) # Get read pipe null A # STDIN_FILENO? if ne # No cc dup2(A 0) # Dup to STDIN_FILENO ld4 (S) # Close read pipe call closeAX end add S I # Drop 'pipe' structure cc execvp((S) S) # Execute program jmp execErrS # Error if failed end cc setpgid(A 0) # Set process group ld4 (S) # Close read pipe call closeAX ld4 (S 4) # Get write pipe ld (Y I) A # Set 'fd' call initOutFileA_A add S I # Drop 'pipe' structure do ld S Z # Clean up buffers pop Z # Chain null Z # End? until z # Yes pop X end pop Z end end ret (code 'erOpenEXY) num E # Need symbol jnz symErrEX sym E jz symErrEX cc dup(2) # Duplicate current stderr ld (Y I) A # Save it cmp E Nil # Use current output channel? if eq # Yes cc dup(((OutFile))) # Duplicate 'fd' ld C A # Keep in C else push Z call pathStringE_SZ # File name do ld B (S) # First char cmp B (char "+") # Plus? if eq # Yes cc open(&(S 1) (| O_APPEND O_CREAT O_WRONLY) (oct "0666")) else cc open(S (| O_CREAT O_TRUNC O_WRONLY) (oct "0666")) end nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? jne openErrEX # No null (Signal) # Signal? if nz # Yes call sighandlerX end loop ld S Z # Drop buffer pop Z ld C A # Keep 'fd' in C call closeOnExecAX end cc dup2(C 2) # Dup 'fd' to STDERR_FILENO ld A C call closeAX ret (code 'ctOpenEXY) num E # Need symbol jnz symErrEX sym E jz symErrEX cmp E Nil # Shared lock on current I/O channel? if eq # Yes ld (Y I) -1 # 'fd' call currFdX_C # Get current fd call rdLockFileC else cmp E TSym # Exclusive lock on current I/O channel? if eq # Yes ld (Y I) -1 # 'fd' call currFdX_C # Get current fd call wrLockFileC else push Z call pathStringE_SZ # File name do ld B (S) # First char cmp B (char "+") # Plus? if eq # Yes cc open(&(S 1) (| O_CREAT O_RDWR) (oct "0666")) else cc open(S (| O_CREAT O_RDWR) (oct "0666")) end nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? jne openErrEX # No null (Signal) # Signal? if nz # Yes call sighandlerX end loop ld S Z # Drop buffer pop Z ld (Y I) A # Save 'fd' ld C A # Keep in C ld B (S) # First char cmp B (char "+") # Plus? if eq # Yes call rdLockFileC # Read lock else call wrLockFileC # Write lock end ld A (Y I) # Get fd call closeOnExecAX end end ret (code 'getStdin_A 0) push Z ld Z (InFile) # Current InFile null Z # Any? if nz # Yes cmp Z ((InFiles)) # On stdin? if ne # No ld A (Z I) # Get 'ix' cmp A (Z II) # Equals 'cnt'? if eq # Yes null A # Closed? js 90 # Return -1 call slowZ_F # Read into buffer jz 90 # Return -1 ld A 0 # 'ix' end inc (Z I) # Increment 'ix' add A Z # Fetch byte ld B (A VII) # from buffer cmp B 10 # Newline? if eq # Yes inc (Z IV) # Increment line end zxt # Extend into A else push C push E push X atom (Led) # Line editor? if nz # No ld C 0 # Standard input ld E -1 # No timeout ld X 0 # Runtime expression call waitFdCEX_A # Wait for events call stdinByte_A # Get byte else ld C (LineC) null C # First call? if ns # No ld X (LineX) # Get line status else ld E (Led) # Run line editor call runE_E cmp E Nil # NIL if eq # Yes ld X ZERO # Empty else ld X (E TAIL) call nameX_X # Get name end ld C 0 end call symByteCX_FACX # Extract next byte if z # None ld A 10 # Default to linefeed ld C -1 end ld (LineX) X # Save line status ld (LineC) C end pop X pop E pop C end else 90 ld A -1 # Return EOF end ld (Chr) A pop Z ret (code 'getParse_A 0) push C push X ld X (EnvParseX) # Get parser status ld C (EnvParseC) call symByteCX_FACX # Extract next byte if z # Done ld A (EnvParseEOF) # Get parser trail bytes shr A 8 # More bytes? ld (EnvParseEOF) A if nz # Yes zxt # Return next byte else dec A # Return -1 end end ld (Chr) A ld (EnvParseX) X # Save status ld (EnvParseC) C pop X pop C ret (code 'pushInFilesY) ld A (InFile) # Current InFile? null A if nz # Yes ld (A III) (Chr) # Save Chr in next end ld A (Y I) # Get 'fd' shl A 3 # Vector index add A (InFiles) # Get InFile ld A (A) ld (InFile) A # Store new null A # Any? if nz # Yes ld A (A III) # Get 'next' else ld A -1 end ld (Chr) A # Save in 'Chr' ld (Y III) (Get_A) # Save 'get' ld (Get_A) getStdin_A # Set new ld (Y) (EnvInFrames) # Set link ld (EnvInFrames) Y # Link frame ret (code 'pushOutFilesY) ld A (Y I) # Get 'fd' shl A 3 # Vector index add A (OutFiles) # Get OutFile ld (OutFile) (A) # Store new ld (Y III) (PutB) # Save 'put' ld (PutB) putStdoutB # Set new ld (Y) (EnvOutFrames) # Set link ld (EnvOutFrames) Y # Link frame ret (code 'pushErrFilesY) ld (Y) (EnvErrFrames) # Set link ld (EnvErrFrames) Y # Link frame ret (code 'pushCtlFilesY) ld (Y) (EnvCtlFrames) # Set link ld (EnvCtlFrames) Y # Link frame ret (code 'popInFiles) # C ld C (EnvInFrames) # Get InFrames null (C II) # 'pid'? if nz # Yes cc close((C I)) # Close 'fd' ld A (C I) # Close input file call closeInFileA call waitFileC # Wait for pipe process if necessary else ld A (InFile) # Current InFile? null A if nz # Yes ld (A III) (Chr) # Save Chr in next end end ld (Get_A) (C III) # Retrieve 'get' ld C (C) # Get link ld (EnvInFrames) C # Restore InFrames null C # Any? if z # No ld A ((InFiles)) # InFiles[0] (stdin) else ld A (C I) # Get 'fd' shl A 3 # Vector index add A (InFiles) ld A (A) # Get previous InFile end ld (InFile) A # Set InFile null A # Any? if nz # Yes ld A (A III) # Get 'next' else ld A -1 end ld (Chr) A # Save in 'Chr' ret (code 'popOutFiles) # C ld A (OutFile) # Flush OutFile call flushA_F ld C (EnvOutFrames) # Get OutFrames null (C II) # 'pid'? if nz # Yes cc close((C I)) # Close 'fd' ld A (C I) # Close input file call closeOutFileA call waitFileC # Wait for pipe process if necessary end ld (PutB) (C III) # Retrieve 'put' ld C (C) # Get link ld (EnvOutFrames) C # Restore OutFrames null C # Any? if z # No ld A ((OutFiles) I) # OutFiles[1] (stdout) else ld A (C I) # Get 'fd' shl A 3 # Vector index add A (OutFiles) ld A (A) # Get previous OutFile end ld (OutFile) A # Set OutFile ret (code 'popErrFiles) # C ld C (EnvErrFrames) # Get ErrFrames cc dup2((C I) 2) # Restore stderr cc close((C I)) # Close 'fd' ld (EnvErrFrames) ((EnvErrFrames)) # Restore ErrFrames ret (code 'popCtlFiles) # C ld C (EnvCtlFrames) # Get CtlFrames null (C I) # 'fd' >= 0? if ns # Yes cc close((C I)) # Close 'fd' else call currFd_C # Get current fd ld A (| F_UNLCK (hex "00000")) # Unlock, length 0 call unLockFileAC # Unlock end ld (EnvCtlFrames) ((EnvCtlFrames)) # Restore CtlFrames ret # Get full char from input channel (code 'getChar_A 0) ld A (Chr) # Get look ahead cmp B (hex "FF") # Special "top" character? if ne # No cmp B 128 # Single byte? if ge # No test B (hex "20") # Two bytes? if z # Yes and B (hex "1F") # First byte 110xxxxx shl A 6 # xxxxx000000 push A else # Three bytes and B (hex "F") # First byte 1110xxxx shl A 6 # xxxx000000 push A call (Get_A) # Get second byte and B (hex "3F") # 10xxxxxx or A (S) # Combine shl A 6 # xxxxxxxxxx000000 ld (S) A end call (Get_A) # Get last byte and B (hex "3F") # 10xxxxxx or (S) A # Combine pop A # Get result end ret end ld A TOP ret # Skip White Space and Comments (code 'skipC_A 0) ld A (Chr) null A # EOF? if ns # No do do cmp B 32 # White space? while le # Yes call (Get_A) # Get next null A # EOF? js 90 # Yes loop cmp A C # Comment char? while eq # Yes call (Get_A) do cmp B 10 # Linefeed? while ne #No null A # EOF? js 90 # Yes call (Get_A) loop loop end 90 ret (code 'comment_A 0) call (Get_A) cmp B (char "{") if ne # No do cmp B 10 # Linefeed? while ne #No null A # EOF? js 90 # Yes call (Get_A) loop else # Block comment do call (Get_A) null A # EOF? js 90 # Yes cmp B (char "}") # End of block comment? if eq call (Get_A) cmp B (char "#") break eq # Yes end loop call (Get_A) end 90 ret (code 'skip_A 0) ld A (Chr) do null A # EOF? while ns # No do cmp B 32 # White space? while le # Yes call (Get_A) # Get next null A # EOF? js 90 # Yes loop cmp B (char "#") # Comment char? while eq # Yes call comment_A # Skip comment loop 90 ret (code 'testEscA_F 0) do null A # EOF? if s # Yes clrc # Return NO ret end cmp B (char "\^") # Caret? if eq # Yes call (Get_A) # Skip '^' cmp B (char "@") # At-mark? jeq badInputErrB # Yes cmp B (char "?") # Question-mark? if eq # Yes ld B 127 # DEL else and B 31 # Control-character end 10 setc # Return YES ret end cmp B (char "\\") # Backslash? jnz 10 # No call (Get_A) # Skip '\' cmp B 10 # Newline? jnz 10 # No do call (Get_A) # Skip white space cmp B 32 continue eq cmp B 9 until ne loop (code 'anonymousX_FE 0) ld C 0 call symByteCX_FACX # First byte cmp B (char "$") # Starting with '$'? jne Ret # No call symByteCX_FACX # Second byte cmp B (char "1") # >= '1'? if ge # Yes cmp B (char "7") # <= '7'? if le # Yes sub B (char "0") # Digit ld E A # Calculate number call symByteCX_FACX # Third byte do cmp B (char "0") # >= '0'? while ge # Yes cmp B (char "7") # <= '7'? while le # Yes shl E 3 # Times 8 sub B (char "0") # Digit add E A # Add to result call symByteCX_FACX # Next byte? if z # No shl E 4 # Make symbol pointer or E SYM setz ret end loop end end ret (code 'rdAtomBY_E) # X link push (EnvIntern) # Current symbol namespace push ZERO # Result ld C 4 # Build name ld X S link call byteSymBCX_CX # Pack first char ld A Y # Get second do null A # EOF? while ns # No cmp B (char "~") # Tilde? if eq # Yes ld X (L I) # Get name so far call findSymX_E # Find or create symbol ld X 0 # Clear error context atom (E) # Value must be a pair jnz symNsErrEX ld (EnvIntern) E # Switch symbol namespace ld C 4 # Build new name lea X (L I) # Safe ld (X) ZERO else memb Delim "(DelimEnd-Delim)" # Delimiter? break eq # Yes cmp B (char "\\") # Backslash? if eq # Yes call (Get_A) # Get next char end call byteSymBCX_CX # Pack char end call (Get_A) # Get next loop ld X (L I) # Get name ld A (Scl) # Scale shr A 4 # Normalize ld (Sep3) 0 # Thousand separator ld (Sep0) (char ".") # Decimal separator call symToNumXA_FE # Legal number? if nc # No ld X (L I) # Get name call anonymousX_FE # Anonymous symbol? if ne # No ld X (L I) # Get name call findSymX_E # Find or create symbol end end ld (EnvIntern) (L II) # Restore current symbol namespace drop ret (code 'rdList_E) cmp S (StkLimit) # Stack check jlt stkErr call (Get_A) # Skip paren do call skip_A # and white space cmp B (char ")") # Empty list? if eq # Yes call (Get_A) # Skip paren ld E Nil # Return NIL ret end cmp B (char "]") # Empty list? jz retNil # Yes cmp B (char "~") # Tilde? if ne # No ld A 0 call readA_E # Read expression call consE_A # Make a pair ld (A) E ld (A CDR) Nil link push A # Save it link ld E A # Keep last cell in E jmp 10 # Exit end call (Get_A) # Skip tilde ld A 0 call readA_E # Read expression link push E # Save it link eval # Evaluate ld (L I) E # Save again atom E # Pair? if z # Yes do atom (E CDR) # Find last cell while z ld E (E CDR) loop jmp 10 # Exit end drop # Continue loop 10 do call skip_A # Skip white space cmp B (char ")") # Done? if eq # Yes call (Get_A) # Skip paren jmp 90 # Done end cmp B (char "]") # Done? jz 90 # Yes cmp B (char ".") # Dotted pair? if eq # Yes call (Get_A) # Skip dot memb Delim "(DelimEnd-Delim)" # Delimiter? if eq # Yes call skip_A # and white space cmp B (char ")") # Circular list? jz 20 # Yes cmp B (char "]") if eq # Yes 20 ld (E CDR) (L I) # Store list in CDR else push E ld A 0 call readA_E # Read expression ld A E pop E ld (E CDR) A # Store in CDR end call skip_A # Skip white space cmp B (char ")") # Done? if eq # Yes call (Get_A) # Skip paren jmp 90 # Done end cmp B (char "]") jz 90 # Done ld E (L I) # Else bad dottet pair jmp badDotErrE end push X push Y push E ld Y A # Save first char ld B (char ".") # Restore dot call rdAtomBY_E # Read atom call consE_A # Make a pair ld (A) E ld (A CDR) Nil pop E ld (E CDR) A # Store in last cell ld E A pop Y pop X else cmp B (char "~") # Tilde? if ne # No push E ld A 0 call readA_E # Read expression call consE_A # Make a pair ld (A) E ld (A CDR) Nil pop E ld (E CDR) A # Store in last cell ld E A else call (Get_A) # Skip tilde push E ld A 0 call readA_E # Read expression ld A (S) ld (A CDR) E # Save in last cell eval # Evaluate pop A ld (A CDR) E # Store in last cell ld E A do atom (E CDR) # Pair? while z # Yes ld E (E CDR) # Find last cell loop end end loop 90 ld E (L I) # Return list drop ret (code 'readC_E) null (Chr) # Empty channel? if z # Yes call (Get_A) # Fill 'Chr' end cmp C (Chr) # Terminator? if eq # Yes ld E Nil # Return 'NIL' ret end ld A 1 # Read top level expression (code 'readA_E) push X push Y push A # Top flag call skip_A null A # EOF? if s # Yes null (S) # Top? jz eofErr # No: Error ld E Nil # Yes: Return NIL jmp 99 end null (S) # Top? if nz # Yes ld C (InFile) # And reading file? null C if nz # Yes ld (C V) (C IV) # src = line end end cmp B (char "(") # Opening a list? if eq # Yes call rdList_E # Read it null (S) # Top? if nz # Yes cmp (Chr) (char "]") # And super-parentheses? if eq # Yes call (Get_A) # Skip ']' end end jmp 99 # Return list end cmp B (char "[") # Opening super-list? if eq # Yes call rdList_E # Read it cmp (Chr) (char "]") # Matching super-parentheses? jnz suparErrE # Yes: Error call (Get_A) # Else skip ']' jmp 99 end cmp B (char "'") # Quote? if eq # Yes call (Get_A) # Skip "'" ld A (S) call readA_E # Read expression ld C E call consC_E # Cons with 'quote' ld (E) Quote ld (E CDR) C jmp 99 end cmp B (char ",") # Comma? if eq # Yes call (Get_A) # Skip ',' ld A (S) call readA_E # Read expression ld X Uni # Maintain '*Uni' index cmp (X) TSym # Disabled? jeq 99 # Yes link push E # Else save expression link ld Y E call idxPutXY_E atom E # Pair? if z # Yes ld E (E) # Return index entry else ld E Y # 'read' value end drop jmp 99 end cmp B (char "`") # Backquote? if eq # Yes call (Get_A) # Skip '`' ld A (S) call readA_E # Read expression link push E # Save it link eval # Evaluate drop jmp 99 end cmp B (char "\"") # String? if eq # Yes call (Get_A) # Skip '"' cmp B (char "\"") # Empty string? if eq # Yes call (Get_A) # Skip '"' ld E Nil # Return NIL jmp 99 end call testEscA_F jnc eofErr link push ZERO # Result ld C 4 # Build name ld X S link do call byteSymBCX_CX # Pack char call (Get_A) # Get next cmp B (char "\"") # Done? while ne call testEscA_F jnc eofErr loop call (Get_A) # Skip '"' ld X (L I) # Get name ld Y Transient ld E 0 # No symbol yet call internEXY_FE # Check transient symbol drop jmp 99 end cmp B (char "{") # External symbol? if eq # Yes call (Get_A) # Skip '{' cmp B (char "}") # Empty? if eq # Yes call (Get_A) # Skip '}' call cons_E # New symbol ld (E) ZERO # anonymous or E SYM ld (E) Nil # Set to NIL jmp 99 end ld E 0 # Init file number do cmp B (char "@") # File done? while ge # No cmp B (char "O") # In A-O range? jgt badInputErrB # Yes sub B (char "@") shl E 4 # Add to file number add E A call (Get_A) # Get next char loop cmp B (char "0") # Octal digit? jlt badInputErrB cmp B (char "7") jgt badInputErrB # No sub B (char "0") zxt ld C A # Init object ID do call (Get_A) # Get next char cmp B (char "}") # Done? while ne # No cmp B (char "0") # Octal digit? jlt badInputErrB cmp B (char "7") jgt badInputErrB # No sub B (char "0") shl C 3 # Add to object ID add C A loop call (Get_A) # Skip '}' call extNmCE_X # Build external symbol name call externX_E # New external symbol jmp 99 end cmp B (char ")") # Closing paren? jeq badInputErrB # Yes cmp B (char "]") jeq badInputErrB cmp B (char "~") # Tilde? jeq badInputErrB # Yes cmp B (char "\\") # Backslash? if eq # Yes call (Get_A) # Get next char end ld Y A # Save in Y call (Get_A) # Next char xchg A Y # Get first char call rdAtomBY_E # Read atom 99 pop A pop Y pop X ret (code 'tokenCE_E) # X null (Chr) # Look ahead char? if z # No call (Get_A) # Get next end call skipC_A # Skip white space and comments null A # EOF? js retNull # Yes cmp B (char "\"") # String? if eq # Yes call (Get_A) # Skip '"' cmp B (char "\"") # Empty string? if eq # Yes call (Get_A) # Skip '"' ld E Nil # Return NIL ret end call testEscA_F jnc retNil call mkCharA_A # Make single character call consA_X # Cons it ld (X) A ld (X CDR) Nil # with NIL link push X # Result link do call (Get_A) # Get next cmp B (char "\"") # Done? if eq # Yes call (Get_A) # Skip '"' break T end call testEscA_F while c call mkCharA_A # Make char call consA_C # Cons it ld (C) A ld (C CDR) Nil # with NIL ld (X CDR) C # Append to result ld X C loop ld E (L I) # Get result drop ret end cmp B (char "0") # Digit? if ge cmp B (char "9") if le # Yes link push ZERO # Result ld C 4 # Build digit string ld X S link do call byteSymBCX_CX # Pack char call (Get_A) # Get next cmp B (char ".") # Dot? continue eq # Yes cmp B (char "0") # Or digit? while ge cmp B (char "9") until gt # No ld X (L I) # Get name ld A (Scl) # Scale shr A 4 # Normalize drop ld (Sep3) 0 # Thousand separator ld (Sep0) (char ".") # Decimal separator jmp symToNumXA_FE # Convert to number end end push Y push Z ld Y A # Keep char in Y call bufStringE_SZ # Stack buffer push A # String length slen (S) (S I) ld A Y # Restore char cmp B (char "+") # Sign? jeq 90 cmp B (char "-") jeq 90 # Yes cmp B (char "a") # Lower case letter? if ge cmp B (char "z") jle 10 # Yes end cmp B (char "A") # Upper case letter? if ge cmp B (char "Z") jle 10 # Yes end cmp B (char "\\") # Backslash? if eq # Yes call (Get_A) # Use next char jmp 10 end memb (S I) (S) # Member of character set? if eq # Yes 10 link push ZERO # Result ld C 4 # Build name ld X S link do call byteSymBCX_CX # Pack char call (Get_A) # Get next cmp B (char "a") # Lower case letter? if ge cmp B (char "z") continue le # Yes end cmp B (char "A") # Upper case letter? if ge cmp B (char "Z") continue le # Yes end cmp B (char "0") # Digit? if ge cmp B (char "9") continue le # Yes end cmp B (char "\\") # Backslash? if eq # Yes call (Get_A) # Use next char continue T end memb (S IV) (S III) # Member of character set? until ne # No ld X (L I) # Get name call findSymX_E # Find or create symbol drop else 90 call getChar_A call mkCharA_A # Return char ld E A call (Get_A) # Skip it end ld S Z # Drop buffer pop Z pop Y ret # (read ['sym1 ['sym2]]) -> any (code 'doRead 2) atom (E CDR) # Arg? if nz # No ld C 0 # No terminator call readC_E # Read item else push X ld X (E CDR) # Args ld E (X) # Eval 'sym1' eval sym E # Need symbol jz symErrEX link push E # Safe link ld E ((X CDR)) # Eval 'sym2' eval sym E # Need symbol jz symErrEX call firstCharE_A # Get first character ld C A # as comment char ld E (L I) # Get Set of characters call tokenCE_E # Read token null E # Any? ldz E Nil # No drop pop X end cmp (Chr) 10 # Hit linefeed? if eq # Yes cmp (InFile) ((InFiles)) # Current InFile on stdin? if eq # Yes ld (Chr) 0 # Clear it end end ret # Check if input channel has data (code 'inReadyC_F 0) ld A C shl A 3 # Vector index cmp A (InFDs) # 'fd' >= 'InFDs'? jge ret # No add A (InFiles) # Get vector ld A (A) # Slot? null A # Any? jz ret # No cmp (A I) (A II) # Data in buffer ('ix' < 'cnt')? ret # Yes: Return 'c' (code 'fdSetCL_X 0) ld X C # Get fd and C 7 # Shift count ld B 1 # Bit mask shl B C # Shift it shr X 3 # Offset ? (not *LittleEndian) xor X 7 # Invert byte offset = add X L # Point to byte ret (code 'fdRdSetCZL 0) # X cmp Z C # Maintain maximum ldc Z C call fdSetCL_X or (X (- (+ V FD_SET))) B # FD_SET in RdSet ret (code 'fdWrSetCZL 0) # X cmp Z C # Maintain maximum ldc Z C call fdSetCL_X or (X (- (+ V FD_SET FD_SET))) B # FD_SET in WrSet ret (code 'rdSetCL_F 0) # X call fdSetCL_X test (X (- (+ V FD_SET))) B # FD_SET in RdSet ret # Return 'nz' (code 'wrSetCL_F 0) # X call fdSetCL_X test (X (- (+ V FD_SET FD_SET))) B # FD_SET in WrSet ret # Return 'nz' (code 'rdSetRdyCL_F 0) # X ld A C shl A 3 # Vector index cmp A (InFDs) # 'fd' >= 'InFDs'? jge rdSetCL_F # Yes add A (InFiles) # Get vector ld A (A) # Slot? null A # Any? jz rdSetCL_F # No cmp (A I) (A II) # Data in buffer ('ix' < 'cnt')? if z # No push A call rdSetCL_F pop C if nz # Yes call slowNbC_FA # Try non-blocking read jge retnz setz end end ret (code 'waitFdCEX_A) push Y push Z push (EnvTask) # Save task list link push (At) # '@' push ZERO # '*Run' link push C # File descriptor push E # Milliseconds push E # Timeout sub S (+ II FD_SET FD_SET) # Microseconds # Seconds # RdSet # WrSet cmp S (StkLimit) # Stack check jlt stkErrX do ld B 0 # Zero fd sets mset (S) (+ FD_SET FD_SET) push X # Save context ld Z 0 # Maximum fd ld C (L -I) # File descriptor null C # Positive? if ns # Yes call inReadyC_F # Ready? if c # Yes ld (L -III) 0 # Timeout = 0 else call fdRdSetCZL end end ld Y (Run) # Get '*Run' ld (L I) Y # Save it ld (EnvTask) Y do atom Y # '*Run' elements? while z # Yes ld E (Y) # Next element ld A (L IV) # memq in saved tasklist? do atom A # End of tasklist? while z # No cmp E (A) # Member? jeq 10 # Yes: Skip ld A (A CDR) loop ld C (E) # Get fd or timeout value shr C 4 # Negative? if c # Yes ld A ((E CDR)) # Get CADR shr A 4 # Normalize cmp A (L -III) # Less than current timeout? if lt # Yes ld (L -III) A # Set new timeout end else cmp C (L -I) # Different from argument-fd? if ne # Yes call inReadyC_F # Ready? if c # Yes ld (L -III) 0 # Timeout = 0 else call fdRdSetCZL end end end 10 ld Y (Y CDR) loop ld C (Hear) # RPC listener? null C if nz # Yes cmp C (L -I) # Different from argument-fd? if ne # Yes ld A C # Still open? shl A 3 # Vector index add A (InFiles) # Get vector ld A (A) # Slot? null A # Any? if nz # Yes cmp (A I) (A II) # Data in buffer ('ix' < 'cnt')? if nz # Yes ld (L -III) 0 # Timeout = 0 else call fdRdSetCZL end end end end ld C (Spkr) # Speaker open? null C if nz # Yes call fdRdSetCZL ld Y (Child) # Iterate children ld E (Children) # Count do sub E VI # More? while ge # Yes null (Y) # 'pid'? if nz # Yes ld C (Y I) # Child's 'hear' fd call fdRdSetCZL null (Y IV) # Child's buffer count? if nz # Yes ld C (Y II) # Child's 'tell' fd call fdWrSetCZL end end add Y VI # Increment by sizeof(child) loop end pop X # Restore context inc Z # Maximum fd + 1 ld C 0 # Timeval structure pointer ld A (L -III) # Timeout value? null A if ns # Yes div 1000 # Calculate seconds (C is zero) ld (L -V) A ld A C # and microseconds mul 1000 ld (L -IV) A lea C (L -V) # Set timeval structure pointer ? (<> *TargetOS "Linux") # Non-Linux? call msec_A # Get milliseconds ld E A # into E = end do cc select(Z &(S FD_SET) S 0 C) # Wait for event or timeout nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? if ne # No ld (Run) Nil # Clear '*Run' jmp selectErrX end null (Signal) # Signal? if nz # Yes call sighandlerX end loop null C # Timeval structure pointer? if nz # Yes ? (= *TargetOS "Linux") # Linux? ld A (L -V) # Seconds not slept mul 1000 # Calculate milliseconds ld E A ld A (L -IV) # Microseconds not slept div 1000 # Calculate milliseconds add A E # Milliseconds not slept sub (L -III) A # Time difference = ? (<> *TargetOS "Linux") # Else call msec_A # Get milliseconds sub A E # Time difference ld (L -III) A # Save it = end push X # Save context again null (Spkr) # Speaker open? if nz # Yes inc (EnvProtect) # Protect child communication ld Y (Child) # Iterate children ld Z (Children) # Count do sub Z VI # More? while ge # Yes null (Y) # 'pid'? if nz # Yes push Z # Outer loop count ld C (Y I) # Get child's 'hear' fd call rdSetCL_F # Ready? if nz # Yes ld C (Y I) # Get 'hear' fd again ld E 4 # Size of PID and count ld X Buf # Buffer pointer call rdBytesNbCEX_F # Read count? if ge # Yes if z call clsChildY # Close child jmp 20 # Continue end ld4 (Buf) # PID and size? null A if z # No cmp (Y) (Talking) # Currently active? if eq # Yes ld (Talking) 0 # Clear end else sub S PIPE_BUF # Pipe buffer push Y # Outer child index ld C (Y I) # Get 'hear' fd again ld2 (Buf 2) # Get size ld E A lea X (S I) # Buffer pointer call rdBytesCEX_F # Read data? if nz # Yes ld Y (Child) # Iterate children ld Z (Children) # Count do cmp Y (S) # Same as outer loop child? if ne # No null (Y) # 'pid'? if nz # Yes ld2 (Buf) # Get PID null A # Any? jz 15 # Yes cmp A (Y) # Same as 'pid'? if eq # Yes 15 ld2 (Buf 2) # Get size ld C A lea X (S I) # and data call wrChildCXY # Write to child end end end add Y VI # Increment by sizeof(child) sub Z VI # More? until z # No else call clsChildY # Close child pop Y add S PIPE_BUF # Drop 'tell' buffer jmp 20 # Continue end pop Y add S PIPE_BUF # Drop 'tell' buffer end end end ld C (Y II) # Get child's 'tell' fd call wrSetCL_F # Ready? if nz # Yes ld C (Y II) # Get 'tell' fd again ld X (Y V) # Get buffer pointer add X (Y III) # plus buffer offset ld4 (X) # Get size ld E A add X 4 # Point to data (beyond size) push E # Keep size call wrBytesCEX_F # Write data? pop E if z # Yes add E (Y III) # Add size to buffer offset add E 4 # plus size of size ld (Y III) E # New buffer offset add E E # Twice the offset cmp E (Y IV) # greater or equal to buffer count? if ge # Yes sub (Y IV) (Y III) # Decrement count by offset if nz ld X (Y V) # Get buffer pointer add X (Y III) # Add buffer offset movn ((Y V)) (X) (Y IV) # Copy data ld A (Y V) # Get buffer pointer ld E (Y IV) # and new count call allocAE_A # Shrink buffer ld (Y V) A # Store end ld (Y III) 0 # Clear buffer offset end else call clsChildY # Close child end end 20 pop Z end add Y VI # Increment by sizeof(child) loop null (Talking) # Ready to sync? if z # Yes ld C (Spkr) # Get speaker call rdSetCL_F # Anybody? if nz # Yes ld C (Spkr) # Get fd ld E I # Size of slot ld X Buf # Buffer pointer call rdBytesNbCEX_F # Read slot? if gt # Yes ld Y (Child) # Get child add Y (Buf) # in slot ld A (Y) # 'pid'? null A if nz # Yes ld (Talking) A # Set to talking ld C 2 # Size of 'TBuf' ld X TBuf # Buffer pointer call wrChildCXY # Write to child end end end end dec (EnvProtect) end ld C (Hear) # RPC listener? null C if nz # Yes cmp C (L -I) # Different from argument-fd? if ne # Yes call rdSetRdyCL_F # Ready? if nz # Yes call rdHear_FE # Read expression? if nc # Yes cmp E TSym # Read 'T'? if eq # Yes set (Sync) 1 # Set sync flag else link push E # Save expression link call evListE_E # Execute it drop end else ld A (Hear) call closeAX # Close 'Hear' ld A (Hear) call closeInFileA ld A (Hear) call closeOutFileA ld (Hear) 0 # Clear value end end end end ld Y (L I) # Get '*Run' do atom Y # More elements? while z # Yes ld E (Y) # Next element ld A (L IV) # memq in saved tasklist? do atom A # End of tasklist? while z # No cmp E (A) # Member? jeq 30 # Yes: Skip ld A (A CDR) loop ld C (E) # Get fd or timeout value shr C 4 # Negative? if c # Yes ld C (E CDR) # Get CDR ld A (C) # and CADR shr A 4 # Normalize sub A (L -III) # Subtract time difference if gt # Not yet timed out shl A 4 # Make short number or A CNT ld (C) A # Store in '*Run' else # Timed out ld A (E) # Timeout value ld (C) A # Store in '*Run' ld (At) (E) # Set to CAR ld Z (C CDR) # Run body prog Z end else cmp C (L -I) # Different from argument-fd? if ne # Yes call rdSetRdyCL_F # Ready? if nz # Yes ld (At) (E) # Set to fd ld Z (E CDR) # Run body prog Z end end end 30 ld Y (Y CDR) loop pop X # Restore context null (Signal) # Signal? if nz # Yes call sighandlerX end ld A (L -II) # Milliseconds or A A if nsz # Greater zero sub A (L -III) # Subtract time difference if s # < 0 xor A A # Set to zero, 'z' end ld (L -II) A end while nz # Milliseconds non-zero ld (L -III) A # Set timeout ld C (L -I) # File descriptor null C # Positive? while ns # Yes push X call rdSetRdyCL_F # Ready? pop X until nz # Yes ld (At) (L II) # Restore '@' ld A (L -II) # Return milliseconds drop pop (EnvTask) pop Z pop Y ret # (wait ['cnt] . prg) -> any (code 'doWait 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'cnt' eval cmp E Nil # None? if eq # Yes push -1 # Wait infinite else call xCntEX_FE # Get 'cnt' push E # Milliseconds end ld Y (Y CDR) # Y on 'prg' do ld Z Y # Run 'prg' prog Z cmp E Nil # NIL? while eq # Yes ld C -1 # No file descriptor ld E (S) # Milliseconds call waitFdCEX_A # Wait for events null A # Timeout? if z # Yes prog Y # Run 'prg' break T end ld (S) A # New milliseconds loop add S I # Drop milliseconds pop Z pop Y pop X ret # (sync) -> flg (code 'doSync 2) null (Mic) # No 'mic' channel? jz retNil # Yes null (Hear) # No 'hear' channel? jz retNil # Yes nul (Sync) # Already synchronized? jnz retT # Yes push X ld X E ld E Slot # Buffer pointer ld C I # Count do cc write((Mic) E C) # Write 'Slot' to 'Mic' null A # OK? if ns # Yes sub C A # Decrement count break z # Done add E A # Increment buffer pointer else call errno_A cmp A EINTR # Interrupted? jne wrSyncErrX # No null (Signal) # Signal? if nz # Yes call sighandlerX end end loop set (Sync) 0 # Clear sync flag do ld C -1 # No file descriptor ld E C # Wait infinite call waitFdCEX_A # Wait for events nul (Sync) # Synchronized? until nz # Yes ld E TSym # Return T pop X ret # (hear 'cnt) -> cnt (code 'doHear 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it cnt E # # Short number? jz cntErrEX # No ld C E # Get fd shr C 4 # Normalize jc badFdErrEX # Negative ld A C # Keep 'fd' in C shl A 3 # Vector index cmp A (InFDs) # 'fd' >= 'InFDs'? jge badFdErrEX # Yes add A (InFiles) # Get vector ld A (A) # Slot? null A # Any? jz badFdErrEX # No ld A (Hear) # Current value? null A if nz # Yes call closeAX # Close 'Hear' ld A (Hear) call closeInFileA ld A (Hear) call closeOutFileA end ld (Hear) C # Set new value pop X ret # (tell ['cnt] 'sym ['any ..]) -> any (code 'doTell 2) ld A (Tell) # RPC? or A (Children) jz retNil # No push X push Y push Z ld X (E CDR) # Args atom X # Any? if nz # No call unsync # Release sync ld E Nil # Return NIL else push (TellBuf) # Save current 'tell' env sub S PIPE_BUF # New 'tell' buffer ld Z S # Buffer pointer ld E (X) # Eval first argument eval num E # PID argument? if z # No push 0 # Send to all else shr E 4 # Normalize PID push E # Save it ld X (X CDR) # Next arg ld E (X) # Eval eval end call tellBegZ_Z # Start 'tell' message do ld Y E # Keep result call prTellEZ # Print to 'tell' ld X (X CDR) # More args? atom X while z # Yes ld E (X) # Eval next eval loop pop A # Get PID call tellEndAZ # Close 'tell' add S PIPE_BUF # Drop 'tell' buffer pop (TellBuf) ld E Y # Get result end pop Z pop Y pop X ret (code 'fdSetC_Y 0) ld Y (C) # Get fd and Y 7 # Shift count ld B 1 # Bit mask shl B Y # Shift it ld Y (C) # Get fd again shr Y 3 # Offset add Y S # Pointer to byte minus I ret # (poll 'cnt) -> cnt | NIL (code 'doPoll 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it ld A E # Keep call xCntEX_FE # Get fd xchg A E null A # fd < 0? js badFdErrEX # Yes ld C A shl C 3 # Vector index cmp C (InFDs) # 'fd' >= 'InFDs'? jge badFdErrEX # Yes ld C A # Readable input file? shl C 3 # Vector index add C (InFiles) # Get vector ld C (C) # Slot? null C # Any? ldz E Nil # No: Return NIL if nz push Y sub S (+ II FD_SET) # Timeval, RdSet do cmp (C I) (C II) # Data in buffer ('ix' < 'cnt')? while z # No ld B 0 # Zero fd set and timeval mset (S) (+ II FD_SET) call fdSetC_Y or (Y I) B # FD_SET in RdSet ld Y (C) # fd + 1 inc Y do cc select(Y S 0 0 &(S FD_SET)) # Check nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? if ne # No ld (Run) Nil # Clear '*Run' jmp selectErrX end loop call fdSetC_Y test (Y I) B # FD_SET in RdSet ldz E Nil # No: Return NIL while nz call slowNbC_FA # Try non-blocking read until ge add S (+ II FD_SET) pop Y end pop X ret # (key ['cnt]) -> sym (code 'doKey 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it cmp E Nil # None? if eq # Yes ld E -1 # Wait infinite else call xCntEX_FE # Get milliseconds end call flushAll # Flush all output channels call setRaw # Set terminal to raw mode ld C 0 # Standard input call waitFdCEX_A # Wait for events null A # Timeout? if nz # No call stdinByte_A # Read first byte cmp B (hex "FF") # Special "top" character? if ne # No cmp B 128 # Single byte? if ge # No test B (hex "20") # Two bytes? if z # Yes and B (hex "1F") # First byte 110xxxxx shl A 6 # xxxxx000000 push A else # Three bytes and B (hex "F") # First byte 1110xxxx shl A 6 # xxxx000000 push A call stdinByte_A # Read second byte and B (hex "3F") # 10xxxxxx or A (S) # Combine shl A 6 # xxxxxxxxxx000000 ld (S) A end call stdinByte_A # Read last byte and B (hex "3F") # 10xxxxxx or (S) A # Combine pop A # Get result end else ld A TOP end call mkCharA_A # Return char ld E A pop X ret end ld E Nil pop X ret # (peek) -> sym (code 'doPeek 2) ld A (Chr) # Look ahead char? null A if z # No call (Get_A) # Get next end null A # EOF? js retNil # Yes call mkCharA_A # Return char ld E A ret # (char) -> sym # (char 'cnt) -> sym # (char T) -> sym # (char 'sym) -> cnt (code 'doChar 2) push X ld X E ld E (E CDR) # Any args? atom E if nz # No ld A (Chr) # Look ahead char? null A if z # No call (Get_A) # Get next end null A # EOF? if ns # No call getChar_A call mkCharA_A # Make char ld E A call (Get_A) # Get next else ld E Nil end pop X ret end ld E (E) eval # Eval arg cnt E # 'cnt'? if nz # Yes ld A E # Get 'cnt' shr A 4 # Normalize if nz call mkCharA_A # Make char ld E A else ld E Nil end pop X ret end sym E # 'sym'? jz atomErrEX # No cmp E TSym # T? if ne call firstCharE_A shl A 4 # Make short number or A CNT else ld A TOP # Special "top" character call mkCharA_A end ld E A pop X ret # (skip ['any]) -> sym (code 'doSkip 2) ld E ((E CDR)) # Get arg call evSymE_E # Evaluate to a symbol call firstCharE_A # Get first character ld C A # Use as comment char call skipC_A # Skip white space and comments null A # EOF? js retNil # Yes ld A (Chr) # Return 'Chr' call mkCharA_A # Return char ld E A ret # (eol) -> flg (code 'doEol 2) cmp (Chr) 10 # Linefeed? jeq retT # Yes null (Chr) # Chr <= 0? jsz retT # Yes ld E Nil # Return NIL ret # (eof ['flg]) -> flg (code 'doEof 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E Nil # NIL? if eq # Yes ld A (Chr) # Look ahead char? null A if z # No call (Get_A) # Get next end null A # EOF? jns RetNil # No else ld (Chr) -1 # Set EOF end ld E TSym # Return T ret # (from 'any ..) -> sym (code 'doFrom 2) push X push Z ld X (E CDR) # X on args push 0 # End-of-buffers marker do call evSymX_E # Next argument call bufStringE_SZ # Stack buffer push 0 # Index link push E # Symbol link push Z # Buffer chain ld X (X CDR) # More arguments? atom X until nz # No ld A (Chr) # Look ahead char? null A if z # No call (Get_A) # Get next end do null A # EOF? while ns # No ld Z S # Buffer chain do do lea C (Z V) # Stack buffer add C (Z IV) # Index cmp B (C) # Bytes match? if eq # Yes inc (Z IV) # Increment index nul (C 1) # End of string? break nz # No call (Get_A) # Skip next input byte ld E (Z II) # Return matched symbol jmp 90 end null (Z IV) # Still at beginning of string? break z # Yes lea C (Z (+ V 1)) # Offset pointer to second byte do dec (Z IV) # Decrement index while nz cmpn (Z V) (C) (Z IV) # Compare stack buffer while nz inc C # Increment offset loop loop ld Z (Z) # Next in chain null (Z) # Any? until z # No call (Get_A) # Get next input byte loop ld E Nil # Return NIL 90 pop Z # Clean up buffers do drop ld S Z pop Z null Z # End? until z # Yes pop Z pop X ret # (till 'any ['flg]) -> lst|sym (code 'doTill 2) push X push Z ld X (E CDR) # Args call evSymX_E # Evaluate to a symbol call bufStringE_SZ # Stack buffer push A # String length slen (S) (S I) ld A (Chr) # Look ahead char? null A if z # No call (Get_A) # Get next end null A # EOF? if ns # No memb (S I) (S) # Matched first char? if ne # No ld E ((X CDR)) # Eval 'flg' eval cmp E Nil # NIL? if eq # Yes call getChar_A # Get first character call mkCharA_A # Make char call consA_X # Build first cell ld (X) A ld (X CDR) Nil link push X # Result list link do call (Get_A) # Get next null A # EOF? while nsz # No memb (S IV) (S III) # Matched char? while ne # No call getChar_A # Get next character call mkCharA_A call consA_C # Build next cell ld (C) A ld (C CDR) Nil ld (X CDR) C # Append to sublist ld X C loop ld E (L I) # Get result list else link push ZERO # Result ld X S link ld C 4 # Build name do call getChar_A # Get next character call charSymACX_CX # Insert call (Get_A) # Get next null A # EOF? while nsz # No memb (S IV) (S III) # Matched char? until eq # Yes ld X (L I) # Get result name call consSymX_E end drop ld S Z # Drop buffer pop Z pop X ret end end ld E Nil # Return NIL ld S Z # Drop buffer pop Z pop X ret (code 'eolA_F 0) null A # EOF? js retz # Yes cmp A 10 # Linefeed? if ne # No cmp A 13 # Return? jne Ret # No call (Get_A) # Get next cmp A 10 # Linefeed? jnz retz end ld (Chr) 0 # Clear look ahead ret # 'z' # (line 'flg ['cnt ..]) -> lst|sym (code 'doLine 2) ld A (Chr) # Look ahead char? null A if z # No call (Get_A) # Get next end call eolA_F # End of line? jeq retNil # Yes push X push Y push Z ld Y (E CDR) # Y on args ld E (Y) # Eval 'flg' eval cmp E Nil # 'flg' was non-NIL? if ne # Yes: Pack ld Y (Y CDR) # More args? atom Y if nz # No link push ZERO # Result ld X S link ld C 4 # Build name do call getChar_A # Get next character call charSymACX_CX # Insert call (Get_A) # Get next call eolA_F # End of line? until eq # Yes ld X (L I) # Get result name call consSymX_E else call cons_Z # First cell of top list ld (Z) ZERO ld (Z CDR) Nil link push Z # Result link do ld C 4 # Build name ld X Z call getChar_A # Get next character call charSymACX_CX # Insert first char push C ld E (Y) eval # Eval next arg pop C shr E 4 # Normalize do dec E # Decrement count while nz call (Get_A) # Get next call eolA_F # End of line? if eq # Yes ld X (Z) # Get last sub-result call consSymX_E ld (Z) E jmp 20 end call getChar_A # Get next character call charSymACX_CX # Insert loop ld X (Z) # Get last sub-result call consSymX_E ld (Z) E ld Y (Y CDR) # More args? atom Y jnz 10 # No call (Get_A) # Get next call eolA_F # End of line? jeq 20 # Yes call cons_A # New cell to top list ld (A) ZERO ld (A CDR) Nil ld (Z CDR) A ld Z A loop end else call getChar_A # Get first character call mkCharA_A # Make char call consA_Z # Build first cell ld (Z) A ld (Z CDR) Nil link push Z # Result link ld Y (Y CDR) # More args? atom Y if z # Yes ld X Z # Current sublist call cons_Z # First cell of top list ld (Z) X ld (Z CDR) Nil ld (L I) Z # New result do ld E (Y) eval # Eval next arg shr E 4 # Normalize do dec E # Decrement count while nz call (Get_A) # Get next call eolA_F # End of line? jeq 20 # Yes call getChar_A # Get next character call mkCharA_A call consA_C # Build next cell ld (C) A ld (C CDR) Nil ld (X CDR) C # Append to sublist ld X C loop ld Y (Y CDR) # More args? atom Y while z # Yes call (Get_A) # Get next call eolA_F # End of line? jeq 20 # Yes call getChar_A # Get next character call mkCharA_A call consA_X # Build new sublist ld (X) A ld (X CDR) Nil call consX_A # Append to top list ld (A) X ld (A CDR) Nil ld (Z CDR) A ld Z A loop end 10 do call (Get_A) # Get next call eolA_F # End of line? while ne # No call getChar_A # Get next character call mkCharA_A call consA_C # Build next cell ld (C) A ld (C CDR) Nil ld (Z CDR) C # Append ld Z C loop 20 ld E (L I) # Get result end drop pop Z pop Y pop X ret # (lines 'any ..) -> cnt (code 'doLines 2) push X push Y push Z ld X (E CDR) # Args ld Y 0 # Result do atom X # More args? while z # Yes call evSymX_E # Evaluate next file name call pathStringE_SZ # Write to stack buffer cc fopen(S _r_) # Open file ld S Z # Drop buffer null A # OK? if nz # Yes ld E A # File pointer null Y # First hit? if z # Yes ld Y ZERO # Init short number end do cc getc_unlocked(E) # Next char nul4 # EOF? while ns # No cmp A 10 # Linefeed? if eq # Yes add Y (hex "10") # Increment count end loop cc fclose(E) # Close file pointer end ld X (X CDR) loop null Y # Result? ld E Y # Yes ldz E Nil # No pop Z pop Y pop X ret (code 'parseBCE_E) push (EnvParseX) # Save old parser status push (EnvParseC) push (EnvParseEOF) push (Get_A) # Save 'get' status push (Chr) ld E (E TAIL) call nameE_E # Get name link push E # Save it link ld (EnvParseX) E # Set new parser status ld (EnvParseC) 0 ld E 0 null C # Token? if z # No ld E (hex "5D0A00") # linefeed, ']', EOF end ld (EnvParseEOF) E ld (Get_A) getParse_A # Set 'get' status ld (Chr) 0 or B B # Skip? if nz # Yes call getParse_A # Skip first char end null C # Token? if z # No call rdList_E # Read a list else push X push C # Set of characters ld E C # in E ld C 0 # No comment char call tokenCE_E # Read token null E # Any? ldz E Nil if nz # Yes call consE_X # Build first result cell ld (X) E ld (X CDR) Nil link push X # Result link do ld C 0 # No comment char ld E (S III) # Get set of characters push X call tokenCE_E # Next token? pop X null E while nz # Yes call consE_A # Build next result cell ld (A) E ld (A CDR) Nil ld (X CDR) A ld X A loop ld E (L I) # Get result drop end add S I # Drop set pop X end drop pop (Chr) # Retrieve 'get' status pop (Get_A) pop (EnvParseEOF) # Restore old parser status pop (EnvParseC) pop (EnvParseX) ret # (any 'sym) -> any (code 'doAny 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it num E # Need symbol jnz symErrEX sym E jz symErrEX cmp E Nil # NIL? if ne # No push (EnvParseX) # Save old parser status push (EnvParseC) push (EnvParseEOF) push (Get_A) # Save 'get' status push (Chr) ld E (E TAIL) call nameE_E # Get name link push E # Save it link ld (EnvParseX) E # Set new parser status ld (EnvParseC) 0 ld (EnvParseEOF) (hex "2000") # Blank, EOF ld (Get_A) getParse_A # Set 'get' status ld (Chr) 0 call getParse_A # Skip first char ld A 1 # Top level call readA_E # Read expression drop pop (Chr) # Retrieve 'get' status pop (Get_A) pop (EnvParseEOF) # Restore old parser status pop (EnvParseC) pop (EnvParseX) end pop X ret # (sym 'any) -> sym (code 'doSym 2) ld E ((E CDR)) # Eval arg eval link push E # Save link call begString # Start string call printE # Print to string call endString_E # Retrieve result drop ret # (str 'sym ['sym1]) -> lst # (str 'lst) -> sym (code 'doStr 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval cmp E Nil # NIL? if ne # No num E # Number? jnz argErrEX # Yes sym E # Symbol? if nz # Yes link push E # 'sym' link ld X (Y CDR) # Second arg? atom X if nz # No ld C 0 # No token else call evSymX_E # Eval 'sym1' tuck E # Save link ld C E # Get token ld E (L II) # and 'sym' end ld B 0 # Don't skip call parseBCE_E # Parse drop else link push E # Save 'lst' link call begString # Start string ld X E # 'lst' do ld E (X) # Get CAR call printE # Print to string ld X (X CDR) # More items? atom X while z # Yes call space loop call endString_E # Retrieve result drop end end pop Y pop X ret # Read-Eval-Print loop (code 'loadBEX_E) ld C A # Save prompt in C sym E # Symbolic argument? if nz # Yes ld A (E TAIL) call firstByteA_B # starting with "-"? cmp B (char "-") if eq # Yes ld C 0 # No token call parseBCE_E # Parse executable list link push E # Save expression link call evListE_E # Execute it drop ret end end push Y link push (EnvIntern) # Keep current namespace push ZERO # push ZERO # link push C # Prompt sub S IV # InFrame ld Y S call rdOpenEXY call pushInFilesY ld E Nil # Close transient scope call doHide do cmp ((InFiles)) (InFile) # Reading from file? if ne # Yes ld C 0 # No terminator call readC_E # Read expression else null (L -I) # Prompt? if nz # Yes null (Chr) if z ld E (Prompt) # Output prompt prefix call runE_E # Execute call prinE_E ld A (L -I) # Output prompt call (PutB) call space call flushAll end end ld C 10 # Linefeed terminator cc isatty(0) # STDIN nul4 # on a tty? ldz C 0 # No call readC_E # Read expression ld A (Chr) do null A # EOF? while nsz # No cmp B 10 # Linefeed? if eq # Yes ld (Chr) 0 # Clear it break T end cmp B (char "#") # Comment char? if eq # Yes call comment_A # Skip comment else cmp B 32 # White space? break gt # No call (Get_A) end loop end cmp E Nil while ne ld (L I) E # Save read expression cmp ((InFiles)) (InFile) # Reading from file? if nz # Yes 10 eval # Evaluate else null (Chr) # Line? jnz 10 # Yes ld A (L -I) or B B # Prompt? jz 10 # No call flushAll ld (L II) (At) # Save '@' eval # Evaluate ld (At) E # Save result ld (At3) (At2) ld (At2) (L II) # Retrieve previous '@' ld C Arrow call outStringC call flushAll call printE_E call newline end ld (L I) E # Save result loop ld (EnvIntern) (L III) # Restore namespace call popInFiles ld E Nil # Close transient scope call doHide ld E (L I) drop pop Y ret # (load 'any ..) -> any (code 'doLoad 2) push X push Y ld X E ld Y (E CDR) # Y on args do ld E (Y) # Eval arg eval cmp E TSym # Load remaining command line args? if ne # No ld B (char ">") # Prompt call loadBEX_E else call loadAllX_E end ld Y (Y CDR) # More args? atom Y until nz # No pop Y pop X ret # (in 'any . prg) -> any (code 'doIn 2) push X push Y ld X E # Expression in X ld E (E CDR) ld E (E) # Eval 'any' eval sub S IV # InFrame ld Y S call rdOpenEXY call pushInFilesY ld X ((X CDR) CDR) # Get 'prg' prog X call popInFiles add S IV # Drop InFrame pop Y pop X ret # (out 'any . prg) -> any (code 'doOut 2) push X push Y ld X E # Expression in X ld E (E CDR) ld E (E) # Eval 'any' eval sub S IV # OutFrame ld Y S call wrOpenEXY call pushOutFilesY ld X ((X CDR) CDR) # Get 'prg' prog X call popOutFiles add S IV # Drop InFrame pop Y pop X ret # (err 'sym . prg) -> any (code 'doErr 2) push X push Y ld X E # Expression in X ld E (E CDR) ld E (E) # Eval 'any' eval sub S II # ErrFrame ld Y S call erOpenEXY call pushErrFilesY ld X ((X CDR) CDR) # Get 'prg' prog X call popErrFiles add S II # Drop ErrFrame pop Y pop X ret # (ctl 'sym . prg) -> any (code 'doCtl 2) push X push Y ld X E # Expression in X ld E (E CDR) ld E (E) # Eval 'any' eval sub S II # CtlFrame ld Y S call ctOpenEXY call pushCtlFilesY ld X ((X CDR) CDR) # Get 'prg' prog X call popCtlFiles add S II # Drop CtlFrame pop Y pop X ret # (pipe exe) -> cnt # (pipe exe . prg) -> any (code 'doPipe 2) push X push Y ld X E # Expression in X sub S IV # In/OutFrame ld Y S push A # Create 'pipe' structure cc pipe(S) # Open pipe nul4 # OK? jnz pipeErrX ld4 (S) # Get pfd[0] call closeOnExecAX ld4 (S 4) # Get pfd[1] call closeOnExecAX call forkLispX_FE # Fork child process if c # In child atom ((X CDR) CDR) # 'prg'? if z # Yes cc setpgid(0 0) # Set process group end ld4 (S) # Close read pipe call closeAX ld4 (S 4) # Get write pipe cmp A 1 # STDOUT_FILENO? if ne # No cc dup2(A 1) # Dup to STDOUT_FILENO ld4 (S 4) # Close write pipe call closeAX end ld E Nil # Standard output call wrOpenEXY call pushOutFilesY ld ((OutFile) II) 0 # Clear 'tty' ld (Run) Nil # Switch off all tasks ld E ((X CDR)) # Get 'exe' eval # Evaluate it ld E 0 # Exit OK jmp byeE end ld (Y II) E # Set 'pid' ld4 (S 4) # Close write pipe call closeAX ld4 (S) # Get read pipe call initInFileA_A ld E (A) # Get file descriptor ld X ((X CDR) CDR) # Get 'prg' atom X # Any? if nz # No shl E 4 # In parent or E CNT # Return PID else ld (Y I) E # Save 'fd' cc setpgid((Y II) 0) # Set process group call pushInFilesY prog X call popInFiles end add S (+ 8 IV) # Drop 'pipe' structure and In/OutFrame pop Y pop X ret # (open 'any ['flg]) -> cnt | NIL (code 'doOpen 2) push X push Z ld X E ld E ((E CDR)) # Get arg call evSymE_E # Evaluate to a symbol call pathStringE_SZ # Write to stack buffer ld E (((X CDR) CDR)) # Get flg eval cmp E Nil # Read-only? ldnz E O_RDONLY # Yes ldz E (| O_CREAT O_RDWR) # No do cc open(S E (oct "0666")) # Try to open nul4 # OK? while s # No call errno_A cmp A EINTR # Interrupted? if ne # No ld E Nil # Return NIL jmp 90 end null (Signal) # Signal? if nz # Yes call sighandlerX end loop ld X A # Keep 'fd' call closeOnExecAX ld C X # 'fd' cc strdup(S) # Duplicate name call initInFileCA_A # Init input file structure ld A X # 'fd' again call initOutFileA_A # Init output file structure ld E X # Return 'fd' shl E 4 # Make short number or E CNT 90 ld S Z # Drop buffer pop Z pop X ret # (close 'cnt) -> cnt | NIL (code 'doClose 2) push X ld X E ld E ((E CDR)) # Eval 'cnt' eval ld C E # Keep in E call xCntCX_FC # Get fd do cc close(C) # Close it nul4 # OK? while nz # No call errno_A cmp A EINTR # Interrupted? if ne # No ld E Nil # Return NIL pop X ret end null (Signal) # Signal? if nz # Yes call sighandlerX end loop ld A C # Close InFile call closeInFileA ld A C # Close OutFile call closeOutFileA pop X ret # (echo ['cnt ['cnt]] | ['sym ..]) -> sym (code 'doEcho 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval ld Y (Y CDR) # Next arg ld A (Chr) # Look ahead char? null A if z # No call (Get_A) # Get next end cmp E Nil # Empty arg? if eq # Yes atom Y # No further args? if nz # Yes do null A # EOF? while ns # No call (PutB) # Output byte call (Get_A) # Get next loop ld E TSym # Return T pop Y pop X ret end end num E # Number? if nz # Yes call xCntEX_FE # Get 'cnt' atom Y # Second 'cnt' arg? if z # Yes ld Y (Y) # Get second 'cnt' xchg Y E # First 'cnt' in Y call evCntEX_FE # Evaluate second ld A (Chr) # Get Chr again do dec Y # Decrement first 'cnt' while ns null A # EOF? if s # Yes ld E Nil # Return NIL pop Y pop X ret end call (Get_A) # Get next loop end null E # 'cnt'? if nsz # Yes do null A # EOF? if s # Yes ld E Nil # Return NIL pop Y pop X ret end call (PutB) # Output byte dec E # Decrement 'cnt' while nz call (Get_A) # Get next loop end ld (Chr) 0 # Clear look ahead ld E TSym # Return T pop Y pop X ret end sym E # Need symbol jz argErrEX push Z push 0 # End-of-buffers marker do call bufStringE_SZ # Stack buffer push 0 # Index link push E # Symbol link push Z # Buffer chain atom Y # More arguments? while z # Yes call evSymY_E # Next argument ld Y (Y CDR) loop ld X 0 # Clear current max ld A (Chr) # Look ahead char do null A # EOF? while ns # No ld Y X # Output max null Y # Any? if nz # Yes ld E (Y IV) # Set output index end ld Z S # Buffer chain do do lea C (Z V) # Stack buffer add C (Z IV) # Index cmp B (C) # Bytes match? if eq # Yes inc (Z IV) # Increment index nul (C 1) # End of string? if nz # No null X # Current max? if z # No ld X Z else cmp (X IV) (Z IV) # Smaller than index? ldc X Z # Yes end break T end null Y # Output max? if nz # Yes lea C (Y V) # Buffer of output max sub E (Z IV) # Diff to current index do # Done? while ge # No ld B (C) call (PutB) # Output bytes inc C sub E 1 loop end ld (Chr) 0 # Clear look ahead ld E (Z II) # Return matched symbol jmp 90 end null (Z IV) # Still at beginning of string? break z # Yes lea C (Z (+ V 1)) # Offset pointer to second byte do dec (Z IV) # Decrement index while nz cmpn (Z V) (C) (Z IV) # Compare stack buffer while nz inc C # Increment offset loop cmp X Z # On current max? if eq # Yes ld X 0 # Clear current max ld C S # Buffer chain do null (C IV) # Index? if nz # Yes null X # Current max? if z # No ld X C else cmp (X IV) (C IV) # Smaller than index? ldc X C # Yes end end ld C (C) # Next in chain null (C) # Any? until z # No end loop ld Z (Z) # Next in chain null (Z) # Any? until z # No null X # Current max? if z # No null Y # Output max? if nz push A # Save current byte push E # and output index lea C (Y V) # Buffer of output max do ld B (C) call (PutB) # Output bytes inc C dec E # Done? until z # Yes pop E pop A end call (PutB) # Output current byte else null Y # Output max? if nz lea C (Y V) # Buffer of output max sub E (X IV) # Diff to current max index do # Done? while ge # No ld B (C) call (PutB) # Output bytes inc C sub E 1 loop end end call (Get_A) # Get next input byte loop ld E Nil # Return NIL 90 pop Z # Clean up buffers do drop ld S Z pop Z null Z # End? until z # Yes pop Z pop Y pop X ret (code 'putStdoutB 0) push Y ld Y (OutFile) # OutFile? null Y if nz # Yes push E push X ld E (Y I) # Get 'ix' lea X (Y III) # Buffer pointer cmp E BUFSIZ # Reached end of buffer? if eq # Yes push A push C ld (Y I) 0 # Clear 'ix' ld C (Y) # Get 'fd' call wrBytesCEX_F # Write buffer ld E 0 # Get 'ix' lea X (Y III) # Buffer pointer pop C pop A end add X E # Buffer index ld (X) B # Store byte inc E # Increment ix ld (Y I) E # Store 'ix' cmp B 10 # Linefeed? if eq # Yes null (Y II) # and 'tty'? if nz # Yes push C ld (Y I) 0 # Clear 'ix' ld C (Y) # Get 'fd' lea X (Y III) # Buffer pointer call wrBytesCEX_F # Write buffer pop C end end pop X pop E end pop Y ret (code 'newline) ld B 10 jmp (PutB) (code 'space) ld B 32 jmp (PutB) # Output decimal number (code 'outNumE) shr E 4 # Normalize if c # Sign ld B (char "-") # Output sign call (PutB) end ld A E (code 'outWordA) cmp A 9 # Single digit? if gt # No ld C 0 # Divide by 10 div 10 push C # Save remainder call outWordA # Recurse pop A end add B (char "0") # Make ASCII digit jmp (PutB) (code 'prExtNmX) call fileObjX_AC # Get file and object ID null A # File? if nz # Yes call outAoA # Output file number end ld A C # Get object ID # Output octal number (code 'outOctA 0) cmp A 7 # Single digit? if gt # No push A # Save shr A 3 # Divide by 8 call outOctA # Recurse pop A and B 7 # Get remainder end add B (char "0") # Make ASCII digit jmp (PutB) # Output A-O encoding (code 'outAoA 0) cmp A 15 # Single digit? if gt # No push A # Save shr A 4 # Divide by 16 call outAoA # Recurse pop A and B 15 # Get remainder end add B (char "@") # Make ASCII letter jmp (PutB) (code 'outStringS) # C lea C (S I) # Buffer above return address (code 'outStringC) do ld B (C) # Next char inc C or B B # Null? while ne # No call (PutB) loop ret (code 'outNameE) push X ld X (E TAIL) call nameX_X # Get name call prNameX # Print it pop X ret (code 'prNameX) ld C 0 do call symByteCX_FACX # Next byte while nz call (PutB) # Output byte loop ret # Print one expression (code 'printE_E) link push E # Save expression link call printE # Print it ld E (L I) # Restore drop ret (code 'printE 0) cmp S (StkLimit) # Stack check jlt stkErr null (Signal) # Signal? if nz # Yes call sighandler0 end cnt E # Short number? jnz outNumE # Yes big E # Bignum? if nz # Yes ld A -1 # Scale jmp fmtNum0AE_E # Print it end push X sym E # Symbol? if nz # Yes ld X (E TAIL) call nameX_X # Get name cmp X ZERO # Any? if eq # No ld B (char "$") # $xxxxxx call (PutB) shr E 4 # Normalize symbol pointer ld A E call outOctA pop X ret end sym (E TAIL) # External symbol? if nz # Yes ld B (char "{") # {AB123} call (PutB) call prExtNmX # Print it ld B (char "}") call (PutB) pop X ret end push Y ld Y ((EnvIntern)) call isInternEXY_F # Internal symbol? if eq # Yes cmp X (hex "2E2") # Dot? if eq # Yes ld B (char "\\") # Print backslash call (PutB) ld B (char ".") # Print dot call (PutB) else ld C 0 call symByteCX_FACX # Get first byte cmp B (char "#") # Hash? if eq ld B (char "\\") # Print backslash call (PutB) ld B (char "#") # Restore Hash end do cmp B (char "\\") # Backslash? jeq 10 # Yes memb Delim "(DelimEnd-Delim)" # Delimiter? if eq # Yes 10 push A # Save char ld B (char "\\") # Print backslash call (PutB) pop A end call (PutB) # Put byte call symByteCX_FACX # Next byte until z # Done end else # Else transient symbol ld Y 0 # 'tsm' flag in Y atom (Tsm) # Transient symbol markup? if z # Yes cmp (PutB) putStdoutB # to stdout? if eq # No ld Y ((OutFile) II) # and 'tty'? -> Y end end null Y # Transient symbol markup? if z # No ld B (char "\"") call (PutB) else ld E ((Tsm)) # Get CAR call outNameE # Write transient symbol markup end ld C 0 call symByteCX_FACX # Get first byte do cmp B (char "\\") # Backslash? jeq 20 cmp B (char "\^") # Caret? jeq 20 null Y # Transient symbol markup? jnz 30 # Yes cmp B (char "\"") # Double quote? if eq # Yes 20 push A # Save char ld B (char "\\") # Escape with backslash call (PutB) pop A else 30 cmp B 127 # DEL? if eq # Yes ld B (char "\^") # Print ^? call (PutB) ld B (char "?") else cmp B 32 # White space? if lt # Yes push A # Save char ld B (char "\^") # Escape with caret call (PutB) pop A or A 64 # Make printable end end end call (PutB) # Put byte call symByteCX_FACX # Next byte until z # Done null Y # Transient symbol markup? if z # No ld B (char "\"") # Final double quote call (PutB) else ld E ((Tsm) CDR) # Get CDR call outNameE # Write transient symbol markup end end pop Y pop X ret end # Print list cmp (E) Quote # CAR 'quote'? if eq # Yes cmp E (E CDR) # Circular? if ne # No ld B (char "'") # Print single quote call (PutB) ld E (E CDR) # And CDR call printE pop X ret end end push Y ld B (char "(") # Open paren call (PutB) ld X E # Keep list in X call circE_YF # Circular? if nz # No do ld E (X) # Print CAR call printE ld X (X CDR) # NIL-terminated? cmp X Nil while ne # No atom X # Atomic tail? if nz # Yes call space # Print " . " ld B (char ".") call (PutB) call space ld E X # and the atom call printE break T end call space # Print space loop else cmp X Y # Fully circular? if eq # Yes do ld E (X) # Print CAR call printE call space # and space ld X (X CDR) # Done? cmp X Y until eq # Yes ld B (char ".") # Print "." call (PutB) else do # Non-circular part ld E (X) # Print CAR call printE call space # and space ld X (X CDR) # Done? cmp X Y until eq # Yes ld B (char ".") # Print ". (" call (PutB) call space ld B (char "(") call (PutB) do # Circular part ld E (X) # Print CAR call printE call space # and space ld X (X CDR) # Done? cmp X Y until eq # Yes ld B (char ".") # Print ".)" call (PutB) ld B (char ")") call (PutB) end end ld B (char ")") # Closing paren call (PutB) pop Y pop X ret # Print string representation (code 'prinE_E 0) link push E # Save expression link call prinE # Print it ld E (L I) # Restore drop ret (code 'prinE 0) cmp S (StkLimit) # Stack check jlt stkErr null (Signal) # Signal? if nz # Yes call sighandler0 end cmp E Nil # NIL? if ne # No cnt E # Short number? jnz outNumE # Yes big E # Bignum? if nz # Yes ld A -1 # Scale jmp fmtNum0AE_E # Print it end push X sym E # Symbol? if nz # Yes ld X (E TAIL) call nameX_X # Get name cmp X ZERO # Any? if ne # Yes sym (E TAIL) # External symbol? if z # No call prNameX else ld B (char "{") # {AB123} call (PutB) call prExtNmX # Print it ld B (char "}") call (PutB) end end else ld X E # Get list in X do ld E (X) # Prin CAR call prinE ld X (X CDR) # Next cmp X Nil # NIL-terminated? while ne # No atom X # Done? if nz # Yes ld E X # Print atomic rest call prinE break T end loop end pop X end ret # (prin 'any ..) -> any (code 'doPrin 2) push X ld X (E CDR) # Get arguments do ld E (X) eval # Eval next arg call prinE_E # Print string representation ld X (X CDR) # More arguments? atom X until nz # No pop X ret # (prinl 'any ..) -> any (code 'doPrinl 2) call doPrin # Print arguments jmp newline (code 'doSpace 2) push X ld X E ld E ((E CDR)) # Eval 'cnt' eval cmp E Nil # NIL? if eq # Yes call space # Output single space ld E ONE # Return 1 else ld C E # Keep in E call xCntCX_FC # Get cnt do dec C # 'cnt' times while ns call space # Output spaces loop end pop X ret # (print 'any ..) -> any (code 'doPrint 2) push X ld X (E CDR) # Get arguments do ld E (X) eval # Eval next arg call printE_E # Print it ld X (X CDR) # More arguments? atom X while z # Yes call space # Print space loop pop X ret # (printsp 'any ..) -> any (code 'doPrintsp 2) push X ld X (E CDR) # Get arguments do ld E (X) eval # Eval next arg call printE_E # Print it call space # Print space ld X (X CDR) # More arguments? atom X until nz # No pop X ret # (println 'any ..) -> any (code 'doPrintln 2) call doPrint # Print arguments jmp newline # (flush) -> flg (code 'doFlush 2) ld A (OutFile) # Flush OutFile call flushA_F # OK? ld E TSym # Yes ldnz E Nil ret # (rewind) -> flg (code 'doRewind 2) ld E Nil # Preload return value ld C (OutFile) # OutFile? null C if nz # Yes ld (C I) 0 # Clear 'ix' cc lseek((C) 0 SEEK_SET) # Seek to beginning of file null A # OK? if z # Yes cc ftruncate((C) 0) # Truncate file nul4 # OK? ldz E TSym # Return T end end ret # (ext 'cnt . prg) -> any (code 'doExt 2) push X push Y ld X E ld Y (E CDR) # Y on args call evCntXY_FE # Eval 'cnt' push (ExtN) # Save external symbol offset ld (ExtN) E # Set new ld X (Y CDR) # Run 'prg' prog X pop (ExtN) # Restore external symbol offset pop Y pop X ret # (rd ['sym]) -> any # (rd 'cnt) -> num | NIL (code 'doRd 2) push X push Z link push ZERO # Result link ld E ((E CDR)) # Get arg eval # Eval it ld Z (InFile) # Current InFile? null Z if nz # Yes cnt E # Read raw bytes? if z # No ld (L I) E # EOF ld (GetBinZ_FB) getBinaryZ_FB # Set binary read function ld (Extn) (ExtN) # Set external symbol offset call binReadZ_FE # Read item? ldc E (L I) # No: Return EOF else shr E 4 # Normalize jz 90 # Zero if c # Little endian lea X (L I) # X on result ld C 3 # Build signed number do call getBinaryZ_FB # Enough bytes? jc 90 # No call byteNumBCX_CX # Add next byte to number dec E # Done? until z # Yes ld A (L I) # Get result cnt A # Short number? if nz # Yes call twiceA_A # Double it end else ld X E # Count in X do call getBinaryZ_FB # Enough bytes? jc 90 # No zxt push A # Save byte ld A (L I) # Multiply number by 256 ld E (hex "1002") call muluAE_A ld (L I) A # Save digit pop E # Get digit shl E 4 # Make short number or E CNT call adduAE_A # Add to number ld (L I) A # Save again dec X # Done? until z # Yes end big A # Bignum? if nz # Yes call zapZeroA_A # Remove leading zeroes end ld E A # Get result end else 90 ld E Nil # Return NIL end drop pop Z pop X ret # (pr 'any ..) -> any (code 'doPr 2) push X ld X (E CDR) # Get arguments do ld E (X) eval # Eval next arg push E # Keep ld (Extn) (ExtN) # Set external symbol offset call prE # Print binary pop E ld X (X CDR) # More arguments? atom X until nz # No pop X ret # (wr 'cnt ..) -> cnt (code 'doWr 2) push X ld X (E CDR) # Args do ld E (X) # Eval next eval ld A E # Get byte shr A 4 # Normalize call putStdoutB # Output ld X (X CDR) # X on rest atom X # Done? until nz # Yes pop X ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/lib/0000755000000000000000000000000012265263724014657 5ustar rootrootpicolisp-3.1.5.2.orig/src64/lib/asm.l0000644000000000000000000004306312265263724015622 0ustar rootroot# 05jan13abu # (c) Software Lab. Alexander Burger # *LittleEndian *AlignedCode *Registers optimize # *FPic *Section *Label *Tags *Map *Program *Statement # *Instructions *IfStack *DoStack # "*Mode" "*Modes" (de *Transfers call jmp jz jeq jnz jne js jns jsz jnsz jc jlt jnc jge jcz jle jncz jgt ) (de *Conditions (T jmp . jmp) (z jz . jnz) (nz jnz . jz) (s js . jns) (ns jns . js) (sz jsz . jnsz) (nsz jnsz . jsz) (c jc . jnc) (nc jnc . jc) (cz jcz . jncz) (ncz jncz . jcz) (eq jz . jnz) (ne jnz . jz) (lt jc . jnc) (le jcz . jncz) (gt jncz . jcz) (ge jnc . jc) ) (de build ("File" "Map" . "Prg") (off *Section *Tags *Map *IfStack *DoStack) (out "File" (prinl "/* " (datSym (date)) " */") (prolog "File") (run "Prg") (epilog "File") ) (when "Map" (out "tags" (for Lst (group # (file (line . sym) (line . sym) ..) (mapcar '((This) (cons (pack (: src 1) (: src 2)) (: src -2) This ) ) (idx '*Tags) ) ) (let Tags (in (car Lst) (let (Line 1 Ofs 0) (mapcar '((X) (do (- (car X) Line) (inc 'Ofs (inc (size (line T)))) ) (pack `(pack "^J" (char 127)) (cdr X) (char 1) (setq Line (car X)) "," Ofs ) ) (sort (cdr Lst)) ) ) ) (prinl "^L^J" (car Lst) "," (sum size Tags) Tags) ) ) ) (out "Map" (for Sym (idx '*Map) (and (sym? (val Sym)) (; Sym 0 tag) (prinl Sym " (" (cdr @) " . \"@src64/" (car @) "\")") ) ) ) ) ) (de asm Args (def (car Args) 'asm (cdr Args)) ) (de idxTags (Lbl Src) (when Src (idx '*Tags (def Lbl 'src @) T) ) ) # Sections (de section (Fun @Sym) (def Fun (curry (@Sym) (Lbl Align) (newSection '@Sym) (and Align (alignSection @)) (when Lbl (and (reg Lbl) (quit "Register" Lbl)) (let Src (file) (idxTags Lbl Src) (def Lbl 'tag (cdr Src)) ) (label (setq *Label Lbl) T) ) (setq *Program (make (while (and (skip "#") (<> "(" (peek))) (let Atom (read) (cond ((== ': Atom) # Label (let Lbl (read) (idxTags Lbl (file)) (link (cons Atom Lbl)) ) ) ((== '? Atom) # Conditional (unless (eval (read)) (while (and (skip "#") (n== '= (read)))) ) ) ((== '= Atom)) # Conditional end ((num? Atom) (link (cons ': (pack *Label "_" Atom))) ) ((lup *FlowControl Atom) ((; Atom asm) (eval (cadr @))) ) ((lup *Instructions Atom) (link (cons Atom (mapcar eval (cdr @)))) ) (T (quit "Bad instruction" Atom)) ) ) ) ) ) (when (or *IfStack *DoStack) (quit "Unbalanced flow") ) (cleanUp) (setq *Program (make (for (L *Program L) (ifn (optimize L) (link (pop 'L)) (setq L (nth L (inc (car @)))) (chain (cdr @)) ) ) ) ) (for *Statement *Program (if (== ': (car *Statement)) (label (cdr *Statement)) (apply (; (car *Statement) asm) (cdr *Statement)) ) ) ) ) ) # (data 'lbl) # (data 'lbl 0) (section 'data 'data) # (code 'lbl) # (code 'lbl 0) # (code 'lbl 2) (section 'code 'text) (de cleanUp () (use (L1 L2) (while # Remove duplicate labels (seek '((L) (and (== ': (caar L)) (== ': (caadr L)) (cond ((= `(char ".") (char (setq L1 (cdar L)))) (setq L2 (cdadr L)) ) ((= `(char ".") (char (setq L1 (cdadr L)))) (setq L2 (cdar L)) ) ) ) ) *Program ) (setq *Program (mapcan '((L) (cond ((<> L1 ((if (atom (cdr L)) cdr cadr) L)) (cons L) ) ((memq (car L) *Transfers) (cons (list (car L) L2)) ) ) ) *Program ) ) ) (while # Remove jmp-only labels (seek '((L) (and (== ': (car (setq L1 (car L)))) (= `(char ".") (char (cdr L1))) (== 'jmp (car (setq L2 (cadr L)))) ) ) *Program ) (setq *Program (mapcan '((L) (unless (== L L1) (cons (if (and (memq (car L) *Transfers) (= (cdr L1) (cadr L)) ) (list (car L) (cadr L2)) L ) ) ) ) *Program ) ) ) ) (setq *Program # Remove unreachable statements (make (while *Program (when (memq (car (link (pop '*Program))) '(jmp ret eval/ret)) (while (and *Program (n== ': (caar *Program))) (pop '*Program) ) ) ) ) ) (setq *Program # Remove zero jumps (make (while *Program (let P (pop '*Program) (unless (and (memq (car P) (cdr *Transfers)) (== ': (caar *Program)) (= (cadr P) (cdar *Program)) ) (link P) ) ) ) ) ) (setq *Program # Toggle inverted jumps (make (while *Program (let P (pop '*Program) (ifn (and (memq (car P) (cddr *Transfers)) (== 'jmp (caar *Program)) (== ': (caadr *Program)) (= (cadr P) (cadr (cadr *Program))) ) (link P) (link (list (cddr (find '((C) (== (car P) (cadr C))) (cdr *Conditions) ) ) (cadr (pop '*Program)) ) ) ) ) ) ) ) ) # Registers (de reg (X) (cdr (asoq X *Registers)) ) # Operand evaluation (de operand (X) (cond ((num? X) X) ((sym? X) (cond ((asoq X *Registers) X) ((; X equ) @) (T X) ) ) ((asoq (car X) *Registers) (cons (car X) (operand (cadr X))) ) ((memq (car X) '(+ - * */ / % >> & | %% pack short char hex oct)) (apply (car X) (mapcar operand (cdr X))) ) (T (cons (car X) (operand (cadr X)))) ) ) # Constants (de %% (N) (>> -3 (>> 3 (+ N 7))) ) (de short (N) (| 2 (>> -4 N)) ) (de equ Args (idxTags (car Args) (file)) (let Val (run (cdr Args) 1) (def (car Args) 'equ Val) (def (car Args) Val) ) ) # Source/Destination addressing mode: # 0 -> Immediate # NIL -> Register # T -> Direct # (..) -> Combined (de "source" (X F) (setq X (operand X)) (cond ((num? X) # Immediate (zero "*Mode") (pack (and F "~") X) ) ((reg X) (off "*Mode") @) # Register ((atom X) (on "*Mode") X) # Direct ((or (num? (cdr X)) (; (cdr X) equ)) (prog1 (cons ("source" (car X) F) @) (setq "*Mode" (cons "*Mode" 0)) ) ) ((cdr X) (and (reg (cdr X)) (quit "Bad source" X)) (prog1 (cons ("source" (car X) F) @) (setq "*Mode" (cons "*Mode" T)) ) ) (T (prog1 (cons ("source" (car X) F)) (setq "*Mode" (cons "*Mode")) ) ) ) ) (de source (F) ("source" (read) F) ) (de sources () (off "*Modes") (let Arg (read) (if (lst? Arg) (mapcar '((X) (prog1 ("source" X) (queue '"*Modes" "*Mode") ) ) Arg ) ("source" Arg) ) ) ) (de "destination" (X F) (setq X (operand X)) (cond ((num? X) (quit "Bad destination" X)) # Immediate ((reg X) (off "*Mode") @) # Register ((atom X) # Direct (or F (quit "Bad destination" X)) (on "*Mode") X ) ((or (num? (cdr X)) (; (cdr X) equ)) (prog1 (cons ("destination" (car X) T) @) (setq "*Mode" (cons "*Mode" 0)) ) ) ((cdr X) (and (reg (cdr X)) (quit "Bad destination" X)) (prog1 (cons ("destination" (car X) T) (cdr X)) (setq "*Mode" (cons "*Mode" T)) ) ) (T (prog1 (cons ("destination" (car X) T)) (setq "*Mode" (cons "*Mode")) ) ) ) ) (de destination () ("destination" (read)) ) (de destinations () (off "*Modes") (mapcar '((X) (prog1 ("destination" X) (queue '"*Modes" "*Mode") ) ) (read) ) ) # Target addressing mode: # NIL -> Absolute # 0 -> Indexed # (0) -> SUBR # T -> Indirect (de address () (let X (read) (off "*Mode") (cond ((num? X) (pack *Label "_" X)) # Label ((reg X) (quit "Bad address" X)) # Register ((atom X) X) # Absolute ((and (=T (cadr X)) (reg (car X))) # SUBR (setq "*Mode" (0)) @ ) ((cdr X) (quit "Bad address" X)) ((reg (car X)) (zero "*Mode") @) # Register indirect (T (on "*Mode") (car X)) ) ) ) # Indirect # Flow control (balance '*FlowControl (quote (break (read)) (continue (read)) (do) (else) (end) (if (read)) (loop) (until (read)) (while (read)) ) ) (de flowCondition (Sym Lbl Neg) (if ((if Neg cddr cadr) (asoq Sym *Conditions)) (link (list @ Lbl)) (quit "Bad condition" Sym) ) ) (de flowLabel () (pack "." (inc (0))) ) (asm if (Sym) (flowCondition Sym (push '*IfStack (flowLabel)) T) ) (asm else () (let Lbl (car *IfStack) (link (list 'jmp (set *IfStack (flowLabel))) (cons ': Lbl) ) ) ) (asm end () (link (cons ': (pop '*IfStack))) ) (asm do () (link (cons ': (push '*DoStack (flowLabel)))) ) (asm while (Sym) (flowCondition Sym (if (pair (car *DoStack)) (car @) (push *DoStack (flowLabel)) ) T ) ) (asm until (Sym) (let X (pop '*DoStack) (flowCondition Sym (fin X) T) (and (pair X) (link (cons ': (car X)))) ) ) (asm break (Sym) (flowCondition Sym (if (pair (car *DoStack)) (car @) (push *DoStack (flowLabel)) ) ) ) (asm continue (Sym) (flowCondition Sym (fin (car *DoStack))) ) (asm loop () (let X (pop '*DoStack) (link (list 'jmp (fin X))) (and (pair X) (link (cons ': (car X)))) ) ) # Instruction set (balance '*Instructions (quote (add (destination) "*Mode" (source) "*Mode") (addc (destination) "*Mode" (source) "*Mode") (align (operand (read))) (and (destination) "*Mode" (source) "*Mode") (ascii (operand (read))) (asciz (operand (read))) (atom (source) "*Mode") (begin) (big (source) "*Mode") (byte (operand (read))) (bytes (mapcar operand (read))) (cc (address) "*Mode" (sources) "*Modes") (call (address) "*Mode") (clrc) (clrz) (cmp (destination) "*Mode" (source) "*Mode") (cmpn (destination) "*Mode" (source) "*Mode" (source) "*Mode") (cnt (source) "*Mode") (dec (destination) "*Mode") (div (source) "*Mode") (drop) (eval) (eval+) (eval/ret) (exec (reg (read))) (fixnum) (float) (func) (hx2 (read)) (inc (destination) "*Mode") (initCode) (initData) (initFun (file) (read) (read) (operand (read))) (initLib) (initMain) (initSym (file) (read) (read) (operand (read))) (jc (address) "*Mode") (jcz (address) "*Mode") (jeq (address) "*Mode") (jge (address) "*Mode") (jgt (address) "*Mode") (jle (address) "*Mode") (jlt (address) "*Mode") (jmp (address) "*Mode") (jnc (address) "*Mode") (jncz (address) "*Mode") (jne (address) "*Mode") (jns (address) "*Mode") (jnsz (address) "*Mode") (jnz (address) "*Mode") (js (address) "*Mode") (jsz (address) "*Mode") (jz (address) "*Mode") (:: (file) (read)) (ld (destination) "*Mode" (source) "*Mode") (ld2 (source) "*Mode") (ld4 (source) "*Mode") (ldc (destination) "*Mode" (source) "*Mode") (ldd) (ldf) (ldnc (destination) "*Mode" (source) "*Mode") (ldnz (destination) "*Mode" (source) "*Mode") (ldz (destination) "*Mode" (source) "*Mode") (lea (destination) "*Mode" (source) "*Mode") (link) (load (destination) "*Mode" (destination) "*Mode" (source) "*Mode") (memb (source) "*Mode" (source) "*Mode") (movm (destination) "*Mode" (source) "*Mode" (source) "*Mode") (movn (destination) "*Mode" (source) "*Mode" (source) "*Mode") (mset (destination) "*Mode" (source) "*Mode") (mul (source) "*Mode") (neg (destination) "*Mode") (nop) (not (destination) "*Mode") (nul (source) "*Mode") (nul4) (null (source) "*Mode") (nulp (source) "*Mode") (num (source) "*Mode") (off (destination) "*Mode" (source T) "*Mode") (or (destination) "*Mode" (source) "*Mode") (pop (destination) "*Mode") (prog (reg (read))) (push (source) "*Mode") (rcl (destination) "*Mode" (source) "*Mode") (rcr (destination) "*Mode" (source) "*Mode") (ret) (return) (rol (destination) "*Mode" (source) "*Mode") (ror (destination) "*Mode" (source) "*Mode") (save (source) "*Mode" (source) "*Mode" (destination) "*Mode") (set (destination) "*Mode" (source) "*Mode") (setc) (setz) (shl (destination) "*Mode" (source) "*Mode") (shr (destination) "*Mode" (source) "*Mode") (skip (operand (read))) (slen (destination) "*Mode" (source) "*Mode") (st2 (destination) "*Mode") (st4 (destination) "*Mode") (std) (stf) (sub (destination) "*Mode" (source) "*Mode") (subc (destination) "*Mode" (source) "*Mode") (sym (source) "*Mode") (test (destination) "*Mode" (source) "*Mode") (tuck (source) "*Mode") (word (operand (read))) (xchg (destination) "*Mode" (destination) "*Mode") (xor (destination) "*Mode" (source) "*Mode") (zxt) ) ) # Directives (asm :: (Src Lbl) (idxTags Lbl Src) (label Lbl T) ) (asm initFun (Src Lbl Name Val) (initSym Src Lbl Name Val (pack Val (and *AlignedCode "+2"))) ) (asm initSym (Src Lbl Name Val) (initSym Src Lbl Name Val Val) ) (de initSym (Src Lbl Name Sym Val) (and Lbl (idxTags Lbl Src)) (idx '*Map (def Name Sym) T) (setq Name (let (N 2 Lst (chop Name) C) (make (while (nth Lst 8) (let L (mapcar char (cut 8 'Lst)) (unless *LittleEndian (setq L (flip L)) ) (chain L) ) ) (let L (make (do 7 (setq C (char (pop 'Lst))) (link (| N (>> -4 (& 15 C)))) (setq N (& 15 (>> 4 C))) ) (link N) ) (unless *LittleEndian (setq L (flip L)) ) (chain L) ) ) ) ) (if (nth Name 9) ((; 'word asm) ".+20") ((; 'bytes asm) Name) (off Name) ) (when Lbl (label Lbl T) ) ((; 'word asm) Val) (while Name ((; 'bytes asm) (cut 8 'Name)) ) ) # Condition code optimizations (de asmNoCC Args (let Sym (intern (pack (car Args) "-")) (put (car Args) 'noCC Sym) (def Sym 'asm (cdr Args)) ) ) (de useCC Lst (for Sym Lst (put Sym 'useCC T) ) ) (de chgCC Lst (for Sym Lst (put Sym 'chgCC T) ) ) (useCC ldc ldnc ldz ldnz addc subc rcl rcr jz jeq jnz jne js jns jsz jnsz jc jlt jnc jge jcz jle jncz jgt ) (chgCC movn mset movm save load add sub inc dec not neg and or xor off test shl shr rol ror mul div zxt setz clrz cmp cmpn slen memb null nul4 nul cnt big num sym atom call cc return eval eval+ eval/ret exec prog ) (de noCC (Lst) (with (caar Lst) (and (: noCC) (loop (NIL (setq Lst (cdr Lst))) (T (; Lst 1 1 useCC)) (T (; Lst 1 1 chgCC) T) (T (= '(push T NIL) (car Lst))) (T (= '(pop T NIL) (car Lst)) T) (T (== 'ret (caar Lst)) (use (@A @B @Z) (not (match '(@A "_" @B "F" @Z) (chop *Label))) ) ) (T (and (== 'jmp (caar Lst)) (not (setq Lst (member (cons ': (cadar Lst)) *Program))) ) ) ) (: noCC) ) ) ) # Warning message (de warn (Msg) (out 2 (printsp *Label *Statement) (prinl Msg) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/lib/fmt.c.l0000644000000000000000000000270612265263724016050 0ustar rootroot# 30sep12abu # (c) Software Lab. Alexander Burger (de newSection (Sym) (setq *Section Sym) ) (de asmDataLength () (+ (or (cadar *AsmData) 0) (sum '((X) (if (num? X) 1 8)) (cddar *AsmData)) ) ) # Directives (de label (Lbl Flg) (if (== 'data *Section) (push '*AsmData (list Lbl (asmDataLength)) ) (if (and *AsmCode (not (caar @))) (conc (car *AsmCode) (cons Lbl)) (push '*AsmCode (list NIL Lbl)) ) (idx '*Labels (def (name Lbl) *AsmPos) T) ) ) (asm word (X) (conc (cdar *AsmData) (cons (if (sym? X) X (cons X))) ) ) (asm byte (N) (conc (cdar *AsmData) (cons N)) ) (asm bytes (Lst) (conc (cdar *AsmData) (copy Lst)) ) (asm hx2 (Lst) (conc (cdar *AsmData) (mapcan '((S) (let (N (hex S) Hi (& (>> 8 N) 255) Lo (& N 255)) (if *LittleEndian (list Lo Hi) (list Hi Lo) ) ) ) Lst ) ) ) (de escCstr (Str) (make (for (L (chop Str) L) (let C (pop 'L) (link (char (ifn (= "\\" C) C (case (pop 'L) ("t" "^I") ("n" "^J") ("r" "^M") (T @) ) ) ) ) ) ) ) ) (asm ascii (Str) (conc (cdar *AsmData) (escCstr Str)) ) (asm asciz (Str) (conc (cdar *AsmData) (escCstr Str) (cons 0)) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/lib/fmt.s.l0000644000000000000000000000134612265263724016067 0ustar rootroot# 03aug12abu # (c) Software Lab. Alexander Burger (de newSection (Sym) (unless (== *Section Sym) (prinl) (prinl " ." (setq *Section Sym)) ) (prinl) ) # Print instruction (de prinst (Name . @) (if (rest) (tab (3 -9 0) NIL Name (glue ", " @)) (tab (3 -9) NIL Name) ) ) # Directives (de label (Lbl Flg) (and Flg (prinl " .globl " Lbl)) (prinl Lbl ':) ) (asm word (N) (prinst ".quad" N) ) (asm byte (N) (prinst ".byte" N) ) (asm bytes (Lst) (prinst ".byte" (glue ", " Lst)) ) (asm hx2 (Lst) (prinst ".short" (glue ", " (mapcar hex Lst))) ) (asm ascii (Str) (prinst ".ascii" (pack "\"" Str "\"")) ) (asm asciz (Str) (prinst ".asciz" (pack "\"" Str "\"")) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/main.l0000644000000000000000000024304712265263724015224 0ustar rootroot# 23jun13abu # (c) Software Lab. Alexander Burger (code 'Code) initCode ### Global return labels ### (code 'Ret 0) ret (code 'Retc 0) setc ret (code 'Retnc 0) clrc ret (code 'Retz 0) setz ret (code 'Retnz 0) clrz ret (code 'RetNil 0) ld E Nil ret (code 'RetT 0) ld E TSym ret (code 'RetE_E 0) ld E (E) # Get value or CAR ret ### Main entry point ### (code 'main) initMain ld (AV0) X # Save command ld (AV) Y # and argument vector # Check debug mode ld C (Z) # Last argument ld B (C) # First byte cmp B (char "+") # Single plus? if eq # Yes nul (C 1) if z # Yes ld (Dbg) TSym # Set '*Dbg' ld (Z) 0 # Clear last argument end end # Locate home directory ld Y (Y) # First argument null Y # Any? if nz # Yes ld B (Y) # First byte cmp B (char "-") # Dash? if ne # No ld Z Y # Keep in Y ld B (char "/") # Contains a slash? slen C Y # String length in C memb Z C if eq # Yes do memb Z C # Find last one until ne ld A Z sub A 2 # "./lib.l"? cmp A Y # Last slash is second byte? jne 10 # No ld B (Y) # First byte is "."? cmp B (char ".") if ne # No 10 sub Z Y # Length ld C Z # Keep in Z inc C # Space for null byte call allocC_A ld (Home) A # Set 'Home' movn (A) (Y) Z # Copy path including "/" add Z (Home) # Pointer to null byte set (Z) 0 # Clear it end end end end # Initialize globals cc getpid() # PID in A shl A 4 # Make short number or A CNT ld (Pid) A ld (Stack0) S # Save top level stack pointer ld A S # Stack top in A sub A (* 4 STACK) # Decrement by main segment size ld (Stack1) A # Set coroutine stack base ld (StkLimit) 0 # Initially without stack limit ld L 0 # Init link register call heapAlloc # Allocate initial heap ld E Nil # Init internal symbols lea Z (E VI) # Skip padding and 'pico' cell do ld X (E TAIL) # Get name ld Y Pico # From initial symbol namespace call internEXY_FE # Store to internals ld E Z cnt (Z TAIL) # Short name? if nz # Yes add Z II # Next symbol else add Z IV end cmp E SymTabEnd until gt ld (Get_A) getStdin_A ld A 0 # Standard input call initInFileA_A # Create input file ld (InFile) A # Set to default InFile ld (PutB) putStdoutB ld A 2 # Standard error call initOutFileA_A # Create output file ld A 1 # Standard output call initOutFileA_A # Create output file ld (OutFile) A # Set to default OutFile cc tcgetattr(0 OrgTermio) # Save terminal I/O not B ld (Tio) B # and flag sub S (%% SIGSET_T) # Create signal mask structure cc sigfillset(S) # Set all signals to unblocked cc sigprocmask(SIG_UNBLOCK S 0) add S (%% SIGSET_T) # Drop mask structure ld E sig # Install standard signal handler ld C SIGHUP call iSignalCE # for SIGHUP ld C SIGUSR1 call iSignalCE # for SIGUSR1 ld C SIGUSR2 call iSignalCE # for SIGUSR2 ld C SIGALRM call iSignalCE # for SIGALRM ld C SIGTERM call iSignalCE # for SIGTERM ld C SIGIO call iSignalCE # for SIGIO ld E sigTerm # Install terminating signal handler for SIGINT ld C SIGINT call iSignalCE cc signal(SIGCHLD sigChld) # Install child signal handler for SIGCHLD cc signal(SIGPIPE SIG_IGN) # Ignore signals cc signal(SIGTTIN SIG_IGN) cc signal(SIGTTOU SIG_IGN) cc gettimeofday(Tv 0) # Get time ld A (Tv) # tv_sec mul 1000000 # Convert to microseconds add A (Tv I) # tv_usec ld (USec) A # Store ld X 0 # Runtime expression call loadAllX_E # Load arguments ld E sig # Install standard signal handler for SIGINT ld C SIGINT set (Repl) 1 # Set REPL flag call iSignalCE (code 'restart) ld B (char ":") # Prompt ld E Nil # REPL ld X 0 # Runtime expression call loadBEX_E jmp restart # Load all remaining arguments (code 'loadAllX_E) do ld E ((AV)) # Command line vector null E # Next string pointer? jz retNil # No ld B (E) # Single-dash argument? cmp B (char "-") if eq nul (E 1) jz retNil # Yes end add (AV) I # Increment vector pointer call mkStrE_E # Make transient symbol ld B 0 # Prompt call loadBEX_E loop # Give up (code 'giveupX) ld A (Pid) # Get PID shr A 4 cc fprintf((stderr) Giveup A X) ld E 1 jmp finishE (code 'execErrS) cc fprintf((stderr) ExecErr (S)) cc exit(127) # Install interrupting signal (code 'iSignalCE) sub S (%% (* 2 SIGACTION)) # 'sigaction' and 'oldact' ld (S SA_HANDLER) E # Function pointer cc sigemptyset(&(S SA_MASK)) ld (S SA_FLAGS) 0 cc sigaction(C S &(S SIGACTION)) # Install handler add S (%% (* 2 SIGACTION)) ret # Allocate memory (code 'allocC_A 0) cc malloc(C) # Allocate memory of size C null A # OK? jz NoMemory # No ret (code 'allocAE_A 0) cc realloc(A E) # Reallocate pointer in A to size E null A # OK? jnz Ret # Return : NoMemory ld X AllocErr # No memory jmp giveupX # Allocate cell heap (code 'heapAlloc 0) # AEX ld A 0 # NULL pointer ld E (+ HEAP I II) # Heap size + link + space call allocAE_A add A 15 # Align to cell boundary off B 15 ld E A # Heap pointer ld (A HEAP) (Heaps) # Set heap link ld (Heaps) A add A (- HEAP 16) # A on last cell in chunk ld X (Avail) # Initialize free list do ld (A) X # Link avail ld X A sub A 16 cmp A E # Done? until lt # Yes ld (Avail) X # Set new Avail ret # Signal handler (code 'sighandler0) push E ld E 0 call sighandlerE pop E ret (code 'sighandlerX) push E ld E X call sighandlerE pop E ret (code 'sighandlerE) null (EnvProtect) # Protected? if z # No inc (EnvProtect) push A push C do null (Signal (* I SIGIO)) # Test signals if nz dec (Signal) # Decrement signal counters dec (Signal (* I SIGIO)) ld E (Sigio) # Run 'Sigio' call execE else null (Signal (* I SIGUSR1)) if nz dec (Signal) dec (Signal (* I SIGUSR1)) ld E (Sig1) # Run 'Sig1' call execE else null (Signal (* I SIGUSR2)) if nz dec (Signal) dec (Signal (* I SIGUSR2)) ld E (Sig2) # Run 'Sig2' call execE else null (Signal (* I SIGALRM)) if nz dec (Signal) dec (Signal (* I SIGALRM)) ld E (Alarm) # Run 'Alarm' call execE else null (Signal (* I SIGINT)) if nz dec (Signal) dec (Signal (* I SIGINT)) nul (PRepl) # Child of REPL process? if z # No null E # Runtime expression? ldz E Nil # No: Default to NIL call brkLoadE_E # Enter debug breakpoint end else null (Signal (* I SIGHUP)) if nz dec (Signal) dec (Signal (* I SIGHUP)) ld E (Hup) # Run 'Hup' call execE else null (Signal (* I SIGTERM)) if nz push X ld X (Child) # Iterate children ld C (Children) # Count ld E 0 # Flag do sub C VI # More? while ge # Yes null (X) # 'pid'? if nz # Yes cc kill((X) SIGTERM) # Try to terminate nul4 # OK? ldz E 1 # Yes: Set flag end add X VI # Increment by sizeof(child) loop pop X null E # Still terminated any child? if z # No ld (Signal) 0 ld E 0 # Exit OK jmp byeE end break T end end end end end end end null (Signal) # More signals? until z # No pop C pop A ld (EnvProtect) 0 end ret (code 'sig) begin # Signal number in A null (TtyPid) # Kill terminal process? if nz # Yes cc kill((TtyPid) A) else shl A 3 # Signal index inc (A Signal) inc (Signal) end return (code 'sigTerm) begin # Ignore signal number null (TtyPid) # Kill terminal process? if nz # Yes cc kill((TtyPid) SIGTERM) else inc (Signal (* I SIGTERM)) inc (Signal) end return (code 'sigChld) begin # Ignore signal number call errno_A # Save 'errno' push A sub S I # 'stat' do cc waitpid(0 S WNOHANG) # Wait for child nul4 # Pid greater zero? while nsz # Yes ld C A # Keep Pid call wifsignaledS_F # WIFSIGNALED(S)? if nz # Yes call wtermsigS_A # Get signal number WTERMSIG(S) cc fprintf((stderr) PidSigMsg C A) end loop add S I # Drop 'stat' pop C # Restore 'errno' call errnoC return (code 'tcSetC) null (Termio) # In raw mode? if nz # Yes do cc tcsetattr(0 TCSADRAIN C) # Set terminal I/O nul4 # OK? while nz # No call errno_A cmp A EINTR # Interrupted? until ne # No end ret (code 'sigTermStop) begin # Ignore signal number ld C OrgTermio # Set original terminal I/O call tcSetC sub S (%% SIGSET_T) # Create mask structure cc sigemptyset(S) # Init to empty signal set cc sigaddset(S SIGTSTP) # Add stop signal cc sigprocmask(SIG_UNBLOCK S 0) # Remove blocked signals add S (%% SIGSET_T) # Drop mask structure cc signal(SIGTSTP SIG_DFL) cc raise(SIGTSTP) cc signal(SIGTSTP sigTermStop) ld C (Termio) call tcSetC return (code 'setRaw 0) nul (Tio) # Terminal I/O? if nz # Yes null (Termio) # Already in raw mode? if z # No ld C TERMIOS # Allocate space for termio structure call allocC_A ld (Termio) A # Save it ld C A # Pointer in C movn (C) (OrgTermio) TERMIOS # Copy original termio structure ld A 0 # Clear c_iflag st4 (C C_IFLAG) ld A ISIG # ISIG in c_lflag st4 (C C_LFLAG) set (C (+ C_CC VMIN)) 1 set (C (+ C_CC VTIME)) 0 call tcSetC # Set terminal I/O cc signal(SIGTSTP SIG_IGN) # Ignore stop signals cmp A SIG_DFL # Not set yet? if eq # Yes cc signal(SIGTSTP sigTermStop) # Handle stop signals end end end ret (code 'setCooked 0) ld C OrgTermio # Set original terminal I/O call tcSetC cc free((Termio)) # Clear Termio ld (Termio) 0 ret # (raw ['flg]) -> flg (code 'doRaw 2) ld E (E CDR) # Arg? atom E if nz # No null (Termio) # Return termio flag jnz retT ld E Nil ret end ld E (E) # Evaluate arg eval cmp E Nil # NIL? if eq # Yes call setCooked # Set terminal to cooked mode ld E Nil ret end call setRaw # Set terminal to raw mode ld E TSym ret # (alarm 'cnt . prg) -> cnt (code 'doAlarm 2) push X push Y ld X E ld Y (E CDR) # Y on args call evCntXY_FE # Get 'cnt' cc alarm(E) # Set alarm ld (Alarm) (Y CDR) ld E A # Get old alarm shl E 4 # Make short number or E CNT pop Y pop X ret # (sigio 'cnt . prg) -> cnt (code 'doSigio 2) push X push Y ld X E ld Y (E CDR) # Y on args call evCntXY_FE # Get fd ld (Sigio) (Y CDR) # Set handler ld A (Pid) # Get process ID shr A 4 # Normalize cc fcntl(E F_SETOWN A) # Receive SIGIO events cc fcntl(E F_GETFL 0) # Get file status flags or A (| O_NONBLOCK O_ASYNC) cc fcntl(E F_SETFL A) # Set file status flags shl E 4 # Return fd or E CNT pop Y pop X ret # (protect . prg) -> any (code 'doProtect 2) push X ld X (E CDR) # Get 'prg' inc (EnvProtect) prog X # Run 'prg' dec (EnvProtect) pop X ret # (heap 'flg) -> cnt (code 'doHeap 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E Nil # NIL? if eq # Yes ld E ZERO # Init count ld A (Heaps) # Get heap list do add E (hex "10") # Increment count ld A (A HEAP) # Get link null A # Done? until z # Yes ret end ld A 0 # Init count ld C (Avail) # Get avail list do null C # Any? while nz # Yes inc A # Increment count ld C (C) # Follow link loop div CELLS # (C is zero) ld E A shl E 4 # Make short number or E CNT ret # (stack ['cnt]) -> cnt | (.. sym . cnt) (code 'doStack 2) push X ld X E ld E (E CDR) # Arg? atom E if z # Yes null (Stacks) # Stack segments allocated? if z # No ld E (E) # Eval 'cnt' call evCntEX_FE shl E 22 # Main stack segment size [times 4 MB] ld A (Stack0) # Get stack top sub A E # Decrement by main segment size ld (Stack1) A # New coroutine stack base shr E 2 # [to MB] ld (StkSize) E # Set new stack size shr E 16 # Make short number [MB] or E CNT pop X ret end end ld E (StkSize) # Return current stack size shr E 16 # Make short number [MB] or E CNT ld X (Stack1) # Collect coroutines ld C (Stacks) # Segment bitmask do null C # Any? while nz # Yes null (X -I) # In use? if nz # Yes call consE_A # Cons 'tag' ld (A) (X -I) ld (A CDR) E ld E A dec C # Decrement count end sub X (StkSize) # Next segment loop pop X ret # (adr 'var) -> num # (adr 'num) -> var (code 'doAdr 2) ld E ((E CDR)) # Eval arg eval num E # 'num' argument? if nz # Yes off E CNT # Make 'var' ret end or E CNT # Make 'num' ret # (env ['lst] | ['sym 'val] ..) -> lst (code 'doEnv 2) push X ld X (E CDR) link push Nil # Safe push Nil # Result link atom X # Args? if nz # No push Y ld Y (EnvBind) # Bindings null Y # Any? if nz # Yes null (Break) # In breakpoint? ldnz Y ((Y) I) # Yes: Skip frame end do null Y # Bindings? while nz # Yes ld C (Y) # End of bindings null (Y -I) # Env swap zero? if z # Yes add Y I # Y on bindings do ld E (Y) # Next symbol ld X (L I) # Get result do atom X # More result items? if nz # No call cons_A # Cons symbol and its value ld (A) E ld (A CDR) (E) call consA_X # Cons to result ld (X) A ld (X CDR) (L I) ld (L I) X break T end cmp E ((X)) # Symbol already in result? while ne # No ld X (X CDR) # Next result item loop add Y II # Skip value cmp Y C # More? until eq # No end ld Y (C I) # Bind link loop pop Y else do ld E (X) # Eval 'lst' or 'sym' eval ld (L II) E # Save atom E # 'lst'? if z # Yes do call cons_A # Prepare new cell ld C (E) # Next item already a pair? atom C if z # Yes ld (A) (C) # Copy it ld (A CDR) (C CDR) else ld (A) C # Cons symbol and its value ld (A CDR) (C) end call consA_C # Cons to result ld (C) A ld (C CDR) (L I) ld (L I) C ld E (E CDR) # Next item in 'lst' atom E # Any? until nz # No else cmp E Nil # NIL? if ne # No ld X (X CDR) # Next arg ld E (X) # Eval eval call consE_A # Cons symbol and value ld (A) (L II) # Safe ld (A CDR) E call consA_C # Cons to result ld (C) A ld (C CDR) (L I) ld (L I) C end end ld X (X CDR) # More args? atom X until nz # No end ld E (L I) # Get result drop pop X ret # (trail ['flg]) -> lst (code 'doTrail 2) push X push Y push Z ld E ((E CDR)) # Evaluate arg eval ld Z E # Keep 'flg' in Z ld X (EnvBind) # Bindings null X # Any? if nz # Yes null (Break) # In breakpoint? ldnz X ((X) I) # Yes: Skip frame end ld E Nil # Result do null X # Bindings? while nz # Yes ld C (X) # End of bindings null (X -I) # Env swap zero? if z # Yes add X I # X on bindings do ld Y (X) # Next symbol add X II # Next entry cmp Y At # Lambda frame? if eq # Yes cmp X C # Last entry? if eq # Yes call cons_A # Cons 'exe' ld (A) (C II) # Cons 'exe' ld (A CDR) E ld E A break T end end cmp Z Nil # 'flg'? if ne # Yes call cons_A # Cons value ld (A) (Y) ld (A CDR) E call consA_E # Cons symbol ld (E) Y ld (E CDR) A ld (Y) (X -I) # Set old value end cmp X C # More? until eq # No end ld X (C I) # Bind link loop ld X E # Restore values do atom X # More? while z # Yes ld Y (X) # Next entry ld X (X CDR) atom Y # Symbol? if nz # Yes ld (Y) (X) # Set old value ld X (X CDR) end loop pop Z pop Y pop X ret # (up [cnt] sym ['val]) -> any (code 'doUp 2) push X ld C 1 # Count ld E (E CDR) # First arg ld X (E) # Get 'sym' cnt X # 'cnt'? if nz # Yes ld C X # Count shr C 4 # Normalize ld E (E CDR) # Skip arg ld X (E) # 'sym' end cmp X Nil # NIL? if eq # Yes ld X (EnvBind) # Bindings null X # Any? if nz # Yes null (Break) # In breakpoint? ldnz X ((X) I) # Yes: Skip frame end do null X # Bindings? while nz # Yes ld A (X) # End of bindings in A cmp (A -II) At # Lambda frame? if eq # Yes dec C # Done? if z # Yes ld E (A II) # Return 'exe' pop X ret end end ld X (A I) # Bind link loop ld E Nil # Return NIL pop X ret end push Y push Z ld E (E CDR) # Last arg ld Y (EnvBind) # Bindings null Y # Any? if nz # Yes null (Break) # In breakpoint? ldnz Y ((Y) I) # Yes: Skip frame end ld Z X # Value pointer do null Y # Bindings? while nz # Yes ld A (Y) # End of bindings in A add Y I do cmp X (Y) # Found symbol? if eq # Yes lea Z (Y I) # Point to saved value dec C # Decrement count jz 10 # Done end add Y II cmp Y A # More? until eq # No ld Y (A I) # Bind link loop 10 atom E # 'val' arg? if nz # No ld E (Z) # Get value else ld E (E) # Eval last arg eval ld (Z) E # Store value end pop Z pop Y pop X ret # (sys 'any ['any]) -> sym (code 'doSys 2) push X push Z ld X (E CDR) # X on args call evSymX_E # Evaluate first symbol call bufStringE_SZ # Write to stack buffer ld X (X CDR) # Next arg? atom X if nz # No cc getenv(S) # Get value from system ld E A call mkStrE_E # Make transient symbol else push Z call evSymX_E # Evaluate second symbol lea X (S I) # Keep pointer to first buffer call bufStringE_SZ # Write to stack buffer cc setenv(X S 1) # Set system value nul4 # OK? ldnz E Nil # No ld S Z # Drop buffer pop Z end ld S Z # Drop buffer pop Z pop X ret (code 'circE_YF) ld Y E # Keep list in Y do or (E) 1 # Mark ld E (E CDR) # Normal list? atom E if nz # Yes do off (Y) 1 # Unmark ld Y (Y CDR) atom Y # Done? until nz # Yes ret # 'nz' - No circularity found end test (E) 1 # Detected circularity? if nz # Yes do cmp Y E # Skip non-circular part while ne off (Y) 1 # Unmark ld Y (Y CDR) loop do off (Y) 1 # Unmark circular part ld Y (Y CDR) cmp Y E # Done? until eq # Yes ret # 'z' - Circularity in Y end loop ### Comparisons ### (code 'equalAE_F 0) cmp A E # Pointer-equal? jeq ret # Yes: 'eq' cnt A # A short? jnz ret # Yes: 'ne' big A # A big? if nz # Yes big E # E also big? jz Retnz # No: 'ne' test A SIGN # A negative? if nz # Yes test E SIGN # E also negative? jz Retnz # No: 'ne' off A SIGN # Make both positive off E SIGN end do cmp (A DIG) (E DIG) # Digits equal? while eq # Yes ld A (A BIG) # Else next digits ld E (E BIG) cmp A E # Pointer-equal? while ne # No cnt A # A short? while z # No cnt E # E short? until nz # Yes ret end sym A # A symbolic? if nz # Yes num E # E also symbolic? jnz Retnz sym E jz Retnz # No: 'ne' ld A (A TAIL) call nameA_A # Get name of A cmp A ZERO # Any? jeq retnz # No: 'ne' ld E (E TAIL) call nameE_E # Get name of E cmp E ZERO # Any? jeq retnz # No: 'ne' jmp equalAE_F end atom E # E atomic? jnz ret # Yes: 'ne' push X push Y ld X A # Keep list heads ld Y E do push A # Save lists push E cmp S (StkLimit) # Stack check jlt stkErr ld A (A) # Recurse on CARs ld E (E) off E 1 # Clear possible mark call equalAE_F # Equal? pop E # Retrieve lists pop A break ne # No: 'ne' atom (A CDR) # A's CDR atomic? if nz # Yes push A # Save lists push E ld A (A CDR) # Recurse on CDRs ld E (E CDR) call equalAE_F # Compare with E's CDR pop E # Retrieve lists pop A break T end atom (E CDR) # E's CDR atomic? break nz # Yes: 'ne' or (A) 1 # Mark ld A (A CDR) ld E (E CDR) test (A) 1 # Detected circularity? if nz do cmp X A # Skip non-circular parts if eq # Done cmp Y E # Circular parts same length? if eq # Perhaps do ld X (X CDR) # Compare ld Y (Y CDR) cmp Y E # End of second? if eq # Yes cmp X A # Also end of first? break T end cmp X A # End of first? break eq # Yes loop end break T end cmp Y E if eq clrz # Result "No" break T end off (X) 1 # Unmark ld X (X CDR) ld Y (Y CDR) loop push F # Save result do off (X) 1 # Unmark circular part ld X (X CDR) cmp X A until eq pop F # Get result pop Y pop X ret end loop push F # Save result do cmp X A # Skip non-circular part while ne off (X) 1 # Unmark ld X (X CDR) loop pop F # Get result pop Y pop X ret (code 'compareAE_F 0) # C cmp A E # Pointer-equal? jeq ret # Yes cmp A Nil if eq # [NIL E] 10 or B B # nz 20 setc # lt ret end cmp A TSym if eq # [T E] 30 or B B # nz 40 clrc # gt ret end num A # Number? if nz # Yes num E # Both? jnz cmpNumAE_F # [ ] cmp E Nil jeq 30 # [ NIL] setc # lt ret end sym A if nz # [ ..] num E jnz 40 # [ ] cmp E Nil jeq 30 # [ NIL] atom E jz 10 # [ ] cmp E TSym jeq 10 # [ T] push X # [ ] ld X (A TAIL) call nameX_X # Get A's name in X cmp X ZERO # Any? if eq # No ld X (E TAIL) call nameX_X # Second name in X cmp X ZERO # Any? if eq # No cmp A E # Compare symbol addresses else setc # lt end pop X ret end ld E (E TAIL) call nameE_E # Get E's name in E cmp E ZERO # Any? if eq # No 50 or B B # nz 60 clrc # gt 70 pop X ret end do cnt X # Get next digit from X into A if nz ld A X # Short shr A 4 # Normalize ld X 0 else ld A (X DIG) # Get next digit ld X (X BIG) end cnt E # Get next digit from E into C if nz ld C E # Short shr C 4 # Normalize ld E 0 else ld C (E DIG) # Get next digit ld E (E BIG) end do cmp B C # Bytes equal? jne 70 # No: lt or gt shr A 8 # Next byte in A? if z # No shr C 8 # Next byte in C? if nz # Yes setc # lt pop X ret end null X # X done? if z # Yes null E # E also done? jz 70 # Yes: eq setc # lt pop X ret end null E # E done? jz 50 # Yes: gt break T end shr C 8 # Next byte in C? jz 50 # No: gt loop loop end atom E if nz # [ ] cmp E TSym if eq # [ T] or B B # nz setc # lt ret end clrc # gt ret end push X # [ ] push Y ld X A # Keep originals ld Y E do push A # Recurse on CAR push E ld A (A) ld E (E) cmp S (StkLimit) # Stack check jlt stkErr call compareAE_F # Same? pop E pop A while eq # Yes ld A (A CDR) # Next elements ld E (E CDR) atom A # End of A? if nz # Yes cmp S (StkLimit) # Stack check jlt stkErr call compareAE_F # Compare CDRs break T end atom E # End of E? if nz # Yes cmp E TSym if ne clrc # gt [ ] break T end or B B # nz [ T] setc # lt break T end cmp A X # Circular list? if eq cmp E Y break eq # Yes end loop pop Y pop X ret # F (code 'binSizeX_A 0) cnt X # Short number? if nz # Yes shr X 3 # Normalize short, keep sign bit jmp 20 end big X # Big number? if nz # Yes ld A 9 # Count 8 significant bytes plus 1 do ld C (X DIG) # Keep digit ld X (X BIG) # More cells? cnt X while z # Yes add A 8 # Increment count by 8 loop shr X 4 # Normalize short shl C 1 # Get most significant bit of last digit addc X X # Any significant bits in short number? jmp 40 end ld A 1 # Preload 1 cmp X Nil # NIL? if ne # No sym X # Symbol? if nz # Yes ld X (X TAIL) call nameX_X # Get name cmp X ZERO # Any? if ne # Yes cnt X # Short name? if nz # Yes shl X 2 # Strip status bits shr X 6 # Normalize 20 ld A 2 # Count significant bytes plus 1 do shr X 8 # More bytes? while nz # Yes inc A # Increment count loop ret end ld A 9 # Count significant bytes plus 1 do ld X (X BIG) # More cells? cnt X while z # Yes add A 8 # Increment count by 8 loop shr X 4 # Any significant bits in short name/number? 40 if nz # Yes do inc A # Increment count shr X 8 # More bytes? until z # No end cmp A (+ 63 1) # More than one chunk? if ge # Yes ld X A # Keep size+1 in X sub A 64 # Size-63 ld C 0 # Divide by 255 div 255 setc # Plus 1 addc A X # Plus size+1 end end ret end push X # List head push 2 # Count do push (X CDR) # Save rest ld X (X) # Recurse on CAR call binSizeX_A pop X add (S) A # Add result to count cmp X Nil # CDR is NIL? while ne # No cmp X (S I) # Circular? if eq # Yes inc (S) # Increment count once more break T end atom X # Atomic CDR? if nz # Yes call binSizeX_A # Get size add (S) A # Add result to count break T end loop pop A # Get result add S I # Drop list head end ret (code 'memberXY_FY 0) ld C Y # Keep head in C do atom Y # List? while z # Yes ld A X ld E (Y) call equalAE_F # Member? jeq ret # Return list ld Y (Y CDR) # Next item cmp C Y # Hit head? jeq retnz # Yes loop ld A X ld E Y jmp equalAE_F # Same atoms? # (quit ['any ['any]]) (code 'doQuit 2) ld X (E CDR) # Args call evSymX_E # Evaluate to a symbol call bufStringE_SZ # Write to stack buffer ld X (X CDR) # Next arg? atom X ldnz E 0 # No if z # Yes ld E (X) eval # Eval end ld X 0 # No context ld Y QuitMsg # Format string ld Z S # Buffer pointer jmp errEXYZ # Jump to error handler ### Evaluation ### # Apply EXPR in C to CDR of E (code 'evExprCE_E 0) push X push Y push Z cmp S (StkLimit) # Stack check jlt stkErrE ld X (E CDR) # Get CDR ld Y (C) # Parameter list in Y ld Z (C CDR) # Body in Z push E # Save 'exe' push (EnvBind) # Build bind frame link push (At) # Bind At push At do atom Y # More evaluating parameters? while z # Yes ld E (X) # Get next argument ld X (X CDR) eval+ # Evaluate and save push E push (Y) # Save symbol ld Y (Y CDR) loop cmp Y Nil # NIL-terminated parameter list? if eq # Yes: Bind parameter symbols ld Y S # Y on bindings do ld X (Y) # Symbol in X add Y I ld A (X) # Old value in A ld (X) (Y) # Set new value ld (Y) A # Save old value add Y I cmp Y L # End? until eq # Yes link ld (EnvBind) L # Close bind frame push 0 # Init env swap prog Z # Run body add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link add S I # Drop 'exe' pop Z pop Y pop X ret end # Non-NIL parameter cmp Y At # '@'? if ne # No push (Y) # Save last parameter's old value push Y # and the last parameter ld (Y) X # Set to unevaluated argument list lea Y (S II) # Y on evaluated bindings do ld X (Y) # Symbol in X add Y I ld A (X) # Old value in A ld (X) (Y) # Set new value ld (Y) A # Save old value add Y I cmp Y L # End? until eq # Yes link ld (EnvBind) L # Close bind frame push 0 # Init env swap prog Z # Run body add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link add S I # Drop 'exe' pop Z pop Y pop X ret end # Evaluated argument list link # Close bind frame ld Y L # Y on frame push 0 # Init env swap push (EnvNext) # Save current 'next' push (EnvArgs) # and varArgs base atom X # Any args? if nz # No ld (EnvArgs) 0 ld (EnvNext) 0 else link # Build varArgs frame do ld E (X) # Get next argument eval+ # Evaluate and save push E ld X (X CDR) atom X # More args? until nz # No ld (EnvArgs) S # Set new varArgs base ld (EnvNext) L # Set new 'next' link # Close varArgs frame end ld (EnvBind) Y # Close bind frame ld C (Y) # End of bindings in C add Y I do ld X (Y) # Symbol in X add Y I ld A (X) # Old value in A ld (X) (Y) # Set new value ld (Y) A # Save old value add Y I cmp Y C # End? until eq # Yes prog Z # Run body null (EnvArgs) # VarArgs? if nz # Yes drop # Drop varArgs end pop (EnvArgs) # Restore varArgs base pop (EnvNext) # and 'next' add S I # Drop env swap pop L # Get link do # Unbind symbols pop X # Next symbol pop (X) # Restore value cmp S L # More? until eq # No pop L # Restore link pop (EnvBind) # Restore bind link add S I # Drop 'exe' pop Z pop Y pop X ret # Evaluate a list (code 'evListE_E 0) ld C (E) # Get CAR in C num C # Number? jnz ret # Yes: Return list sym C # Symbol? if nz # Yes 10 do # C is a symbol null (Signal) # Signal? if nz # Yes push E call sighandlerE pop E end ld A (C) # Get VAL cnt A # Short number? jnz (A T) # Yes: Eval SUBR big A # Undefined if bignum jnz undefinedCE cmp A (A) # Auto-symbol? if ne # No ld C A atom C # Symbol? jz evExprCE_E # No: Apply EXPR else call sharedLibC_FA # Try dynamic load jnz (A T) # Eval SUBR jmp undefinedCE end loop end push E ld E C cmp S (StkLimit) # Stack check jlt stkErr call evListE_E ld C E pop E cnt C # Short number? jnz (C T) # Yes: Eval SUBR big C # Undefined if bignum jnz undefinedCE link push C # Save function link atom C # Symbol? if z call evExprCE_E # No: Apply EXPR else call 10 end drop ret (code 'sharedLibC_FA) push C push E push Y push Z ld E C # Get symbol in E call bufStringE_SZ # Write to stack buffer ld C 0 ld Y S # Search for colon and slash do ld B (Y) # Next byte or B B # End of string? jz 90 # Yes cmp B (char ":") # Colon? while ne # No cmp B (char "/") # Slash? if eq # Yes ld C Y # Keep pointer to slash end inc Y # Increment buffer pointer loop cmp Y Z # At start of buffer? jeq 90 # Yes nul (Y 1) # At end of buffer? jz 90 # Yes set (Y) 0 # Replace colon with null byte inc Y # Point to token null C # Contained '/'? ld C S # Pointer to lib name if z # No sub S 8 # Extend buffer sub C 4 # Prepend "lib/" set (C 3) (char "/") set (C 2) (char "b") set (C 1) (char "i") set (C) (char "l") ld A (Home) # Home directory? null A if nz # Yes do inc A # Find end nul (A) until z sub A (Home) # Calculate length sub C A # Adjust buffer ld S C off S 7 movn (C) ((Home)) A # Insert home path end end cc dlopen(C (| RTLD_LAZY RTLD_GLOBAL)) # Open dynamic library null A # OK? if nz # Yes cc dlsym(A Y) # Find dynamic symbol null A # OK? if nz # Yes initLib ? *AlignedCode or A CNT # Make short number = ld (E) A # 'nz' - Set function definition end end 90 ld S Z # Drop buffer pop Z pop Y pop E pop C ret # (errno) -> cnt (code 'doErrno 2) call errno_A # Get 'errno' ld E A shl E 4 # Make short number or E CNT ret # (native 'cnt1|sym1 'cnt2|sym2 'any 'any ..) -> any (code 'doNative 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval library 'cnt1|sym1' eval cnt E # Library handle? if nz # Yes shr E 4 # Normalize push E # Library handle else big E # Library handle? if nz # Yes push (E DIG) # Library handle else call needSymEX # Check symbol ld A (E TAIL) # Check for main program library call nameA_A # Get name cmp A (| CNT (>> -4 (char "@"))) # "@"? if eq # Yes cc dlopen(0 (| RTLD_LAZY RTLD_GLOBAL)) # Open main library else call pathStringE_SZ # Write to stack buffer cc dlopen(S (| RTLD_LAZY RTLD_GLOBAL)) # Open dynamic library ld S Z # Drop buffer end null A # OK? jz dlErrX # No push A # Library handle test A (hex "F000000000000000") # Fit in short number? if z # Yes shl A 4 # Make short number or A CNT else call boxNumA_A # Make bignum end ld (E) A # Set value of 'sym1' end end ld Y (Y CDR) # Second arg ld E (Y) # Eval function 'cnt2|sym2' eval ld Z S # Stack marker in Z cnt E # Function pointer? if nz # Yes shr E 4 # Normalize ld (S) E # Function pointer else big E # Function pointer?? if nz # Yes ld (S) (E DIG) # Function pointer else call needSymEX # Check symbol call bufStringE_SZ # Write to stack buffer cc dlsym((Z) S) # Find dynamic symbol null A # OK? jz dlErrX # No ld S Z # Drop buffer ld (S) A # Function pointer test A (hex "F000000000000000") # Fit in short number? if z # Yes shl A 4 # Make short number or A CNT else call boxNumA_A # Make bignum end ld (E) A # Set value end end ld Y (Y CDR) # Third arg ld E (Y) # Eval result specification eval link push E # Result specification do ld Y (Y CDR) # Arguments? atom Y while z # Yes ld E (Y) # Eval argument specification eval+ push E loop ld X S # X on last argument link push (CLink) # Save Link ld (CLink) L lea Y (Z -II) # Limit do cmp X Y # More args? while ne # Yes ld E (X) # Argument specification num E # Number? if nz # Yes cnt E # Short? if nz # Yes shr E 4 # Normalize if c # Sign? neg E # Yes end else test E SIGN # Sign? if z # No ld E (E DIG) else ld E (E (- DIG SIGN)) neg E # Negate end end push E # Pass long argument push 0 # as Integer/pointer value else sym E # String? if nz # Yes push Z call bufStringE_SZ # Write to stack buffer cc strdup(S) # Make new string ld S Z # Drop buffer pop Z push A # Pass pointer argument push 0 # as Integer/pointer value else ld C (E CDR) # Fixpoint? cnt C if nz # Yes push (E) # Pass number or flag push C # as fixpoint value else # Structure ld E C # Ignore variable ld C ((E)) # Get buffer size shr C 4 # Normalize call allocC_A # Allocate buffer push A # Pass pointer argument push 0 # as Integer/pointer value push Z ld Z A # Buffer pointer in Z do ld E (E CDR) cnt E # Fill rest? if nz # Yes ld A E # Byte value shr A 4 # in B do dec C # Done? while ns # No ld (Z) B # Store byte in buffer inc Z # Increment buffer pointer loop break T end atom E # Fill structure? while z # Yes ld A (E) # Next value call natBufACZ_CZ # Store in buffer null C # Buffer full? until z # Yes pop Z end end end add X I # Next arg loop lea X (L -I) # Top of arguments ld Y (Z) # Get function pointer cc (Y) X # Call C-function ld (CLink) (L -I) # Restore Link ld E (Z -II) # Get result specification ld C 0 # No pointer yet call natRetACE_CE # Extract return value ld (Z -II) E # Save result lea Y (Z -III) # Clean up allocated C args do cmp Y L # Args? while ne # Yes add S I # Drop type pop X # Next C arg ld E (Y) # Next Lisp arg num E # Number? if z # No sym E # String? jnz 10 # Yes cnt (E CDR) # Fixpoint? if z # No cmp (E) Nil # Variable? if ne # Yes ld C X # Structure pointer ld E (((E CDR)) CDR) # Result specification call natRetACE_CE # Extract value ld (((Y))) E # Store in variable end 10 cc free(X) # Free string or buffer end end sub Y I loop ld E (Z -II) # Get result drop add S I # Drop library handle pop Z pop Y pop X ret (code 'natBufACZ_CZ 0) atom A # Byte or unsigned? if nz # Yes shr A 4 # Byte? if nc # Yes ld (Z) B # Store byte in buffer inc Z # Increment buffer pointer dec C # Decrement size ret end st4 (Z) # Store unsigned in buffer add Z 4 # Size of unsigned sub C 4 # Decrement size ret end # (num|sym . cnt) or ([-]1.0 . lst) push X ld X (A CDR) # 'cnt' or 'lst' ld A (A) # 'num', 'sym' or [-]1.0 cnt X # 'cnt'? if nz # Yes push Y ld Y Z # Y on buffer shr X 4 # Normalize length add Z X # Field width sub C X # New buffer size num A # (num . cnt)? if nz # Yes cnt A # Short? if nz # Yes shr A 4 # Normalize if c # Sign? neg A # Yes end else test A SIGN # Sign? if z # No ld A (A DIG) else ld A (A (- DIG SIGN)) neg A # Negate end end ? *LittleEndian do ld (Y) B # Store byte inc Y # Increment pointer shr A 8 dec X # Done? until z # Yes = ? (not *LittleEndian) ld Y Z do dec Y # Decrement pointer ld (Y) B # Store byte shr A 8 dec X # Done? until z # Yes = else sym A # (sym . cnt)? if nz # Yes push C ld X (A TAIL) # Get name call nameX_X ld C 0 do call symByteCX_FACX # Next byte while nz ld (Y) B # Store it inc Y # Increment pointer loop set (Y) 0 # Null byte pop C end end pop Y else # ([-]1.0 . lst) do atom X # More fixpoint numbers? while z # Yes float # Convert to floating point test A SIGN # Scale negative? if z # No std # Store double value add Z 8 # Size of double sub C 8 # Decrement buffer size else stf # Store float value add Z 4 # Size of float sub C 4 # Decrement buffer size end ld X (X CDR) loop end pop X ret (code 'natRetACE_CE 0) cmp E Nil # NIL? if ne cnt E # Scale? if nz # Yes null C # Pointer? if nz # Yes test E SIGN # Negative? if z # No ldd # Get double value add C 8 # Size of double else ldf # Get float value add C 4 # Size of float end end fixnum # Get fixpoint number or flg else cmp E ISym # 'I'? if eq # Yes null C # Pointer? if nz # Yes ld4 (C) add C 4 # Size of int end ld E (hex "FFFFFFFF") # Sign-extend integer and E A # into E ld A (hex "80000000") xor E A sub E A # Negative? if ns # No shl E 4 # Make short number or E CNT else neg E # Negate shl E 4 # Make negative short number or E (| SIGN CNT) end else cmp E NSym # 'N'? if eq # Yes null C # Pointer? if nz # Yes ld A (C) add C 8 # Size of long/pointer end ld E A # Number call boxE_E else cmp E SSym # 'S'? if eq # Yes null C # Pointer? if nz # Yes ld A (C) add C 8 # Size of pointer end ld E A # Make transient symbol call mkStrE_E else cmp E CSym # 'C'? if eq # Yes null C # Pointer? if nz # Yes call fetchCharC_AC # Fetch char end ld E Nil # Preload null A # Char? if nz # Yes call mkCharA_A # Make char ld E A end else cmp E BSym # 'B'? if eq # Yes null C # Pointer? if nz # Yes ld B (C) inc C # Size of byte end zxt # Byte ld E A shl E 4 # Make short number or E CNT else atom E # Atomic? if z # No: Arrary or structure null C # Primary return value? ldz C A # Yes: Get into C null C # Value NULL? ldz E Nil # Yes: Return NIL if nz push X push Y push Z ld X E # Get specification in X ld E (X) call natRetACE_CE # First item call cons_Y # Make cell ld (Y) E ld (Y CDR) Nil link push Y # Result link do ld Z (X CDR) cnt Z # (sym . cnt) if nz shr Z 4 # Normalize do dec Z # Decrement count while nz ld E (X) # Repeat last type call natRetACE_CE # Next item call cons_A # Cons into cell ld (A) E ld (A CDR) Nil ld (Y CDR) A # Append to result ld Y A loop break T end atom Z # End of specification? while z # No ld X Z ld E (X) # Next type call natRetACE_CE # Next item call cons_A # Cons into cell ld (A) E ld (A CDR) Nil ld (Y CDR) A # Append to result ld Y A loop ld E (L I) # Get result drop pop Z pop Y pop X end end end end end end end end end ret # (struct 'num 'any 'any ..) -> any (code 'doStruct 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval native value (pointer or scalar) eval num E # Number? jz numErrEX # No cnt E # Short? if nz # Yes shr E 4 # Normalize ld Z E # Native value in Z else ld Z (E DIG) # Native value in Z end ld Y (Y CDR) # Next arg ld E (Y) eval # Eval 'any' link push E # Result specification link push Z # Save native value do ld Y (Y CDR) # Arguments? atom Y while z # Yes ld E (Y) # Eval next struct element eval ld A E # in A (unused C) call natBufACZ_CZ # Store in buffer loop pop A # Get native value ld C 0 # No pointer yet ld E (L I) # Result specification call natRetACE_CE # Extract return value drop pop Z pop Y pop X ret (code 'fetchCharC_AC 0) ld B (C) # Fetch first byte zxt or B B # Any? if nz # Yes inc C cmp B 128 # Single byte? if ge # No test B (hex "20") # Two bytes? if z # Yes and B (hex "1F") # First byte 110xxxxx shl A 6 # xxxxx000000 push A else # Three bytes and B (hex "F") # First byte 1110xxxx shl A 6 # xxxx000000 push A ld B (C) # Fetch second byte zxt inc C and B (hex "3F") # 10xxxxxx or A (S) # Combine shl A 6 # xxxxxxxxxx000000 ld (S) A end ld B (C) # Fetch last byte zxt inc C and B (hex "3F") # 10xxxxxx or (S) A # Combine pop A # Get result end end ret : cbl push L # Save C frame pointer ld L (CLink) # Restore link register link # Apply args push (Z I) # 'fun' xchg A E # First arg call boxE_E # Make number push E ld E C # Second arg call boxE_E # Make number push E ld E A # Third arg call boxE_E # Make number push E ld E X # Fourth arg call boxE_E # Make number push E ld E Y # Fifth arg call boxE_E # Make number push E ld Z S # Z on last argument link # Close frame lea Y (S VI) # Pointer to 'fun' in Y call applyXYZ_E # Apply ld A E # Return value shr A 4 # Normalize if c # Sign? neg A # Yes end drop pop L # Restore C frame pointer return (code 'cbl1 0) begin # Arguments in A, C, E, X and Y lea Z (Lisp) # Address of callback function jmp cbl : cbl2 begin lea Z (Lisp II) jmp cbl : cbl3 begin lea Z (Lisp (* 2 II)) jmp cbl : cbl4 begin lea Z (Lisp (* 3 II)) jmp cbl : cbl5 begin lea Z (Lisp (* 4 II)) jmp cbl : cbl6 begin lea Z (Lisp (* 5 II)) jmp cbl : cbl7 begin lea Z (Lisp (* 6 II)) jmp cbl : cbl8 begin lea Z (Lisp (* 7 II)) jmp cbl : cbl9 begin lea Z (Lisp (* 8 II)) jmp cbl : cbl10 begin lea Z (Lisp (* 9 II)) jmp cbl : cbl11 begin lea Z (Lisp (* 10 II)) jmp cbl : cbl12 begin lea Z (Lisp (* 11 II)) jmp cbl : cbl13 begin lea Z (Lisp (* 12 II)) jmp cbl : cbl14 begin lea Z (Lisp (* 13 II)) jmp cbl : cbl15 begin lea Z (Lisp (* 14 II)) jmp cbl : cbl16 begin lea Z (Lisp (* 15 II)) jmp cbl : cbl17 begin lea Z (Lisp (* 16 II)) jmp cbl : cbl18 begin lea Z (Lisp (* 17 II)) jmp cbl : cbl19 begin lea Z (Lisp (* 18 II)) jmp cbl : cbl20 begin lea Z (Lisp (* 19 II)) jmp cbl : cbl21 begin lea Z (Lisp (* 20 II)) jmp cbl : cbl22 begin lea Z (Lisp (* 21 II)) jmp cbl : cbl23 begin lea Z (Lisp (* 22 II)) jmp cbl : cbl24 begin lea Z (Lisp (* 23 II)) jmp cbl # (lisp 'sym ['fun]) -> num (code 'doLisp 2) push X push Y ld X E ld Y (E CDR) # Get tag call evSymY_E # Evaluate to a symbol ld A Lisp # Search lisp callback definitions ld C cbl1 do cmp E (A) # Found tag? jeq 10 # Yes add A II # Next entry add C "cbl2-cbl1" cmp A LispEnd until eq ld A Lisp # Not found, search for empty slot ld C cbl1 do cmp (A I) Nil # Empty? if eq # Yes 10 push C # Save function pointer push A # And callback entry ld (A) E # Store tag ld E ((Y CDR)) # Eval 'fun' eval pop A ld (A I) E # Store in slot pop E # Get function pointer func pop Y pop X test E (hex "F000000000000000") # Fit in short number? jnz boxNumE_E # No shl E 4 # Else make short number or E CNT ret end add A II # Next entry add C "cbl2-cbl1" cmp A LispEnd until eq ld Y CbErr jmp errEXYZ (code 'lisp 0) begin # Function name in A, arguments in C, E, X, Y and Z push L # Save C frame pointer ld L (CLink) # Restore link register link # Apply args push ZERO # Space for 'fun' xchg C E # First arg call boxE_E # Make number push E ld E C # Second arg call boxE_E # Make number push E ld E X # Third arg call boxE_E # Make number push E ld E Y # Fourth arg call boxE_E # Make number push E ld E Z # Fifth arg call boxE_E # Make number push E ld Z S # Z on last argument link # Close frame ld C 4 # Build name ld E A # Function name argument lea X (S VI) # Pointer to 'fun' entry do ld B (E) call byteSymBCX_CX # Pack byte inc E # Next byte nul (E) # Any? until z ld X (S VI) # Get name call findSymX_E # Find or create symbol lea Y (S VI) # Pointer to 'fun' in Y ld (Y) E # Store 'fun' call applyXYZ_E # Apply ld A E # Return value shr A 4 # Normalize if c # Sign? neg A # Yes end drop pop L # Restore C frame pointer return (code 'execE 0) push X ld X E link push (At) # Preserve '@' link exec X # Execute body ld (At) (L I) drop pop X ret (code 'runE_E 0) push X ld X E link push (At) # Preserve '@' link prog X # Run body ld (At) (L I) drop pop X ret (code 'funqE_FE 0) cnt E # Short number? jnz retz # Yes big E # Big number? jnz ret # No sym E # Symbol? jnz ret # Yes ld C (E CDR) # Check function body do atom C # More? while z # Yes cmp C E # Circular? jeq retnz # Yes ld A (C) # Next item atom A # Pair? if z # Yes num (A) # CAR a number? if nz # Yes atom (C CDR) # Must be the last jz retnz else cmp (A) Nil # CAR is NIL? jeq retnz # Yes cmp (A) TSym # CAR is T? jeq retnz # Yes end else cmp (C CDR) Nil # Atomic item must be the last jne ret end ld C (C CDR) loop cmp C Nil # Must be NIL-terminated jne ret ld E (E) # Get parameter(s) cmp E Nil # Any? ldz E TSym # No: Return T if ne # Yes ld C E do atom C # Atomic parameter? while z # No ld A (C) # Next parameter num A # Number? jnz ret # Yes atom A # List? jz retnz # Yes cmp A Nil # NIL? jeq retnz # Yes cmp A TSym # T? jeq retnz # Yes ld C (C CDR) # Rest cmp C E # Circular? jeq retnz # Yes loop cmp C TSym # T? jeq retnz # Yes num C # Number? jnz ret # Yes end ret (code 'evSymX_E 0) ld E (X) # Get CAR jmp evSymE_E (code 'evSymY_E 0) ld E (Y) # Get CAR (code 'evSymE_E) eval # Evaluate (code 'xSymE_E) num E # Number? if z # No sym E # Symbol? jnz ret # Yes end push X link push E # Save 'any' push ZERO # Number safe push ZERO # Result ld C 4 # Build name ld X S link call packECX_CX ld X (L I) # Get result call consSymX_E # Make transient symbol drop pop X ret (code 'evCntXY_FE 0) ld E (Y) # Get CAR (code 'evCntEX_FE) eval # Evaluate (code 'xCntEX_FE 0) cnt E # # Short number? jz cntErrEX # No shr E 4 # Normalize if c # Sign? neg E # Yes end ret # 'z' if null, 's' if negative (code 'xCntCX_FC 0) cnt C # # Short number? jz cntErrCX # No shr C 4 # Normalize if c # Sign? neg C # Yes end ret # 'z' if null, 's' if negative (code 'xCntAX_FA 0) cnt A # # Short number? jz cntErrAX # No shr A 4 # Normalize if c # Sign? neg A # Yes end ret # 'z' if null, 's' if negative (code 'boxE_E 0) null E # Positive? if ns # Yes test E (hex "F000000000000000") # Fit in short number? jnz boxNumE_E # No shl E 4 # Make short number or E CNT ret end neg E # Else negate test E (hex "F000000000000000") # Fit in short? if z # Yes shl E 4 # Make negative short number or E (| SIGN CNT) ret end call boxNumE_E # Make bignum or E SIGN # Set negative ret (code 'putStringB 0) push X push C ld X (StrX) # Get string status ld C (StrC) call byteSymBCX_CX # Add byte to result ld (StrC) C # Save string status ld (StrX) X pop C pop X ret (code 'begString 0) pop A # Get return address link push ZERO # Result ld (StrC) 4 # Build name ld (StrX) S link push (PutB) # Save 'put' ld (PutB) putStringB # Set new jmp (A) # Return (code 'endString_E 0) pop A # Get return address pop (PutB) # Restore 'put' ld E Nil # Preload NIL cmp (L I) ZERO # Name? if ne # Yes call cons_E # Cons symbol ld (E) (L I) # Set name or E SYM # Make symbol ld (E) E # Set value to itself end drop jmp (A) # Return ? (<> *TargetOS "Linux") (code 'msec_A) push C cc gettimeofday(Buf 0) # Get time ld A (Buf) # tv_sec mul 1000 # Convert to milliseconds ld (Buf) A # Save ld A (Buf I) # tv_usec div 1000 # Convert to milliseconds (C is zero) add A (Buf) pop C ret = # (args) -> flg (code 'doArgs 2) cmp (EnvNext) (EnvArgs) # VarArgs? ld E Nil ldnz E TSym # Yes ret # (next) -> any (code 'doNext 2) ld C (EnvNext) # VarArgs cmp C (EnvArgs) # Any? if ne # Yes sub C I # Get next ld E (C) ld (EnvNext) C ret end ld E Nil # No (more) arguments null C # Any previous arg? if nz # Yes ld (C) E # Set to NIL end ret # (arg ['cnt]) -> any (code 'doArg 2) null (EnvArgs) # Any args? jz retNil # No ld E (E CDR) # 'cnt' arg? atom E if nz # No ld E ((EnvNext)) # Return arg from last call to 'next' ret end ld E (E) eval # Eval 'cnt' test E SIGN # Negative? if z # No shr E 1 # Normalize to word index off E 1 # Clear 'cnt' tag if nz # Greater zero ld C (EnvNext) # VarArgs sub C E # Subtract from VarArgs pointer cmp C (EnvArgs) # Out of range? if ge # No ld E (C) # Get value ret end end end ld E Nil ret # (rest) -> lst (code 'doRest 2) ld E Nil # Return value ld C (EnvArgs) # VarArgs do cmp C (EnvNext) # Any? while ne # Yes call consE_A # New cell ld (A) (C) ld (A CDR) E ld E A add C I # Next loop ret (code 'tmDateC_E 0) ld4 (C TM_MDAY) # Get day ld X A ld4 (C TM_MON) # month inc A ld Y A ld4 (C TM_YEAR) # and year add A 1900 ld Z A # Date function (code 'dateXYZ_E 0) null Y # Month <= 0? jsz retNil cmp Y 12 # Month > 12? jgt retNil null X # Day <= 0? jsz retNil ld B (Y Month) # Max monthly days cmp X B # Day > max? if gt # Yes cmp Y 2 # February? jne retNil cmp X 29 # 29th? jne retNil test Z 3 # year a multiple of 4? jnz retNil ld A Z # Year ld C 0 div 100 null C # Multiple of 100? if z # Yes ld A Z # Year div 400 null C # Multiple of 400? jnz retNil end end ld A Z # Get year mul 12 # times 12 add A Y # plus month sub A 3 # minus 3 ld C 0 div 12 # divide by 12 ld E A # n = (12 * year + month - 3) / 12 ld C 0 div 100 # divide by 100 ld C E shr E 2 # n/4 add C C # n*2 sub E C # n/4 - n*2 sub E A # n/4 - n*2 - n/100 shr A 2 # n/400 add E A # E = n/4 - n*2 - n/100 + n/400 ld A Z # Year mul 4404 # times 4404 ld Z A ld A Y # Month mul 367 # times 367 add A Z # plus year*4404 sub A 1094 # minus 1094 div 12 # A = (4404*year + 367*month - 1094) / 12 add E A # Add up add E X # plus days shl E 4 # Make short number or E CNT ret # (date ['T]) -> dat # (date 'dat) -> (y m d) # (date 'y 'm 'd) -> dat | NIL # (date '(y m d)) -> dat | NIL (code 'doDate 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args atom Y # Any? if nz # No cc gettimeofday(Tv 0) # Get current time cc localtime(Tv) # Convert to local time ld (Time) A # Keep in 'Time' ld C A call tmDateC_E # Extract date else ld E (Y) # Eval first eval cmp E TSym # T? if eq # Yes cc gettimeofday(Tv 0) # Get current time cc gmtime(Tv) # Convert to Greenwich Mean Time ld (Time) A # Keep in 'Time' ld C A call tmDateC_E # Extract date else cmp E Nil # NIL? if ne # No atom E # List? if z # Yes ld C (E) # Extract year call xCntCX_FC ld Z C ld E (E CDR) ld C (E) # month call xCntCX_FC ld Y C ld C ((E CDR)) # and day call xCntCX_FC ld X C call dateXYZ_E else ld Y (Y CDR) # More args? atom Y if nz # No call xCntEX_FE # Get date ld A E # 100 * n mul 100 sub A 20 # minus 20 ld C 0 # divide by 3652425 div 3652425 ld Z A # year = (100*n - 20) / 3652425 add E A # n += (year - year/4) shr A 2 sub E A ld A E # n mul 100 # 100 * n sub A 20 # minus 20 div 36525 # divide by 36525 ld Z A # year = (100*n - 20) / 36525 mul 36525 # times 36525 div 100 # divide by 100 sub E A # n -= 36525*y / 100 ld A E # n mul 10 # times 10 sub A 5 # minus 5 div 306 # divide by 306 ld Y A # month = (10*n - 5) / 306 mul 306 # times 306 ld X A ld A E # n mul 10 # times 10 sub A X # minus 306*month add A 5 # push 5 div 10 # divide by 10 ld X A # day = (10*n - 306*month + 5) / 10 cmp Y 10 # month < 10? if lt # Yes add Y 3 # month += 3 else inc Z # Increment year sub Y 9 # month -= 9 end shl X 4 # Make short day or X CNT call cons_E # into cell ld (E) X ld (E CDR) Nil shl Y 4 # Make short month or Y CNT call consE_C # Cons ld (C) Y ld (C CDR) E shl Z 4 # Make short year or Z CNT call consC_E # Cons ld (E) Z ld (E CDR) C else call xCntEX_FE # Extract year ld Z E # into Z call evCntXY_FE # Eval month push E # Save ld Y (Y CDR) # Eval day call evCntXY_FE ld X E # Get day pop Y # and month call dateXYZ_E end end end end end pop Z pop Y pop X ret (code 'tmTimeY_E 0) ld4 (Y TM_HOUR) # Get hour mul 3600 ld E A ld4 (Y TM_MIN) # Get minute mul 60 add E A ld4 (Y TM_SEC) # Get second add E A shl E 4 # Make short number or E CNT ret # (time ['T]) -> tim # (time 'tim) -> (h m s) # (time 'h 'm ['s]) -> tim | NIL # (time '(h m [s])) -> tim | NIL (code 'doTime 2) push X push Y ld Y (E CDR) # Y on args atom Y # Any? if nz # No cc gettimeofday(Tv 0) # Get current time cc localtime(Tv) # Convert to local time ld Y A call tmTimeY_E # Extract time else ld E (Y) # Eval first eval cmp E TSym # T? if eq # Yes ld Y (Time) # Get time from last call to 'date' null Y # Any? ldz E Nil if nz # Yes call tmTimeY_E # Extract time end else cmp E Nil # NIL? if ne # No atom E # List? if z # Yes ld A (E) # Extract hour call xCntAX_FA mul 3600 ld Y A ld E (E CDR) ld A (E) # minute call xCntAX_FA mul 60 add Y A ld E (E CDR) # and second atom E # Any? ldnz E Y # No if z # Yes ld E (E) call xCntEX_FE add E Y # add minutes and hours end shl E 4 # Make short number or E CNT else ld Y (Y CDR) # More args? atom Y if nz # No call xCntEX_FE # Get time in total seconds ld A E ld C 0 div 60 # Seconds in C shl C 4 # Make short number or C CNT call cons_Y # into cell ld (Y) C ld (Y CDR) Nil ld A E ld C 0 div 60 # Total minutes in A ld C 0 div 60 # Minutes in C shl C 4 # Make short number or C CNT call consY_X ld (X) C ld (X CDR) Y xchg A E # Get total seconds again ld C 0 div 3600 # Hours in A shl A 4 # Make short number or A CNT call consX_E ld (E) A ld (E CDR) X else call xCntEX_FE # Extract hour ld A E mul 3600 push A # Save hour call evCntXY_FE # Eval minute ld A E mul 60 add (S) A # Add to hour ld Y (Y CDR) # Eval second atom Y # Any? if z # Yes call evCntXY_FE add (S) E end pop E # Get result shl E 4 # Make short number or E CNT end end end end end pop Y pop X ret # (usec ['flg]) -> num (code 'doUsec 2) ld E ((E CDR)) # Eval arg eval cmp E Nil # NIL? ldnz E (Tv I) # No: tv_usec from last 'time' call if eq # Yes cc gettimeofday(Tv 0) # Get time ld A (Tv) # tv_sec mul 1000000 # Convert to microseconds add A (Tv I) # tv_usec sub A (USec) # Diff to startup time ld E A end shl E 4 # Make short number or E CNT ret # (pwd) -> sym (code 'doPwd 2) cc getcwd(0 MAXPATHLEN) # Get current working directory null A # OK? jz retNil # No push A # Save buffer pointer ld E A # Make transient symbol call mkStrE_E cc free(pop) # Free buffer ret # (cd 'any) -> sym (code 'doCd 2) push Z ld E ((E CDR)) # Get arg call evSymE_E # Evaluate to a symbol call pathStringE_SZ # Write to stack buffer ld E Nil # Preload return value cc getcwd(0 MAXPATHLEN) # Get current working directory null A # OK? if nz # Yes push A # Save buffer pointer nul (S I) # CWD empty? jz 10 # Yes cc chdir(&(S I)) # Stack buffer nul4 # OK? if z # Yes 10 ld E (S) # Make transient symbol call mkStrE_E end cc free(pop) # Free buffer end ld S Z # Drop buffer pop Z ret # (ctty 'sym|pid) -> flg (code 'doCtty 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it cnt E # 'pid'? if nz # Yes shr E 4 # Normalize ld (TtyPid) E # Keep in global ld E TSym # Return T else sym E # Need symbol jz argErrEX push Z call bufStringE_SZ # Write to stack buffer ld E Nil # Preload return value cc freopen(S _r_ (stdin)) # Re-open standard input null A # OK? if nz # Yes cc freopen(S _w_ (stdout)) # Re-open standard output null A # OK? if nz # Yes cc freopen(S _w_ (stderr)) # Re-open standard error null A # OK? if nz # Yes ld (((OutFiles) I) II) 1 # (stdout) OutFiles[1]->tty ld E TSym # Return T end end end ld S Z # Drop buffer pop Z end pop X ret # (info 'any ['flg]) -> (cnt|T dat . tim) (code 'doInfo 2) push X push Y push Z ld X (E CDR) # Args ld E (X) # Get 'any' call evSymE_E # Evaluate to a symbol call pathStringE_SZ # Write to stack buffer ld Y S # path name pointer sub S (%% STAT) # 'stat' structure ld X (X CDR) # Eval 'flg' ld E (X) eval cmp E Nil # NIL? if eq # Yes cc stat(Y S) # Get status else cc lstat(Y S) # or link status end ld E Nil # Preload return value nul4 # 'stat' OK? if ns cc gmtime(&(S ST_MTIME)) # Get modification time ld Y A # Keep time pointer in Y call tmTimeY_E # Extract time push E # Save time push Z ld C Y # Extract date call tmDateC_E pop Z call cons_X # New cell ld (X) E # Set date pop (X CDR) # and time call consX_E # New cell ld4 (S ST_MODE) # Get 'st_mode' from 'stat' and A S_IFMT cmp A S_IFDIR # Directory? if eq # Yes ld (E) TSym # CAR is T else ld A (S ST_SIZE) # Get size shl A 4 # Make short number or A CNT ld (E) A end ld (E CDR) X end ld S Z # Drop buffers pop Z pop Y pop X ret # (file) -> (sym1 sym2 . num) | NIL (code 'doFile 2) ld C (InFile) # Current InFile? null C jz retNil # No ld E (C VI) # Filename? null E jz retNil # No ld B (char "/") # Contains a slash? slen C E # String length in C memb E C if eq # Yes do memb E C # Find last one until ne push Z ld Z E # Pointer to rest dec Z # without slash in Z call mkStrE_E # Make string call consE_C # Cons ld (C) E ld A ((InFile) V) # with 'src' shl A 4 # Make short number or A CNT ld (C CDR) A link push C # Save link ld E ((InFile) VI) # Filename again call mkStrEZ_A # Make string up to Z call consA_E # Cons into list ld (E) A ld (E CDR) (L I) drop pop Z else call mkStrE_E # Make string call consE_C # Cons ld (C) E ld A ((InFile) V) # with 'src' shl A 4 # Make short number or A CNT ld (C CDR) A call consC_A # Cons symbol ld (A) (hex "2F2E2") # "./" or A SYM # Make symbol ld (A) A # Set value to itself call consAC_E # Cons into list ld (E) A ld (E CDR) C end ret # (dir ['any] ['flg]) -> lst (code 'doDir 2) push X push Z ld X (E CDR) # Args ld E (X) # Get 'any' call evSymE_E # Evaluate to a symbol cmp E Nil # NIL? if eq # Yes cc opendir(_dot_) # Open "." directory else call pathStringE_SZ # Write to stack buffer cc opendir(S) # Open directory ld S Z # Drop buffer end null A # OK? jz 10 # No ld Z A # Get directory pointer ld X (X CDR) # Eval 'flg' ld E (X) eval ld X E # into X do cc readdir(Z) # Find first directory entry null A # OK? if z # No cc closedir(Z) # Close directory 10 ld E Nil # Return NIL pop Z pop X ret end lea E (A D_NAME) # Pointer to name entry cmp X Nil # flg? while eq # Yes ld B (E) # First char cmp B (char ".") # Skip dot names until ne call mkStrE_E # Make transient symbol call consE_C # Cons first cell ld (C) E ld (C CDR) Nil link push C # Result link do cc readdir(Z) # Read next directory entry null A # OK? while nz # Yes lea E (A D_NAME) # Pointer to name entry cmp X Nil # flg? jne 20 # Yes ld B (E) # First char cmp B (char ".") # Ignore dot names if ne 20 call mkStrE_E # Make transient symbol call consE_A # Cons next cell ld (A) E ld (A CDR) Nil ld (C CDR) A # Concat to result ld C A end loop ld E (L I) # Get result drop cc closedir(Z) # Close directory pop Z pop X ret # (cmd ['any]) -> sym (code 'doCmd 2) ld E ((E CDR)) # Get arg call evSymE_E # Evaluate to a symbol cmp E Nil # NIL? if eq ld E (AV0) # Return invocation command jmp mkStrE_E # Return transient symbol end push Z call bufStringE_SZ # Write to stack buffer slen C S # String length in C inc C # plus null byte movn ((AV0)) (S) C # Copy to system buffer ld S Z # Drop buffer pop Z ret # (argv [var ..] [. sym]) -> lst|sym (code 'doArgv 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld Z (AV) # Command line vector ld E (Z) null E # Empty? if nz # No ld B (E) # Single-dash argument? cmp B (char "-") if eq nul (E 1) if z # Yes add Z I # Skip "-" end end end cmp Y Nil # Any args? if eq # No ld E Nil # Preload return value null (Z) # More command line arguments? if nz # Yes ld E (Z) # Next call mkStrE_E # Make transient symbol call consE_C # First result cell ld (C) E ld (C CDR) Nil link push C # Result link do add Z I # Next command line argument null (Z) # Any? while nz # Yes ld E (Z) # Get it call mkStrE_E # Make transient symbol call consE_A # Next result cell ld (A) E ld (A CDR) Nil ld (C CDR) A # Concat to result ld C A loop ld E (L I) # Get result drop end else do atom Y # Atomic tail? while z # No ld E (Y) # Next 'var' call needVarEX ld E (Z) # Next command line argument null E # Any? if nz # No add Z I # Increment command line index end call mkStrE_E # Make transient symbol ld ((Y)) E # Set value ld Y (Y CDR) # Next arg cmp Y Nil # End of list? jeq 90 # Yes loop num Y # Need symbol jnz symErrYX call checkVarYX # Check variable ld E (Z) # Next command line argument null E # Any? if z # No ld E Nil # Set and return NIL ld (Y) E else call mkStrE_E # Make transient symbol call consE_C # First result cell ld (C) E ld (C CDR) Nil link push C # Result link do add Z I # Next command line argument null (Z) # Any? while nz # Yes ld E (Z) # Get it call mkStrE_E # Make transient symbol call consE_A # Next result cell ld (A) E ld (A CDR) Nil ld (C CDR) A # Concat to result ld C A loop ld E (L I) # Get and set result ld (Y) E drop end end 90 pop Z pop Y pop X ret # (opt) -> sym (code 'doOpt 2) ld E ((AV)) # Command line vector null E # Next string pointer? jz retNil # No ld B (E) # Single-dash argument? cmp B (char "-") if eq nul (E 1) jz retNil # Yes end add (AV) I # Increment vector pointer jmp mkStrE_E # Return transient symbol # (version ['flg]) -> lst (code 'doVersion 2) ld E ((E CDR)) # Eval flg eval cmp E Nil # Suppress output? if eq # No ld E Version # Print version do ld A (E) # Next number shr A 4 # Normalize call outWordA # Print it ld E (E CDR) # More numbers? atom E while z # Yes ld B `(char ".") # Output dot call (PutB) loop call newline end ld E Version # Return version ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/mkAsm0000755000000000000000000000031112265263724015102 0ustar rootroot#!/bin/sh # 08jun11abu if test -x /usr/bin/picolisp then /usr/bin/pil mkAsm.l "$@" elif test -x ../bin/picolisp then ../pil mkAsm.l "$@" else ../ersatz/pil mkAsm.l "$@" fi # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/mkAsm.l0000644000000000000000000000064712265263724015345 0ustar rootroot# 17oct12abu # (c) Software Lab. Alexander Burger (setq *Architecture (opt) *System (opt) *Format (opt) *TargetOS (opt) *Module (opt) *FPic (bool (opt)) ) (load "lib/asm.l" (pack "lib/fmt" *Format ".l") (pack "arch/" *Architecture ".l") ) (build (pack *Architecture *System "." *Module *Format) (opt) (load (pack "sys/" *Architecture *System ".defs.l") "defs.l" T) ) (bye) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/net.l0000644000000000000000000002371012265263724015057 0ustar rootroot# 04feb13abu # (c) Software Lab. Alexander Burger # (port ['T] 'cnt|(cnt . cnt) ['var]) -> cnt (code 'doPort 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld Z SOCK_STREAM # Type defaults to TCP ld E (Y) # Eval first arg eval cmp E TSym # 'T'? if eq # Yes ld Z SOCK_DGRAM # Type UDP ld Y (Y CDR) # Eval next arg ld E (Y) eval end cc socket(AF_INET6 Z 0) # Create socket nul4 # OK? js ipSocketErrX # No ld C A # Keep socket in C call closeOnExecAX ld A 0 # Socket option "off" st4 (Buf) # Store into 'optval' cc setsockopt(C IPPROTO_IPV6 IPV6_V6ONLY Buf 4) # "Not only IPv6" option nul4 # OK? js ipV6onlyErrX # No ld B 0 # Clear socket structure mset (Addr) SOCKADDR_IN6 ld A AF_INET6 st2 (Addr SIN6_FAMILY) ld B 0 # Clear sin6_addr mset (Addr SIN6_ADDR) 16 # "::" (16 null-bytes) cnt E # Single port-argument? if nz # Yes shr E 4 # Port zero? if nz # No ld A 1 # Socket option "on" st4 (Buf) # Store into 'optval' cc setsockopt(C SOL_SOCKET SO_REUSEADDR Buf 4) # "Reuse socket" option nul4 # OK? js ipReuseaddrErrX # No end push 0 # No range limit else atom E # Port range? jnz argErrEX # No ld A (E CDR) # Get second port ld E (E) # First port shr E 4 # Range start shr A 4 # Normalize second port push A # Range limit end do cc htons(E) # Convert port to network order st2 (Addr SIN6_PORT) # Store as port cc bind(C Addr SOCKADDR_IN6) # Try to bind socket nul4 # OK? while s # No inc E # Next port in range cmp E (S) # Exceeded limit? if gt # Yes cc close(C) # Close socket jmp ipBindErrX end loop add S I # Drop range limit cmp Z SOCK_STREAM # TCP socket? if eq # Yes cc listen(C 5) # Mark as server socket nul4 # OK? if s # No cc close(C) # Close socket jmp ipListenErrX end end ld Z C # Keep socket in Z ld Y (Y CDR) # Eval 'var' ld E (Y) eval cmp E Nil # Any? if ne # Yes ld A SOCKADDR_IN6 # Structure size st4 (Buf) # Store into 'namelen' cc getsockname(Z Addr Buf) # Get socket name nul4 # OK? if s # No cc close(Z) # Close socket jmp ipGetsocknameErrX end call needVarEX # Need variable ld2 (Addr SIN6_PORT) # Get port cc ntohs(A) # Convert to host byte order shl A 4 # Make short number or A CNT ld (E) A # Store in variable end ld E Z # Get socket shl E 4 # Make short number or E CNT pop Z pop Y pop X ret (code 'tcpAcceptA_FE) ld E A # Save socket in E call nonblockingA_A # Set socket to non-blocking push A # Old socket status flags ld C 200 # Maximally 20 seconds do ld A SOCKADDR_IN6 # Structure size st4 (Buf) # Store into 'addrlen' cc accept(E Addr Buf) # Accept connection nul4 # OK? if ns # Yes xchg A (S) # Save new socket, retrieve flags cc fcntl(E F_SETFL A) # Restore socket status flags ? (<> *TargetOS "Linux") # Non-Linux (BSD sockets)? cc fcntl((S) F_SETFL 0) # Yes: Set new socket to non-blocking = sub S (%% INET6_ADDRSTRLEN) # Allocate name buffer cc inet_ntop(AF_INET6 &(Addr SIN6_ADDR) S INET6_ADDRSTRLEN) ld E S call mkStrE_E # Make transient symbol ld (Adr) E # Store in '*Adr' add S (%% INET6_ADDRSTRLEN) # Drop buffer ld A (S) # Get socket call initInFileA_A # Init input file ld A (S) call initOutFileA_A # and output file pop E # Get new socket shl E 4 # Make short number or E CNT # Return 'nz' ret end cc usleep(100000) # Sleep 100 milliseconds dec C # Done? until z # Yes cc fcntl(E F_SETFL pop) # Restore socket status flags setz # Return 'z' ret # (accept 'cnt) -> cnt | NIL (code 'doAccept 2) push X ld X E ld E ((E CDR)) # Eval socket descriptor call evCntEX_FE ld A E # Accept connection call tcpAcceptA_FE # OK? ldz E Nil # No pop X ret # (listen 'cnt1 ['cnt2]) -> cnt | NIL (code 'doListen 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args call evCntXY_FE # Eval 'cnt1' ld Z E # Keep socket descriptor in Z ld Y (Y CDR) # Next arg ld E (Y) eval # Eval 'cnt2' cmp E Nil # Given? ldz Y -1 # No timeout if ne # Yes call xCntEX_FE # Milliseconds ld Y E end do ld C Z # Socket descriptor ld E Y # Milliseconds call waitFdCEX_A # Wait for events ld E Nil # Preload NIL null A # Timeout? while nz # No ld A Z # Accept connection call tcpAcceptA_FE # OK? until nz # Yes pop Z pop Y pop X ret # (host 'any) -> sym (code 'doHost 2) push Z ld E ((E CDR)) # Eval IP address call evSymE_E sub S I # 'lst' buffer call bufStringE_SZ # Write to stack buffer cc getaddrinfo(S 0 0 Z) # Get address info ld S Z # Drop buffer pop Z # Get 'lst' into Z ld E Nil # Preset return value nul4 # Address valid? if z # Yes sub S (%% NI_MAXHOST) # Hostname buffer ld C Z # Get 'lst' do nulp C # Any? while nz # Yes ld4 (C AI_ADDRLEN) cc getnameinfo((C AI_ADDR) A S NI_MAXHOST 0 0 NI_NAMEREQD) nul4 # OK? if z # Yes ld E S call mkStrE_E # Make transient symbol break T end ld C (C AI_NEXT) # Try next loop add S (%% NI_MAXHOST) # Drop buffer cc freeaddrinfo(Z) end pop Z ret # (connect 'any1 'any2) -> cnt | NIL (code 'doConnect 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args call evSymY_E # Eval host ld Y (Y CDR) # Next arg ld C SOCK_STREAM call serverCEY_FE # Found server? if z # Yes ld Z E # Keep list in Z do nulp E # Any? while nz # Yes ld4 (E AI_SOCKTYPE) # Create socket ld C A ld4 (E AI_FAMILY) cc socket(A C 0) nul4 # OK? if ns # Yes ld Y A # Keep socket in Y ld4 (E AI_ADDRLEN) cc connect(Y (E AI_ADDR) A) # Try to connect nul4 # OK? if z # Yes ld A Y call closeOnExecAX ld A Y # Get socket call initInFileA_A # Init input file ld A Y call initOutFileA_A # and output file ld E Y # Return socket shl E 4 # Make short number or E CNT jmp 80 end cc close(Y) # Close socket end ld E (E AI_NEXT) # Try next loop ld E Nil # Return NIL 80 cc freeaddrinfo(Z) end pop Z pop Y pop X ret (code 'serverCEY_FE) link push E # Host link sub S (%% ADDRINFO) # Hints ld B 0 # Clear hints mset (S) ADDRINFO ld A AF_UNSPEC # Accept IPv4 and IPv6 st4 (S AI_FAMILY) # Store into 'ai_family' ld A C # Get type st4 (S AI_SOCKTYPE) # Store into 'ai_socktype' call evSymY_E # Eval service call bufStringE_SZ # Write to stack buffer push Z # Save pointer to hints ld E (L I) # Get host call bufStringE_SZ # Write to stack buffer sub S I # 'lst' buffer cc getaddrinfo(&(S I) &(Z I) (Z) S) # Get address info pop E # Into 'lst' ld S (Z) # Clean up add S (%% ADDRINFO) nul4 # Address valid -> 'z' ldnz E Nil drop ret # (udp 'any1 'any2 'any3) -> any # (udp 'cnt) -> any (code 'doUdp 2) push X push Y push Z sub S UDPMAX # Allocate udp buffer ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval # 'any1' or 'cnt' ld Y (Y CDR) # Next arg? atom Y if nz # No call xCntEX_FE # 'cnt' cc recv(E S UDPMAX 0) # Receive message null A # OK? js 10 # No ld Z S # Buffer pointer lea (BufEnd) (Z UDPMAX) # Calculate buffer end ld (GetBinZ_FB) getUdpZ_FB # Set binary read function ld (Extn) (ExtN) # Set external symbol offset call binReadZ_FE # Read item? if c # No 10 ld E Nil # Return NIL end else call xSymE_E # Host ld C SOCK_DGRAM call serverCEY_FE # Found server? if z # Yes ld X E # Keep list in X ld Y (Y CDR) # Next arg ld E (Y) # Eval 'any2' eval ld Y E # Keep return value in Y ld Z S # Buffer pointer lea (BufEnd) (Z UDPMAX) # Calculate buffer end ld (PutBinBZ) putUdpBZ # Set binary print function ld (Extn) (ExtN) # Set external symbol offset call binPrintEZ # Print item ld E X # Get list do nulp E # Any? while nz # Yes ld4 (E AI_SOCKTYPE) # Create socket ld C A ld4 (E AI_FAMILY) cc socket(A C 0) nul4 # OK? if ns # Yes ld C A # Keep socket in C sub Z S # Data length ld4 (E AI_ADDRLEN) cc sendto(C S Z 0 (E AI_ADDR) A) # Transmit message cc close(C) # Close socket ld E Y # Get return value jmp 80 end ld E (E AI_NEXT) # Try next loop ld E Nil # Return NIL 80 cc freeaddrinfo(X) end end add S UDPMAX # Drop buffer pop Z pop Y pop X ret (code 'getUdpZ_FB 0) cmp Z (BufEnd) # End of buffer data? jeq retc # Yes: Return 'c' ld B (Z) # Next byte add Z 1 # (nc) ret (code 'putUdpBZ 0) cmp Z (BufEnd) # End of buffer data? jeq udpOvflErr # Yes ld (Z) B # Store byte inc Z # Increment pointer ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/subr.l0000644000000000000000000026004712265263724015252 0ustar rootroot# 22jul13abu # (c) Software Lab. Alexander Burger # (car 'var) -> any (code 'doCar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret # (cdr 'lst) -> any (code 'doCdr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCaar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCadr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCdar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCddr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCaaar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCaadr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCadar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCaddr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCdaar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCdadr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCddar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCdddr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCaaaar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCaaadr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCaadar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCaaddr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCadaar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCadadr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCaddar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCadddr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR pop X ret (code 'doCdaaar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCdaadr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCdadar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCdaddr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCddaar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCddadr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCdddar 2) push X ld X E ld E ((E CDR)) # Get arg eval num E # Need variable jnz varErrEX ld E (E) # Take CAR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret (code 'doCddddr 2) push X ld X E ld E ((E CDR)) # Get arg eval cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR cmp E Nil # Need list if ne atom E jnz lstErrEX end ld E (E CDR) # Take CDR pop X ret # (nth 'lst 'cnt ..) -> lst (code 'doNth 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'lst' eval link push E # Safe link ld Y (Y CDR) do atom E # End of 'lst'? while z # No call evCntXY_FE # Next 'cnt' ld C E # into C dec C # 'cnt' greater zero? if ns # Yes ld E (L I) # Get result do dec C # Iterate while ns ld E (E CDR) loop else ld E Nil # Return NIL break T end ld Y (Y CDR) # Next arg? atom Y while z # Yes ld E (E) # Take CAR ld (L I) E # Save loop drop pop Y pop X ret # (con 'lst 'any) -> any (code 'doCon 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'lst' eval atom E # Need pair jnz pairErrEX link push E # Safe link ld Y (Y CDR) # Next arg ld E (Y) # Eval 'any' eval ld ((L I) CDR) E # Concatenate drop pop Y pop X ret # (cons 'any ['any ..]) -> lst (code 'doCons 2) push X push Y ld X (E CDR) # Args ld E (X) # Eval first eval call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil link push C # Safe link do ld Y C # Y on last cell ld X (X CDR) # Args atom (X CDR) # more than one left? while z # Yes ld E (X) eval # Eval next arg call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil ld (Y CDR) C # Store in CDR of last cell loop ld E (X) # Last arg eval # Eval it ld (Y CDR) E # Store in CDR of last cell ld E (L I) # Return pair(s) drop pop Y pop X ret # (conc 'lst ..) -> lst (code 'doConc 2) push X push Y ld X (E CDR) # Args ld E (X) # Eval first eval ld Y E # Keep in Y link push E # Safe link do ld X (X CDR) # Next arg? atom X while z # Yes ld E (X) eval # Eval next arg atom Y # Result list? if nz # No ld (L I) E # Init result ld Y E # Keep in Y else do atom (Y CDR) # Find end of result list while z ld Y (Y CDR) loop ld (Y CDR) E end loop ld E (L I) # Return list drop pop Y pop X ret # (circ 'any ..) -> lst (code 'doCirc 2) push X push Y ld X (E CDR) # Args ld E (X) # Eval first eval call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil link push C # Safe link do ld Y C # Keep in Y ld X (X CDR) # Next arg? atom X while z # Yes ld E (X) eval # Eval next arg call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil ld (Y CDR) C # Store in CDR of last cell loop ld E (L I) # Return list ld (Y CDR) E # Make circular drop pop Y pop X ret # (rot 'lst ['cnt]) -> lst (code 'doRot 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'lst' eval atom E # Pair? if z # Yes link push E # Safe link ld Y (Y CDR) atom Y # Second arg? ldnz E 0 # Yes if z # No call evCntXY_FE # Eval 'cnt' end ld Y (L I) # Retrieve 'lst' ld X (Y) # Keep CAR do dec E # Decrement count while nz ld Y (Y CDR) # Next cell? atom Y while z # Yes cmp Y (L I) # Circular? while ne # No xchg X (Y) # Swap loop ld ((L I)) X # Store new CAR ld E (L I) drop end pop Y pop X ret # (list 'any ['any ..]) -> lst (code 'doList 2) push X push Y ld X (E CDR) # Args ld E (X) # Eval first eval call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil link push C # Safe link do ld Y C # Keep in Y ld X (X CDR) # Next arg? atom X while z # Yes ld E (X) eval # Eval next arg call consE_C # Cons with NIL ld (C) E ld (C CDR) Nil ld (Y CDR) C # Store in CDR of last cell loop ld E (L I) # Return list drop pop Y pop X ret # (need 'cnt ['lst ['any]]) -> lst # (need 'cnt ['num|sym]) -> lst (code 'doNeed 2) push X push Y ld X E ld Y (E CDR) # Y on args call evCntXY_FE # Eval 'cnt' ld X E # Keep in X ld Y (Y CDR) ld E (Y) # Eval next eval link atom E # First form? jz 10 # Yes cmp E Nil if eq # Yes 10 push E # 'lst' ld Y (Y CDR) ld E (Y) # Eval 'any' eval+ push E # 'any' else push Nil # 'lst' push E # 'num|sym' end link ld E (L II) # Get 'lst' or X X # 'cnt'? if nz # Yes if ns # > 0 ld Y E # 'lst' in Y do atom Y # Find end of 'lst' while z ld Y (Y CDR) dec X # Decrement 'cnt' loop do dec X # 'cnt' > 0? while ns # Yes ld C E call consC_E # Cons 'any' with 'lst' ld (E) (L I) ld (E CDR) C loop else atom E # 'lst' atomic? if nz call cons_E # Cons 'any' with NIL ld (E) (L I) ld (E CDR) Nil ld (L II) E # Save else do ld Y (E CDR) # Find last cell atom Y while z inc X # Increment 'cnt' ld E Y loop end do inc X # Increment 'cnt' while s call cons_A # Cons 'any' with NIL ld (A) (L I) ld (A CDR) Nil ld (E CDR) A # Append ld E (E CDR) loop ld E (L II) # Get result end end drop pop Y pop X ret # (range 'num1 'num2 ['num3]) -> lst (code 'doRange 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'num1' eval num E # Number? jz numErrEX # No link push E # Start value ld Y (Y CDR) ld E (Y) # Eval 'num2' eval+ num E # Number? jz numErrEX # No push E # End value push ONE # Increment ld E ((Y CDR)) # Eval 'num3' eval+ cmp E Nil # NIL? if ne # No num E # Number? jz numErrEX # No cmp E ZERO # Zero? jeq argErrEX # Yes test E SIGN # Negative? jnz argErrEX # Yes ld (S) E # Else set increment end link call cons_X # Build first cell tuck X # Result link ld (X) (L IV) # Start value ld (X CDR) Nil ld A (L IV) # Get start value ld E (L III) # and end value call cmpNumAE_F # Start <= end? ld A (L IV) # Get start value again if le # Yes do ld E (L II) # Increment start value call addAE_A push A ld E (L III) # Start <= end? call cmpNumAE_F while le # Yes pop A call consA_Y # Append to result ld (Y) A ld (Y CDR) Nil ld (X CDR) Y ld X Y loop else do ld E (L II) # Decrement start value call subAE_A push A ld E (L III) # Start >= end? call cmpNumAE_F while ge # Yes pop A call consA_Y # Append to result ld (Y) A ld (Y CDR) Nil ld (X CDR) Y ld X Y loop end ld E (L I) drop pop Y pop X ret # (full 'any) -> bool (code 'doFull 2) ld E (E CDR) # Get arg ld E (E) # Eval it eval do atom E # Pair? jnz retT # Yes cmp (E) Nil # Found NIL? jz retNil # Yes ld E (E CDR) loop # (make .. [(made 'lst ..)] .. [(link 'any ..)] ..) -> any (code 'doMake 2) push X ld X (E CDR) # Body push (EnvMake) # Save current 'make' env push (EnvYoke) link push Nil # Result ld (EnvMake) S # Tail address ld (EnvYoke) S # Head address link exec X ld E (L I) # Get result drop pop (EnvYoke) # Restore 'make' env pop (EnvMake) pop X ret # (made ['lst1 ['lst2]]) -> lst (code 'doMade 2) push X ld X E null (EnvMake) # In 'make'? jz makeErrX # No push Y ld Y (E CDR) # Y on args atom Y # Any? if z # Yes ld E (Y) # Eval 'lst1' eval ld ((EnvYoke)) E # Set new list ld Y (Y CDR) ld E (Y) # Eval 'lst2' eval atom E # Pair? if nz # No ld E ((EnvYoke)) # Retrieve new 'lst1' do ld A (E CDR) # Find last cell atom A while z ld E A loop end lea E (E CDR) # Set new tail address ld (EnvMake) E end ld E ((EnvYoke)) # Return list pop Y pop X ret # (chain 'lst ..) -> lst (code 'doChain 2) push X ld X E null (EnvMake) # In 'make'? jz makeErrX # No push Y ld Y (E CDR) # Y on args do ld E (Y) # Eval arg eval ld ((EnvMake)) E # Store new list atom E # Got a list? if z # Yes ld C E do ld A (C CDR) # Find last cell atom A while z ld C A loop lea C (C CDR) # Set new tail address ld (EnvMake) C end ld Y (Y CDR) # More args? atom Y until nz pop Y pop X ret # (link 'any ..) -> any (code 'doLink 2) push X ld X E null (EnvMake) # In 'make'? jz makeErrX # No push Y ld Y (E CDR) # Y on args do ld E (Y) # Eval arg eval call consE_C # Make new cell ld (C) E ld (C CDR) Nil ld ((EnvMake)) C # Store new tail lea C (C CDR) # Set new tail address ld (EnvMake) C ld Y (Y CDR) # More args? atom Y until nz pop Y pop X ret # (yoke 'any ..) -> any (code 'doYoke 2) push X ld X E null (EnvMake) # In 'make'? jz makeErrX # No push Y ld Y (E CDR) # Y on args do ld E (Y) # Eval arg eval call consE_A # Make new cell ld (A) E ld (A CDR) ((EnvYoke)) # Set head ld ((EnvYoke)) A ld Y (Y CDR) # More args? atom Y until nz do ld C ((EnvMake)) # Adjust tail address? atom C while z # Yes lea C (C CDR) # Set new tail address ld (EnvMake) C loop pop Y pop X ret # (copy 'any) -> any (code 'doCopy 2) ld E ((E CDR)) # Eval arg eval atom E # List? if z # Yes push Z ld Z E # Keep head in Z call consE_C # Copy first cell ld (C) (E) ld (C CDR) (E CDR) link push C # Result link do ld E (E CDR) atom E # More cells? while z # Yes cmp E Z # Circular? if eq # Yes ld (C CDR) (L I) # Concat head break T end call consE_A # Copy next cell ld (A) (E) ld (A CDR) (E CDR) ld (C CDR) A # Concat to result ld C A loop ld E (L I) # Get result drop pop Z end ret # (mix 'lst cnt|'any ..) -> lst (code 'doMix 2) push X ld X (E CDR) # X on args ld E (X) # Eval first eval cmp E Nil # Empty list? jz 10 # Yes atom E # Atomic? if z # No 10 push Y ld X (X CDR) # Next arg? atom X if z # Yes link push E # List link ld C (X) cnt C # Literal second arg? if z # No ld E C # Eval second arg eval else shr C 4 # Normalize if le # Negative ld E Nil else do dec C # nth while nz ld E (E CDR) loop ld E (E) end end call consE_C # Cons first result cell ld (C) E ld (C CDR) Nil tuck C # Result link do ld Y C # Keep in Y ld X (X CDR) # Next arg? atom X while z # Yes ld E (X) cnt E # Literal next arg? if z # No eval # Eval next arg else shr E 4 # Normalize if le # Negative ld E Nil else ld C (L II) # Get list do dec E # nth while nz ld C (C CDR) loop ld E (C) end end call consE_C # Cons first result cell ld (C) E ld (C CDR) Nil ld (Y CDR) C # Store in CDR of last cell loop ld E (L I) # Get result drop else ld E Nil # Return NIL end pop Y end pop X ret # (append 'lst ..) -> lst (code 'doAppend 2) push X ld X (E CDR) # Args do atom (X CDR) # More than one left? while z # Yes ld E (X) # Eval first eval atom E # Found a list? if z # Yes ld A E call consE_E # Copy first cell ld (E) (A) ld C (A CDR) ld (E CDR) C link push E # Result link do atom C # More cells? while z # Yes call consC_A # Copy next cell ld (A) (C) ld C (C CDR) ld (A CDR) C ld (E CDR) A # Concat to result ld E A loop push E # Save last cell do ld X (X CDR) # More than one left? atom (X CDR) while z # Yes ld E (X) # Eval next argument eval do atom E # Found a list? while z # Yes call consE_A # Copy cells ld (A) (E) ld E (E CDR) ld (A CDR) E ld ((S) CDR) A # Concat with last cell ld (S) A # New last cell loop loop ld E (X) # Eval last argument eval pop A # Get last cell ld (A CDR) E # Concat last list ld E (L I) # Get result drop pop X ret end ld X (X CDR) # Next arg loop ld E (X) # Eval last arg eval pop X ret # (delete 'any 'lst) -> lst (code 'doDelete 2) push X ld X (E CDR) # Args ld E (X) # Eval 'any' eval link push E # 'any' ld E ((X CDR)) # Eval 'lst' eval+ push E # 'lst' link atom E # Atomic? if z # No ld X E # Keep in X ld A (L II) # 'any' ld E (X) # Equal to CAR? call equalAE_F if eq # Yes ld E (X CDR) # Return CDR else call cons_C # Cons first item into C ld (C) (X) ld (C CDR) Nil tuck C # Result link do ld X (X CDR) # Next item atom X # More cells? while z # Yes ld A (L III) # 'any' ld E (X) # Equal to CAR? call equalAE_F if eq # Yes ld X (X CDR) # Skip this item break T end call cons_A # Cons next item ld (A) (X) ld (A CDR) Nil ld (C CDR) A # Append ld C A loop ld (C CDR) X # Set tail ld E (L I) # Get result end end drop pop X ret # (delq 'any 'lst) -> lst (code 'doDelq 2) push X ld X (E CDR) # Args ld E (X) # Eval 'any' eval link push E # 'any' ld E ((X CDR)) # Eval 'lst' eval+ push E # 'lst' link atom E # Atomic? if z # No ld X (L II) # 'any' cmp X (E) # Equal to CAR? if eq # Yes ld E (E CDR) # Return CDR else call cons_C # Cons first item into C ld (C) (E) ld (C CDR) Nil tuck C # Result link do ld E (E CDR) # Next item atom E # More cells? while z # Yes cmp X (E) # 'any' equal to CAR? if eq # Yes ld E (E CDR) # Skip this item break T end call cons_A # Cons next item ld (A) (E) ld (A CDR) Nil ld (C CDR) A # Append ld C A loop ld (C CDR) E # Set tail ld E (L I) # Get result end end drop pop X ret # (replace 'lst 'any1 'any2 ..) -> lst (code 'doReplace 2) push X ld X (E CDR) # X on args ld E (X) # Eval 'lst' eval atom E # Atomic? if z # No push Y push Z link push E # Save 'lst' ld Y E # Keep in Y do ld X (X CDR) # 'anyN' args? atom X while z # Yes ld E (X) # Eval next two args eval+ push E # Save first ld X (X CDR) ld E (X) # Eval second eval+ push E # Save second loop ld X L # X above 'any1' link ld C S # C below end of 'any' items call cons_Z # Build first result cell do sub X II # Try next 'any' pair cmp X C # Reached last 'any' item? while ne # No ld A (X) # Next item ld E (Y) # Equal to CAR of 'lst'? call equalAE_F if eq # Yes ld (Z) (X -I) # First result item is 'any2' jmp 10 end loop ld (Z) (Y) # First result item is CAR of 'lst' 10 ld (Z CDR) Nil tuck Z # Result link do ld Y (Y CDR) # More in 'lst'? atom Y while z # Yes ld X (L) # X above 'any1' do sub X II # Try next 'any' pair cmp X C # Reached top? while ne # No ld A (X) # Next item ld E (Y) # Equal to next item in 'lst'? call equalAE_F if eq # Yes call cons_E # Build next result cell ld (E) (X -I) # Next result item jmp 20 end loop call cons_E # Build next result cell ld (E) (Y) # Next result item from 'lst' 20 ld (E CDR) Nil ld (Z CDR) E # Concat to result ld Z E loop ld E (L I) # Get result drop pop Z pop Y end pop X ret # (strip 'any) -> any (code 'doStrip 2) ld E ((E CDR)) # Get arg eval # Eval it do atom E # List? while z # Yes cmp (E) Quote # CAR is 'quote'? while eq # Yes ld A (E CDR) # Get CDR cmp A E # Circular? while ne # No ld E A # Go to CDR loop ret # (split 'lst 'any ..) -> lst (code 'doSplit 2) push X ld X (E CDR) # Args ld E (X) # Eval 'lst' eval atom E # List? if z # Yes push Y push Z link push E # Save 'lst' do ld X (X CDR) # Next 'any' arg? atom X while z # Yes ld E (X) # Eval next arg eval+ push E # and save it loop # 'any' items lea C (L -I) # C is top of 'any' items, and adr of 'lst' ld Y Nil push Y # Result in Y ld Z Y push Z # Sublist in Z link do lea X (L III) # X on 'any' items do cmp X C # Reached top? while ne # No ld A (X) # Next item ld E ((C)) # Equal to CAR of 'lst'? call equalAE_F if eq # Yes atom Y # Result? if nz # No call cons_Y # Initial result cell ld (Y) (L I) # with sublist ld (Y CDR) Nil ld (L II) Y # Store in result else call cons_A # New cell ld (A) (L I) # with sublist ld (A CDR) Nil ld (Y CDR) A # Concat to result ld Y A end ld Z Nil # Clear sublist ld (L I) Z jmp 10 end add X I # Next 'any' item loop atom Z # Sublist? if nz # No call cons_Z # Initial sublist cell ld (Z) ((C)) ld (Z CDR) Nil ld (L I) Z # Store in sublist else call cons_A # New cell ld (A) ((C)) ld (A CDR) Nil ld (Z CDR) A # Concat to sublist ld Z A end 10 ld A ((C) CDR) # Next element of 'lst' ld (C) A atom A # Any? until nz # No call cons_E # Cons final sublist ld (E) (L I) ld (E CDR) Nil atom Y # Result so far? if z # Yes ld (Y CDR) E # Concat final sublist ld E (L II) # Get result end drop pop Z pop Y end pop X ret # (reverse 'lst) -> lst (code 'doReverse 2) ld E ((E CDR)) # Get arg eval # Eval it link push E # Safe link ld A Nil # Result do atom E # More cells? while z # Yes call consA_C # Cons next CAR ld (C) (E) ld (C CDR) A ld A C ld E (E CDR) loop ld E A # Return list drop ret # (flip 'lst ['cnt]) -> lst (code 'doFlip 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'lst' eval atom E # Pair? if z # Yes ld Y (Y CDR) atom Y # Second arg? if nz # No ld C (E CDR) # More than one element? atom C if z # Yes ld (E CDR) Nil # Make it the last cell do ld A (C CDR) # Get next cell ld (C CDR) E # Concat previous ld E C # Set to first atom A # Done? while z # No ld C A loop end else link push E # 'lst' link call evCntXY_FE # Eval 'cnt' ld C (L I) # Retrieve 'lst' drop ld X (C CDR) # More than one element? atom X if z # Yes dec E # 'cnt' > 1? if nsz # Yes ld (C CDR) (X CDR) # Swap first two cells ld (X CDR) C do dec E # Done? while nz # No ld A (C CDR) # More cells? atom A while z # Yes ld (C CDR) (A CDR) # Swap next two cells ld (A CDR) X ld X A loop ld C X # Return 'lst' end end ld E C # Return 'lst' end end pop Y pop X ret # (trim 'lst) -> lst (code 'doTrim 2) ld E ((E CDR)) # Get arg eval # Eval it link push E # Save link call trimE_E # Trim drop ret (code 'trimE_E 0) atom E # List? if z # Yes push (E) # Save CAR ld E (E CDR) # Trim CDR cmp S (StkLimit) # Stack check jlt stkErr call trimE_E cmp E Nil # All trimmed? if eq # Yes ld E (S) # Get CAR call isBlankE_F # Blank? if eq # Yes add S I # Drop CAR ld E Nil # Return NIL ret end call cons_E # New tail cell pop (E) # Copy CAR ld (E CDR) Nil ret end ld A E call consE_E # New cell pop (E) # Copy CAR ld (E CDR) A end ret # (clip 'lst) -> lst (code 'doClip 2) ld E ((E CDR)) # Get arg eval # Eval it do atom E # List? jnz ret # No push E ld E (E) # CAR blank? call isBlankE_F pop E while z # Yes ld E (E CDR) # Try next loop link push E # Save link call trimE_E # Trim drop ret # (head 'cnt|lst 'lst) -> lst (code 'doHead 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first ld Y (Y CDR) # Y on rest eval cmp E Nil # NIL? if ne # No atom E # 'lst' arg? if z # Yes link push E # First 'lst' link ld E (Y) # Eval second eval atom E # 'lst'? if z # Yes ld X E # 'lst' ld Y (L I) # Head list do ld A (X) ld E (Y) # Compare elements call equalAE_F # Equal? while eq # Yes ld Y (Y CDR) # Head done? atom Y if nz # Yes ld E (L I) # Return head drop pop Y pop X ret end ld X (X CDR) loop end drop jmp 10 end call xCntEX_FE # 'cnt' zero? if nz # No ld X E # 'cnt' in X ld E (Y) # Eval second eval atom E # List? if z # Yes null X # 'cnt' negative? if s # Yes ld Y E do inc X # Increment 'cnt' by length ld Y (Y CDR) atom Y until nz null X # 'cnt' still negative or zero? jsz 10 # Yes end link push E # Save 'lst' link call cons_Y # Build first cell ld (Y) (E) # From CAR of 'lst' ld (Y CDR) Nil tuck Y # Result link do dec X # Counted down? while nz # No ld E (E CDR) # List done? atom E while z # No call cons_A # Build next cell ld (A) (E) # From next list item ld (A CDR) Nil ld (Y CDR) A # Concat to result ld Y A loop ld E (L I) # Get result drop end else 10 ld E Nil # Return NIL end end pop Y pop X ret # (tail 'cnt|lst 'lst) -> lst (code 'doTail 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first ld Y (Y CDR) # Y on rest eval cmp E Nil # NIL? if ne # No atom E # 'lst' arg? if z # Yes link push E # First 'lst' link ld E (Y) # Eval second eval atom E # 'lst'? if z # Yes ld X E # 'lst' ld Y (L I) # Tail list do ld A X ld E Y # Compare lists call equalAE_F # Equal? if eq # Yes ld E (L I) # Return tail drop pop Y pop X ret end ld X (X CDR) # List done? atom X until nz # Yes end drop jmp 10 end call xCntEX_FE # 'cnt' zero? if nz # No ld X E # 'cnt' in X ld E (Y) # Eval second eval atom E # List? if z # Yes null X # 'cnt' negative? if s # Yes do ld E (E CDR) inc X # Take -nth until z else ld Y (E CDR) # Traverse CDR do dec X # Decrement 'cnt' while nz atom Y # End of list? while z # No ld Y (Y CDR) loop do atom Y # Traverse rest while z ld E (E CDR) # Step result ld Y (Y CDR) # and rest loop end end else 10 ld E Nil # Return NIL end end pop Y pop X ret # (stem 'lst 'any ..) -> lst (code 'doStem 2) push X push Y ld X (E CDR) # Args ld E (X) # Eval 'lst' eval link push E # Save 'lst' do ld X (X CDR) # Next 'any' arg? atom X while z # Yes ld E (X) # Eval next arg eval+ push E # and save it loop # 'any' items lea C (L -I) # C is top of 'any' items, and adr of 'lst' link ld Y (C) # Get 'lst' do atom Y # End of 'lst'? while z # No lea X (L I) # X on 'any' items do cmp X C # Reached top? while ne # No ld A (X) # Next item ld E (Y) # Found in 'lst'? call equalAE_F if eq # Yes ld (C) (Y CDR) # Set result break T end add X I # Next 'any' item loop ld Y (Y CDR) # Next in 'lst' loop ld E (C) # Get Result drop pop Y pop X ret # (fin 'any) -> num|sym (code 'doFin 2) ld E ((E CDR)) # Get arg eval # Eval it do atom E # Final atom? while z # No ld E (E CDR) # Try next loop ret # (last 'lst) -> any (code 'doLast 2) ld E ((E CDR)) # Get arg eval # Eval it atom E # List? if z # Yes do atom (E CDR) # Last cell? while z # No ld E (E CDR) # Try next loop ld E (E) # Get CAR end ret # (== 'any ..) -> flg (code 'doEq 2) push X ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Safe link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg cmp E (L I) # Eq to first arg? if ne # No drop ld E Nil # Return NIL pop X ret end loop drop ld E TSym # Return T pop X ret # (n== 'any ..) -> flg (code 'doNEq 2) push X ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Safe link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg cmp E (L I) # Eq to first arg? if ne # No drop ld E TSym # Return T pop X ret end loop drop ld E Nil # Return NIL pop X ret # (= 'any ..) -> flg (code 'doEqual 2) push X ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Safe link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg ld A (L I) # Get first arg call equalAE_F # Equal to previous? if ne # No drop ld E Nil # Return NIL pop X ret end loop drop ld E TSym # Return T pop X ret # (<> 'any ..) -> flg (code 'doNEqual 2) push X ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Safe link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg ld A (L I) # Get first arg call equalAE_F # Equal to previous? if ne # No drop ld E TSym # Return T pop X ret end loop drop ld E Nil # Return NIL pop X ret # (=0 'any) -> 0 | NIL (code 'doEq0 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E ZERO # Zero? jne retNil # No ret # (=T 'any) -> flg (code 'doEqT 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E TSym # T? jne retNil # No ret # (n0 'any) -> flg (code 'doNEq0 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E ZERO # Zero? jne retT # No ld E Nil ret # (nT 'any) -> flg (code 'doNEqT 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E TSym # T? jne retT # No ld E Nil ret # (< 'any ..) -> flg (code 'doLt 2) push X ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Safe link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg ld A (L I) # Get previous arg ld (L I) E # Store current call compareAE_F # Compare current with previous if ge # Not greater or equal drop ld E Nil # Return NIL pop X ret end loop drop ld E TSym # Return T pop X ret # (<= 'any ..) -> flg (code 'doLe 2) push X ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Safe link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg ld A (L I) # Get previous arg ld (L I) E # Store current call compareAE_F # Compare current with previous if gt # Not greater or equal drop ld E Nil # Return NIL pop X ret end loop drop ld E TSym # Return T pop X ret # (> 'any ..) -> flg (code 'doGt 2) push X ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Safe link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg ld A (L I) # Get previous arg ld (L I) E # Store current call compareAE_F # Compare current with previous if le # Not greater or equal drop ld E Nil # Return NIL pop X ret end loop drop ld E TSym # Return T pop X ret # (>= 'any ..) -> flg (code 'doGe 2) push X ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Safe link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg ld A (L I) # Get previous arg ld (L I) E # Store current call compareAE_F # Compare current with previous if lt # Not greater or equal drop ld E Nil # Return NIL pop X ret end loop drop ld E TSym # Return T pop X ret # (max 'any ..) -> any (code 'doMax 2) push X push Y ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Result link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg ld A (L I) # Get result ld Y E # Save next arg call compareAE_F # Compare arg with result if lt # Result is less than ld (L I) Y # Set new result end loop ld E (L I) # Result drop pop Y pop X ret # (min 'any ..) -> any (code 'doMin 2) push X push Y ld X (E CDR) # X on args ld E (X) eval # Eval first arg link push E # Result link do ld X (X CDR) # More args? atom X while z # Yes ld E (X) eval # Eval next arg ld A (L I) # Get result ld Y E # Save next arg call compareAE_F # Compare arg with result if gt # Result is greater ld (L I) Y # Set new result end loop ld E (L I) # Result drop pop Y pop X ret # (atom 'any) -> flg (code 'doAtom 2) ld E ((E CDR)) # Get arg eval # Eval it atom E # Atom? jnz retT # Yes ld E Nil ret # (pair 'any) -> any (code 'doPair 2) ld E ((E CDR)) # Get arg eval # Eval it atom E # Atom? jnz retNil # Yes ret # (circ? 'any) -> any (code 'doCircQ 2) ld E ((E CDR)) # Get arg eval # Eval it atom E # Atom? jnz retNil # Yes push Y call circE_YF # Circular? ldz E Y # Yes ldnz E Nil pop Y ret # (lst? 'any) -> flg (code 'doLstQ 2) ld E ((E CDR)) # Get arg eval # Eval it atom E # Pair? jz retT # Yes cmp E Nil # NIL? jeq retT # Yes ld E Nil ret # (num? 'any) -> num | NIL (code 'doNumQ 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jz retNil # No ret # (sym? 'any) -> flg (code 'doSymQ 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jnz retNil # Yes sym E # Symbol? jnz retT # Yes ld E Nil ret # (flg? 'any) -> flg (code 'doFlgQ 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E Nil # NIL? jeq retT # Yes cmp E TSym # T? jne retNil # No ret # (member 'any 'lst) -> any (code 'doMember 2) push X push Y ld X (E CDR) # Args ld E (X) # Eval 'any' eval link push E # 'any' link ld E ((X CDR)) # Eval 'lst' eval ld X (L I) # Retrieve 'any' ld Y E # Get 'lst call memberXY_FY # Member? ld E Y ldnz E Nil # No drop pop Y pop X ret # (memq 'any 'lst) -> any (code 'doMemq 2) push X ld X (E CDR) # Args ld E (X) # Eval 'any' eval link push E # 'any' link ld E ((X CDR)) # Eval 'lst' eval ld A (L I) # Retrieve 'any' drop # Clean up pop X ld C E # Keep head in C do atom E # List? while z # Yes cmp A (E) # Member? jeq ret # Return list ld E (E CDR) # Next item cmp C E # Hit head? jeq retNil # Yes loop cmp A E # Same atoms? jne retNil # No ret # (mmeq 'lst 'lst) -> any (code 'doMmeq 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval link push E # 'lst' link ld E ((X CDR)) # Eval second eval ld X (L I) # Retrieve first list ld C E # Keep second in C do atom X # Done? while z # No ld A (X) # Next item from first do atom E # List? while z # Yes cmp A (E) # Member? jeq 20 # Return list ld E (E CDR) # Next item cmp C E # Hit head? jz 10 # Yes loop cmp A E # Same atoms? jeq 20 # Yes ld X (X CDR) # Get CDR of first ld E C # Get second arg again loop 10 ld E Nil # Return NIL 20 drop pop X ret # (sect 'lst 'lst) -> lst (code 'doSect 2) push X push Y push Z ld X (E CDR) # Args ld E (X) # Eval first eval link push E # First 'lst' ld E ((X CDR)) # Eval second arg eval+ push E # Second 'lst' push Nil # Result link ld Z 0 # Empty result cell ld X (L III) # Get first list do atom X # Done? while z # No ld X (X) # CAR of first ld Y (L II) # Second call memberXY_FY # Member? if eq # Yes null Z # Result still empty? if z # Yes call cons_Z # Build first cell ld (Z) X ld (Z CDR) Nil ld (L I) Z # Store in result else call cons_A # Build next cell ld (A) X ld (A CDR) Nil ld (Z CDR) A # Concat to result ld Z A end end ld X ((L III) CDR) # Next item in first ld (L III) X loop ld E (L I) # Get result drop pop Z pop Y pop X ret # (diff 'lst 'lst) -> lst (code 'doDiff 2) push X push Y push Z ld X (E CDR) # Args ld E (X) # Eval first eval link push E # First 'lst' ld E ((X CDR)) # Eval second arg eval+ push E # Second 'lst' push Nil # Result link ld Z 0 # Empty result cell ld X (L III) # Get first list do atom X # Done? while z # No ld X (X) # CAR of first ld Y (L II) # Second call memberXY_FY # Member? if ne # No null Z # Result still empty? if z # Yes call cons_Z # Build first cell ld (Z) X ld (Z CDR) Nil ld (L I) Z # Store in result else call cons_A # Build next cell ld (A) X ld (A CDR) Nil ld (Z CDR) A # Concat to result ld Z A end end ld X ((L III) CDR) # Next item in first ld (L III) X loop ld E (L I) # Get result drop pop Z pop Y pop X ret # (index 'any 'lst) -> cnt | NIL (code 'doIndex 2) push X push Y push Z ld X (E CDR) # Args ld E (X) # Eval first eval link push E # 'any' link ld E ((X CDR)) # Eval second eval ld X (L I) # Get 'any' ld Y E # and 'lst' ld Z Y # Keep head in Z ld C 1 # Count in C do atom Y # List? while z # Yes ld A X ld E (Y) call equalAE_F # Found item? if eq # Yes ld E C # Get result shl E 4 # Make short number or E CNT jmp 90 # Found end inc C # Increment result ld Y (Y CDR) # Next item cmp Z Y # Hit head? until eq # Yes ld E Nil # Not found 90 drop pop Z pop Y pop X ret # (offset 'lst1 'lst2) -> cnt | NIL (code 'doOffset 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval link push E # 'lst1' link ld E ((X CDR)) # Eval 'lst2' eval ld C 0 # Init result ld X (L I) # Get 'lst1' do atom E # Any? while z # Yes inc C # Increment result ld A X # Get 'lst1' push E call equalAE_F # Same rest? if eq # Yes ld E C # Get result shl E 4 # Make short number or E CNT drop pop X ret end pop E ld E (E CDR) loop ld E Nil drop pop X ret # (prior 'lst1 'lst2) -> lst | NIL (code 'doPrior 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval link push E # 'lst1' link ld E ((X CDR)) # Eval 'lst2' eval ld C (L I) # Get 'lst1' drop pop X cmp C E # First cell? if ne # No do atom E # More? while z # Yes ld A (E CDR) cmp A C # Found prior cell? jeq ret # Yes ld E A loop end ld E Nil ret # (length 'any) -> cnt | T (code 'doLength 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? if nz # Yes ld A -2 # Scale jmp fmtNum0AE_E # Calculate length end sym E # Symbol? if z # No (list) ld C E # Keep list in C ld A ONE # Init counter do or (E) 1 # Mark ld E (E CDR) # Normal list? atom E if nz # Yes do off (C) 1 # Unmark ld C (C CDR) atom C # Done? until nz # Yes ld E A # Get count ret # Return length end test (E) 1 # Detected circularity? if nz # Yes do cmp C E # Skip non-circular part while ne off (C) 1 # Unmark ld C (C CDR) loop do off (C) 1 # Unmark circular part ld C (C CDR) cmp C E # Done? until eq # Yes ld E TSym ret # Return T end add A (hex "10") # Increment counter loop end # Symbol cmp E Nil # NIL? if eq # Yes ld E ZERO ret end push X ld X (E TAIL) ld E ZERO # Counter sym X # External symbol? if z # No call nameX_X # Get name ld C 0 do call symCharCX_FACX # Next char while nz add E (hex "10") # Increment counter loop end pop X ret # (size 'any) -> cnt (code 'doSize 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval 'any' num E # Number? if nz # Yes cnt E # Short number? if nz # Yes ld C ONE # Init counter shr E 3 # Normalize short, keep sign bit do shr E 8 # More bytes? while nz # Yes add C (hex "10") # Increment count loop else # Big number ld C (hex "82") # Count '8' significant bytes do ld A (E DIG) # Keep digit ld E (E BIG) # More cells? cnt E while z # Yes add C (hex "80") # Increment count by '8' loop shr E 4 # Normalize short shl A 1 # Get most significant bit of last digit addc E E # Any significant bits in short number? if nz # Yes do add C (hex "10") # Increment count shr E 8 # More bytes? until z # No end end else sym E # List? if z # Yes ld C ZERO # Init count call sizeCE_C # Count cell structures else # Symbol cmp E Nil # NIL? if eq # Yes ld C ZERO # Return zero else sym (E TAIL) # External symbol? if nz # Yes push Z call dbFetchEX ld X (E) # Get value call binSizeX_A # Calculate size add A (+ BLK 1) # plus block overhead ld Z A # Count in Z ld E (E TAIL) # Get properties off E SYM # Clear 'extern' tag do atom E # More properties? while z # Yes ld X (E) # Next property ld E (E CDR) atom X # Flag? if nz # Yes call binSizeX_A # Flag's size add Z A # Add to count add Z 2 # Plus 2 else push (X) # Save value ld X (X CDR) # Get key call binSizeX_A # Calculate size add Z A # Add to count pop X # Retrieve value call binSizeX_A # Calculate size add Z A # Add to count end loop ld C Z # Get count shl C 4 # Make short number or C CNT pop Z else ld E (E TAIL) call nameE_E # Get name cmp E ZERO # Any? if eq # No ld C ZERO # Return zero else cnt E # Short name? if nz # Yes ld C ONE # Init counter shr E 4 # Normalize do shr E 8 # More bytes? while nz # Yes add C (hex "10") # Increment count loop else # Long name ld C (hex "82") # Count '8' significant bytes do ld E (E BIG) # More cells? cnt E while z # Yes add C (hex "80") # Increment count loop shr E 4 # Any significant bits in short name? if nz # Yes do add C (hex "10") # Increment count shr E 8 # More bytes? until z # No end end end end end end end ld E C # Get count pop X ret (code 'sizeCE_C 0) push E # Save list do add C (hex "10") # Increment count atom (E) # Is CAR a pair? if z # Yes push E ld E (E) # Count CAR cmp S (StkLimit) # Stack check jlt stkErr call sizeCE_C pop E end or (E) 1 # Mark ld E (E CDR) # Normal list? atom E if nz # Yes pop E # Get original list do off (E) 1 # Unmark ld E (E CDR) atom E # Done? until nz # Yes ret end test (E) 1 # Detected circularity? if nz # Yes pop A # Get original list do cmp A E # Skip non-circular part while ne off (A) 1 # Unmark ld A (A CDR) loop do off (A) 1 # Unmark circular part ld A (A CDR) cmp A E # Done? until eq # Yes ret end loop # (bytes 'any) -> cnt (code 'doBytes 2) push X ld E ((E CDR)) # Get arg eval # Eval it ld X E call binSizeX_A # Calculate size ld E A shl E 4 # Make short number or E CNT pop X ret # (assoc 'any 'lst) -> lst (code 'doAssoc 2) push X ld X (E CDR) # Args ld E (X) # Eval 'any' eval link push E # 'any' link ld E ((X CDR)) # Eval 'lst' eval ld X E # into X do # assoc atom X # Done? if z # No atom (X) # CAR atomic? if z # No ld A (L I) # Retrieve 'any' ld E ((X)) # and CAAR call equalAE_F # Found? break eq # Yes end ld X (X CDR) # Next else ld E Nil # Return NIL drop pop X ret end loop ld E (X) # Return CAR drop pop X ret # (asoq 'any 'lst) -> lst (code 'doAsoq 2) push X ld X (E CDR) # Args ld E (X) # Eval 'any' eval link push E # 'any' link ld E ((X CDR)) # Eval 'lst' eval ld A (L I) # Retrieve 'any' drop # Clean up pop X do # asoq atom E # Done? jnz retNil # Yes ld C (E) # Get CAR atom C # Atomic? if z # No cmp A (C) # Found? break eq # Yes end ld E (E CDR) # Next loop ld E C # Return CAR ret # (rank 'any 'lst ['flg]) -> lst (code 'doRank 2) push X push Y push Z ld X (E CDR) # Args ld E (X) # Eval first eval link push E # 'any' ld X (X CDR) ld E (X) # Eval next eval+ push E # 'lst' link ld E ((X CDR)) # Eval 'flg' eval ld X (L I) # Get 'lst' in X atom X # Empty? if z # No ld Z 0 # Calculate length in Z ld Y X do inc Z # Increment length ld Y (Y CDR) # Next cell? atom Y until nz # No ld A ((X)) # First CAAR cmp E Nil # 'flg'? if eq # No ld E (L II) # Compare CAAR with 'any' call compareAE_F jgt 10 # Return NIL if too big do ld C Z # Length shr C 1 # One? while nz # No ld Y X # Offset Y do ld Y (Y CDR) dec C until z ld A ((Y)) # Compare CAAR ld E (L II) # with 'any' call compareAE_F # Greater? if gt # Search left half ld Y X # Move right pointer back shr Z 1 # Half length else # Search right half ld X Y # Move left pointer to offset ld C Z shr C 1 # Set length to remainder sub Z C end loop else ld E (L II) # Compare CAAR with 'any' call compareAE_F jlt 10 # Return NIL if too small do ld C Z # Length shr C 1 # One? while nz # No ld Y X # Offset Y do ld Y (Y CDR) dec C until z ld A ((Y)) # Compare CAAR ld E (L II) # with 'any' call compareAE_F # Smaller? if lt # Search left half ld Y X # Move right pointer back shr Z 1 # Half length else # Search right half ld X Y # Move left pointer to offset ld C Z shr C 1 # Set length to remainder sub Z C end loop end ld E (X) # Return CAR else 10 ld E Nil end drop pop Z pop Y pop X ret # (match 'lst1 'lst2) -> flg (code 'doMatch 2) push X ld X (E CDR) # Args ld E (X) # Eval 'lst1' eval link push E # Pattern ld E ((X CDR)) # Eval 'lst2' eval+ push E # Data link ld C (L II) # Pattern call matchCE_F # Match with data? ld E TSym # Yes ldnz E Nil # No drop pop X ret : matchCE_F do atom C # Pattern atomic? if nz # Yes num C # Symbol? if z # Yes ld A (C TAIL) call firstByteA_B # starting with "@"? cmp B (char "@") if eq # Yes ld (C) E # Set value to matched data ret # Return 'z' end end ld A C # Check if equal jmp equalAE_F end ld X (C) # CAR of pattern num X if z sym X # Symbolic? if nz # Yes ld A (X TAIL) call firstByteA_B # starting with "@"? cmp B (char "@") if eq # Yes atom E # Data atomic? if nz # Yes ld A (C CDR) # CDR of pattern equal to data? call equalAE_F jnz ret # No ld (X) Nil # Else clear value ret # Return 'z' end push C # Save pattern push E # and Data ld C (C CDR) # Get CDRs ld E (E CDR) cmp S (StkLimit) # Stack check jlt stkErr call matchCE_F # Match? pop E pop C if eq # Yes call cons_A # Cons CAR of data with NIL ld (A) (E) ld (A CDR) Nil ld ((C)) A # Set value jmp retz end push C # Save pattern push E # and Data ld C (C CDR) # CDR of pattern cmp S (StkLimit) # Stack check jlt stkErr call matchCE_F # Match with data? pop E pop C if eq # Yes ld ((C)) Nil # Set value to NIL ret # Return 'z' end push C # Save pattern push E # and Data ld E (E CDR) # CDR of data cmp S (StkLimit) # Stack check jlt stkErr call matchCE_F # Match with pattern? pop E pop C if eq # Yes ld X (C) # Pattern symbol call cons_A # Cons CAR of data into value ld (A) (E) ld (A CDR) (X) ld (X) A # Set value jmp retz end end end end atom E # Data atomic? jnz ret # Yes push (C CDR) # Save rests push (E CDR) ld C (C) # Get CARs ld E (E) cmp S (StkLimit) # Stack check jlt stkErr call matchCE_F # Match? pop E pop C jnz ret # No loop # (fill 'any ['sym|lst]) -> any (code 'doFill 2) push X ld X (E CDR) # Args ld E (X) # Eval 'any' eval link push E # Pattern ld E ((X CDR)) # Eval 'sym|lst' eval+ push E # 'sym|lst' link ld X E # in X ld E (L II) # Fill pattern call fillE_FE drop pop X ret : fillE_FE num E # Data numeric? jnz ret # Return 'nz' sym E # Data symbolic? if nz # Yes cmp E (E) # Auto-quoting? jeq retnz # Yes cmp X Nil # 'sym|lst'? if eq # No cmp E At # '@'? jeq retnz # Return 'nz' ld A (E TAIL) call firstByteA_B # starting with "@"? cmp B (char "@") if eq # Yes ld E (E) # Return 'z' end ret # Else 'nz' end ld C X # 'memq' do atom C # List? while z # Yes cmp E (C) # Member? if eq # Yes ld E (E) # Return 'z' ret end ld C (C CDR) # Next element loop cmp E C # Same? if eq # Yes ld E (E) # Return 'z' end ret # Else 'nz' end push E # Save ld E (E) # Recurse on CAR cmp S (StkLimit) # Stack check jlt stkErr cmp E Up # Expand expression? if eq # Yes pop E # Get pattern ld E (E CDR) # Skip '^' push (E CDR) # Save rest ld E (E) # Eval expression eval atom E # List? if nz # No pop E # Recurse on rest call fillE_FE setz # Set modified ret end pop C # Get pattern link push E # Result link ld E C # Recurse on rest call fillE_FE ld C (L I) # Result do atom (C CDR) # Find last cell while z ld C (C CDR) loop ld (C CDR) E # Set rest ld E (L I) # Get result drop setz # Modified ret end call fillE_FE # Modified? if z # Yes pop C # Get pattern link push E # Modified CAR link ld E (C CDR) # Recurse on CDR call fillE_FE call consE_A # Cons result ld (A) (L I) ld (A CDR) E ld E A drop setz # Modified ret end ld E ((S) CDR) # Recurse on CDR call fillE_FE # Modified? if z # Yes call consE_A # Cons result pop C ld (A) (C) # Unmodified CAR ld (A CDR) E # Modified CDR ld E A setz # Modified ret end pop E # Return 'nz' ret ### Declarative Programming ### (code 'unifyCEYZ_F 0) 10 num Y # x1 symbolic? if z sym Y if nz # Yes ld A (Y TAIL) # x1 call firstByteA_B # starting with "@"? cmp B (char "@") if eq # Yes ld X ((Penv)) # Get pilog environment do ld A (X) # car(x) atom A # List? while z # Yes ld A (A) # caar(x) cmp C (A) # n1 == caaar(x)? if eq # Yes cmp Y (A CDR) # x1 == cdaar(x)? if eq # Yes ld A ((X) CDR) ld C (A) # n1 = cadar(x) ld Y (A CDR) # x1 = cddar(x) jmp 10 end end ld X (X CDR) loop end end end 20 num Z # x2 symbolic? if z sym Z if nz # Yes ld A (Z TAIL) # x2 call firstByteA_B # starting with "@"? cmp B (char "@") if eq # Yes ld X ((Penv)) # Get pilog environment do ld A (X) # car(x) atom A # List? while z # Yes ld A (A) # caar(x) cmp E (A) # n2 == caaar(x)? if eq # Yes cmp Z (A CDR) # x2 == cdaar(x)? if eq # Yes ld A ((X) CDR) ld E (A) # n2 = cadar(x) ld Z (A CDR) # x2 = cddar(x) jmp 20 end end ld X (X CDR) loop end end end cmp C E # n1 == n2? if eq # Yes ld A Y # x1 push E ld E Z # x2 call equalAE_F # Equal? pop E jeq ret # Yes end num Y # x1 symbolic? if z sym Y if nz # Yes ld A (Y TAIL) # x1 call firstByteA_B # starting with "@"? cmp B (char "@") if eq # Yes cmp Y At # x1 == @? if ne # No call cons_A # (n1 . x1) ld (A) C ld (A CDR) Y call consA_C # (n2 . x2) ld (C) E ld (C CDR) Z call consAC_E # ((n1 . x1) . (n2 . x2)) ld (E) A ld (E CDR) C ld X (Penv) # Concat to pilog environment call consE_A ld (A) E ld (A CDR) (X) ld (X) A # Store in environment end setz ret end end end num Z # x2 symbolic? if z sym Z if nz # Yes ld A (Z TAIL) # x2 call firstByteA_B # starting with "@"? cmp B (char "@") if eq # Yes cmp Z At # x2 == @? if ne # No call cons_A # (n1 . x1) ld (A) C ld (A CDR) Y call consA_C # (n2 . x2) ld (C) E ld (C CDR) Z call consAC_E # ((n2 . x2) . (n1 . x1)) ld (E CDR) A ld (E) C ld X (Penv) # Concat to pilog environment call consE_A ld (A) E ld (A CDR) (X) ld (X) A # Store in environment end setz ret end end end atom Y # x1 atomic? if z # No atom Z # x2 atomic? if z # No push ((Penv)) # Save pilog environment push C # and parameters push E push Y push Z ld Y (Y) # car(x1) ld Z (Z) # car(x2) cmp S (StkLimit) # Stack check jlt stkErr call unifyCEYZ_F # Match? pop Z pop Y pop E pop C if eq # Yes ld Y (Y CDR) # cdr(x1) ld Z (Z CDR) # cdr(x2) cmp S (StkLimit) # Stack check jlt stkErr call unifyCEYZ_F # Match? if eq # Yes lea S (S I) # Drop pilog environment ret # 'z' end end pop ((Penv)) # Restore pilog environment ret # nz end end ld A Y # Compare x1 and x2 ld E Z jmp equalAE_F # (prove 'lst ['lst]) -> lst (code 'doProve 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval atom E # Atomic? if nz # Yes pop X ld E Nil # Return NIL ret end push Y push Z push (Penv) # Save pilog environment pointers push (Pnl) link push (At) # @ push E # q ld Z E # Keep in Z ld X (X CDR) # Second arg ld E (X) # Eval debug list eval+ push E # dbg ld Y ((Z)) # env = caar(q) push Y # env ld (Penv) S # Set pilog environment pointer ld (Z) ((Z) CDR) # car(q) = cdar(q) push (Y) # n ld Y (Y CDR) push (Y) # nl ld (Pnl) S # Set pointer ld Y (Y CDR) push (Y) # alt ld Y (Y CDR) push (Y) # tp1 ld Y (Y CDR) push (Y) # tp2 ld Y (Y CDR) push Nil # e link ld (L VII) Y # Set env do atom (L III) # tp1? jz 10 # Yes atom (L II) # or tp2? while z # Yes 10 atom (L IV) # alt? if z # Yes ld (L I) (L VII) # e = env ld C ((L V)) # car(nl) ld Y (((L III)) CDR) # cdar(tp1) ld E (L VI) # n ld Z (((L IV))) # caar(alt) call unifyCEYZ_F # Match? if ne # No ld X ((L IV) CDR) # alt = cdr(alt) ld (L IV) X atom X # Atomic? if nz # Yes ld X (((L IX))) # env = caar(q) ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q) ld (L VI) (X) # n = car(env) ld X (X CDR) # env = cdr(env) ld (L V) (X) # nl = car(env) ld X (X CDR) # env = cdr(env) ld (L IV) (X) # alt = car(env) ld X (X CDR) # env = cdr(env) ld (L III) (X) # tp1 = car(env) ld X (X CDR) # env = cdr(env) ld (L II) (X) # tp2 = car(env) ld X (X CDR) # env = cdr(env) ld (L VII) X # Set env end else atom (L VIII) # dbg? if z # Yes ld A (((L III))) # memq(caar(tp1), dbg) ld E (L VIII) do cmp A (E) # memq? if eq # Yes ld C TSym # get(caar(tp1), T) ld E (((L III))) call getEC_E ld X E ld C 0 # Index count do inc C # Increment ld A ((L IV)) # Found car(alt)? ld E (X) ld X (X CDR) call equalAE_F until eq # Yes ld A C call outWordA # Print level number call space ld E ((L III)) # car(tp1) call uniFillE_E # Fill with values call printE_E # and print call newline break T end ld E (E CDR) # Next debug symbol atom E # Any? until nz # No end atom ((L IV) CDR) # cdr(alt)? if z # Yes call cons_A # cons(tp2, e) ld (A) (L II) ld (A CDR) (L I) call consA_C # cons(tp1, @) ld (C) (L III) ld (C CDR) A call consC_A # cons(cdr(alt), @) ld (A) ((L IV) CDR) ld (A CDR) C call consA_C # cons(nl, @) ld (C) (L V) ld (C CDR) A call consC_A # cons(n, @) ld (A) (L VI) ld (A CDR) C call consA_C # cons(@, car(q)) ld (C) A ld (C CDR) ((L IX)) ld ((L IX)) C # -> car(q) end ld C (L VI) # n call cons_A # cons(n, nl) ld (A) C ld (A CDR) (L V) ld (L V) A # -> nl add C (hex "10") # Increment ld (L VI) C # -> n call cons_A # cons(cdr(tp1), tp2) ld (A) ((L III) CDR) ld (A CDR) (L II) ld (L II) A # -> tp2 ld (L III) (((L IV)) CDR) # cdar(alt) -> tp1 ld (L IV) Nil # alt = NIL end continue T end ld X (L III) # tp1? atom X if nz # No ld C (L II) # tp2 ld (L III) (C) # tp1 = car(tp2) ld (L II) (C CDR) # tp2 = cdr(tp2) ld (L V) ((L V) CDR) # nl = cdr(nl) continue T end ld Y (X) # car(tp1) cmp Y TSym # car(tp1) == T? if eq do ld C ((L IX)) # car(q) atom C # Any? while z # Yes cmp ((C)) ((L V)) # caaar(q) >= car(nl)? while ge # Yes ld ((L IX)) (C CDR) # car(q) = cdar(q) loop ld (L III) (X CDR) # tp1 = cdr(tp1) continue T end num (Y) # caar(tp1) numeric? if nz # Yes ld Z (Y CDR) # Run Lisp body prog Z ld (L I) E # -> e ld C (Y) # Get count shr C 4 # Normalize short ld A (L V) # nl do dec C # Decrement while nsz ld A (A CDR) # Skip loop call cons_C # cons(car(A), nl) ld (C) (A) ld (C CDR) (L V) ld (L V) C # -> nl call cons_C # cons(cdr(tp1), tp2) ld (C) (X CDR) ld (C CDR) (L II) ld (L II) C # -> tp2 ld (L III) (L I) # tp1 = e continue T end ld E (Y) # caar(tp1) cmp E Up # Lisp call? if eq # Yes ld Z ((Y CDR) CDR) # Run Lisp body prog Z ld (L I) E # -> e cmp E Nil # Any? jeq 20 # No ld C ((L V)) # car(nl) ld Y ((Y CDR)) # cadar(tp1) ld E C # car(nl) ld Z (L I) # e call unifyCEYZ_F # Match? jne 20 # No ld (L III) ((L III) CDR) # tp1 = cdr(tp1) continue T end ld C TSym # get(caar(tp1), T) call getEC_E ld (L IV) E # -> alt atom E # Atomic? if nz # Yes 20 ld X (((L IX))) # env = caar(q) ld ((L IX)) (((L IX)) CDR) # car(q) = cdar(q) ld (L VI) (X) # n = car(env) ld X (X CDR) # env = cdr(env) ld (L V) (X) # nl = car(env) ld X (X CDR) # env = cdr(env) ld (L IV) (X) # alt = car(env) ld X (X CDR) # env = cdr(env) ld (L III) (X) # tp1 = car(env) ld X (X CDR) # env = cdr(env) ld (L II) (X) # tp2 = car(env) ld X (X CDR) # env = cdr(env) ld (L VII) X # Set env end loop ld (L I) Nil # e = NIL ld X (L VII) # env do atom (X CDR) while z ld Y ((X)) # Next binding cmp (Y) ZERO # Top? if eq # Yes ld C ZERO # Look up ld E (Y CDR) call lookupCE_E call consE_A # Cons with variable ld (A) (Y CDR) ld (A CDR) E call consA_E # and e ld (E) A ld (E CDR) (L I) ld (L I) E # -> e end ld X (X CDR) loop ld (At) (L (+ IX I)) # Restore '@' ld E (L I) # Get e atom E # Atomic? if nz # Yes atom (L VII) # 'env' atomic? ld E Nil ldz E TSym # No end drop pop (Pnl) # Restore pilog environment pointers pop (Penv) pop Z pop Y pop X ret (code 'lupCE_E 0) # Z num E # x symbolic? if z sym E if nz # Yes ld A (E TAIL) # x call firstByteA_B # starting with "@"? cmp B (char "@") if eq # Yes ld Z ((Penv)) # Get pilog environment do ld A (Z) # car(y) atom A # List? while z # Yes ld A (A) # caar(y) cmp C (A) # n == caaar(y)? if eq # Yes cmp E (A CDR) # x == cdaar(y)? if eq # Yes ld A ((Z) CDR) ld C (A) # n = cadar(y) ld E (A CDR) # x = cddar(y) cmp S (StkLimit) # Stack check jlt stkErr jmp lupCE_E end end ld Z (Z CDR) loop end end end atom E # Atomic? if z # No push C # Save parameters push E ld E (E) # lup(n, car(x)) cmp S (StkLimit) # Stack check jlt stkErr call lupCE_E pop A pop C link push E # Save link ld E (A CDR) # lup(n, cdr(x)) cmp S (StkLimit) # Stack check jlt stkErr call lupCE_E call consE_A # Cons ld (A) (L I) ld (A CDR) E ld E A drop end ret (code 'lookupCE_E 0) # Z call lupCE_E num E # Symbolic? if z sym E if nz # Yes ld A (E TAIL) call firstByteA_B # starting with "@"? cmp B (char "@") jeq retNil # Yes end end ret (code 'uniFillE_E 0) num E # Number? if z # No sym E # Symbol? if nz # Yes ld C (((Pnl))) # Get Env jmp lupCE_E # Look up end push E # Save list ld E (E) # Recurse on CAR cmp S (StkLimit) # Stack check jlt stkErr call uniFillE_E pop A # Get list link push E # Save result link ld E (A CDR) # Recurse on CDR cmp S (StkLimit) # Stack check jlt stkErr call uniFillE_E call consE_A # Return cell ld (A) (L I) ld (A CDR) E ld E A drop end ret # (-> any [num]) -> any (code 'doArrow 2) push Z ld E (E CDR) # E on args ld C ((Pnl)) # Environments ld A (E CDR) num (A) # 'num' arg? if nz # Yes ld A (A) # Get count shr A 4 # Normalize short do dec A # Decrement while nsz ld C (C CDR) # Skip loop end ld C (C) # Get env ld E (E) # 'sym' call lookupCE_E pop Z ret # (unify 'any) -> lst (code 'doUnify 2) push X push Y push Z ld E ((E CDR)) # Get arg eval # Eval it link push E # Save 'any' link ld A ((Pnl)) # Environments ld C ((A CDR)) # Second environment ld E (A) # First environment ld Y (L I) # 'any' ld Z Y # 'any' call unifyCEYZ_F # Match? ld E Nil if eq # Yes ld E ((Penv)) end drop pop Z pop Y pop X ret ## List Merge Sort: Bill McDaniel, DDJ Jun99 ### # (sort 'lst ['fun]) -> lst (code 'doSort 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'lst' eval atom E # List? if z # Yes push Z link push E # Save 'lst' ld E ((Y CDR)) # Eval 'fun' eval+ ld A Nil # Init local elements cmp E Nil # User function? if eq # No ld Z cmpDfltA_F # Use default sort function xchg E (S) # out[1] else ld Z cmpUserAX_F # Use user supplied sort function xchg E (S) # 'fun' push A push A # Apply args push A # out[1] end push E # out[0] 'lst' push A # in[1] push A # in[0] push A # last[1] push A # last[0] push A # p link push A # tail[1] push A # tail[0] do ld (L IV) (L VI) # in[0] = out[0] ld (L V) (L VII) # in[1] = out[1] lea Y (L IV) # &in[0] atom (L V) # in[1] list? if z # Yes ld A Y # in call (Z) # Less? if ge # No lea Y (L V) # &in[1] end end ld A (Y) # p = in[i] ld (L I) A atom A # List? if z # Yes ld (Y) (A CDR) # in[i] = cdr(in[i]) end ld (L VI) A # out[0] = p lea (L -II) (A CDR) # tail[0] = &cdr(p) ld (L III) (L VI) # last[1] = out[0] ld (A CDR) Nil # cdr(p) = Nil ld (L VII) Nil # out[1] = Nil lea (L -I) (L VII) # tail[1] = &out[1] do atom (L V) # in[1] atomic? if nz # Yes atom (L IV) # in[0] also atomic? break nz # Yes ld Y (L IV) # p = in[0] ld (L I) Y atom Y # List? if z # Yes ld (L IV) (Y CDR) # in[0] = cdr(in[0]) end ld (L II) Y # last[0] = p lea A (L II) # last call (Z) # Less? if lt # Yes xchg (L -I) (L -II) # Exchange tail[0] and tail[1] end else atom (L IV) # in[0] atomic? if nz # Yes atom (L V) # in[1] also atomic? break nz # Yes ld Y (L V) # p = in[1] ld (L I) Y ld (L II) Y # last[0] = p ld (L V) (Y CDR) # in[1] = cdr(in[1]) lea A (L II) # last call (Z) # Less? if lt # Yes xchg (L -I) (L -II) # Exchange tail[0] and tail[1] end else # Both in[0] and in[1] are lists lea A (L II) # last ld (A) (L IV) # last[0] = in[0] call (Z) # Less? if lt # Yes lea A (L II) # last ld (A) (L V) # last[0] = in[1] call (Z) # Less? if ge # No ld Y (L V) # p = in[1] ld (L I) Y ld (L V) (Y CDR) # in[1] = cdr(in[1]) else lea A (L IV) # in call (Z) # Less? if lt # Yes ld Y (L IV) # p = in[0] ld (L I) Y ld (L IV) (Y CDR) # in[0] = cdr(in[0]) else ld Y (L V) # p = in[1] ld (L I) Y ld (L V) (Y CDR) # in[1] = cdr(in[1]) end xchg (L -I) (L -II) # Exchange tail[0] and tail[1] end else lea A (L II) # last ld (A) (L V) # last[0] = in[1] call (Z) # Less? if lt # Yes ld Y (L IV) # p = in[0] ld (L I) Y ld (L IV) (Y CDR) # in[0] = cdr(in[0]) else lea A (L IV) # in call (Z) # Less? if lt # Yes ld Y (L IV) # p = in[0] ld (L I) Y ld (L IV) (Y CDR) # in[0] = cdr(in[0]) else ld Y (L V) # p = in[1] ld (L I) Y ld (L V) (Y CDR) # in[1] = cdr(in[1]) end end end end end ld ((L -II)) Y # *tail[0] = p lea (L -II) (Y CDR) # tail[0] = &cdr(p) ld (Y CDR) Nil # cdr(p) = Nil ld (L III) Y # last[1] = p loop atom (L VII) # out[1] until nz ld E (L VI) # Return out[0] drop pop Z end pop Y pop X ret (code 'cmpDfltA_F 0) ld E ((A I)) # Get CAR of second item ld A ((A)) # and CAR of first item jmp compareAE_F # Build-in compare function (code 'cmpUserAX_F 0) push Y push Z lea Z (L VIII) # Point Z to apply args ld (Z) ((A I)) # Copy CAR of second item ld (Z I) ((A)) # and CAR of first item lea Y (Z II) # Point Y to 'fun' call applyXYZ_E # Apply cmp E Nil # Check result if ne setc # Set carry if "less" end pop Z pop Y ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sym.l0000644000000000000000000024555112265263724015112 0ustar rootroot# 14nov13abu # (c) Software Lab. Alexander Burger ### Compare long names ### (code 'cmpLongAX_F 0) push X # Keep X do cmp (A DIG) (X DIG) # Equal? if ne # No pop X ret end ld A (A BIG) ld X (X BIG) big A # A on last digit? if z # Yes big X # X also on last digit? if nz # No setc # A is smaller pop X ret end cmp A X # Equal? pop X ret end cnt X # A not on last digit. X on last digit? until nz # Yes clrc # A is greater pop X ret ### Is symbol interned? ### # E symbol # X name # Y tree (code 'isInternEXY_F 0) cnt X # Short name? if nz # Yes ld Y (Y) # Y on first tree do atom Y # Empty? jnz ret # Return NO ld A ((Y) TAIL) # Next symbol call nameA_A # Get name cmp A X # Equal? while ne # No ld Y (Y CDR) ldc Y (Y CDR) # Symbol is smaller ldnc Y (Y) # Symbol is greater loop cmp E (Y) # Same Symbol? ret # Return YES or NO end # Long name ld Y (Y CDR) # Y on second tree do atom Y # Empty? jnz ret # Return NO ld A ((Y) TAIL) # Next symbol call nameA_A # Get name call cmpLongAX_F # Equal? while ne # No ld Y (Y CDR) ldc Y (Y CDR) # Symbol is smaller ldnc Y (Y) # Symbol is greater loop cmp E (Y) # Same Symbol? ret # Return YES or NO ### Intern a symbol/name ### # E symbol # X name # Y tree (code 'internEXY_FE 0) cnt X # Short name? if nz # Yes ld C (Y) # C on first tree atom C # Empty? if nz # Yes null E # New symbol? if z call consSymX_E # Yes end call consE_X # Cons into a new node ld (X) E ld (X CDR) Nil ld (Y) X # Store in first tree setc # Return new symbol ret end do ld A ((C) TAIL) # Next symbol call nameA_A # Get name cmp A X # Equal? if eq # Yes ld E (C) # Found symbol ret end if lt # Symbol is smaller atom (C CDR) # Already has link? if nz # No null E # New symbol? if z call consSymX_E # Yes end call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil call consA_X # Cons into a new link ld (X) Nil ld (X CDR) A ld (C CDR) X setc # Return new symbol ret end ld C (C CDR) atom (C CDR) # CDR of link? ldz C (C CDR) # Yes: Get CDR of link in C if nz # No null E # New symbol? if z call consSymX_E # Yes end call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil ld (C CDR) A # Store in CDR of link setc # Return new symbol ret end else # Symbol is greater atom (C CDR) # Already has link? if nz # No null E # New symbol? if z call consSymX_E # Yes end call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil call consA_X # Cons into a new link ld (X) A ld (X CDR) Nil ld (C CDR) X setc # Return new symbol ret end ld C (C CDR) atom (C) # CAR of link? ldz C (C) # Yes: Get CAR of link in C if nz # No null E # New symbol? if z call consSymX_E # Yes end call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil ld (C) A # Store in CAR of link setc # Return new symbol ret end end loop end # Long name ld C (Y CDR) # C on second tree atom C # Empty? if nz # Yes null E # New symbol? if z call consSymX_E # Yes end call consE_X # Cons into a new node ld (X) E ld (X CDR) Nil ld (Y CDR) X # Store in second tree setc # Return new symbol ret end do ld A ((C) TAIL) # Next symbol call nameA_A # Get name call cmpLongAX_F # Equal? if eq # Yes ld E (C) # Found symbol ret end if lt # Symbol is smaller atom (C CDR) # Already has link? if nz # No null E # New symbol? if z call consSymX_E # Yes end call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil call consA_X # Cons into a new link ld (X) Nil ld (X CDR) A ld (C CDR) X setc # Return new symbol ret end ld C (C CDR) atom (C CDR) # CDR of link? ldz C (C CDR) # Yes: Get CDR of link in C if nz # No null E # New symbol? if z call consSymX_E # Yes end call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil ld (C CDR) A # Store in CDR of link setc # Return new symbol ret end else # Symbol is greater atom (C CDR) # Already has link? if nz # No null E # New symbol? if z call consSymX_E # Yes end call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil call consA_X # Cons into a new link ld (X) A ld (X CDR) Nil ld (C CDR) X setc # Return new symbol ret end ld C (C CDR) atom (C) # CAR of link? ldz C (C) # Yes: Get CAR of link in C if nz # No null E # New symbol? if z call consSymX_E # Yes end call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil ld (C) A # Store in CAR of link setc # Return new symbol ret end end loop (code 'findSymX_E 0) # Y ld E 0 # No symbol yet ld Y ((EnvIntern)) call internEXY_FE # New internal symbol? jnc Ret # No ld (E) Nil # Init to 'NIL' ret # X name (code 'externX_E 0) # C ld C 3 # Reserve three cells call needC push X # Save name ld A 6364136223846793005 # Randomize mul X ld E A # Key in E ld X Extern # X on external symbol tree root node do ld A ((X) TAIL) # Next symbol call nameA_A # Get name and A (hex "3FFFFFFFFFFFFFF7") # Mask status and extern bits mul 6364136223846793005 # Randomize cmp A E # Equal to key? if eq # Yes add S I # Drop name ld E (X) # Found symbol ret end if lt # Symbol is smaller atom (X CDR) # Already has link? if nz # No call cons_E # New symbol pop (E) # Retrieve name or (E) SYM # Set 'extern' tag or E SYM # Make symbol ld (E) Nil # Init to 'NIL' call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil call consA_C # Cons into a new link ld (C) Nil ld (C CDR) A ld (X CDR) C ret end ld X (X CDR) atom (X CDR) # CDR of link? ldz X (X CDR) # Yes: Get CDR of link in X if nz # No call cons_E # New symbol pop (E) # Retrieve name or (E) SYM # Set 'extern' tag or E SYM # Make symbol ld (E) Nil # Init to 'NIL' call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil ld (X CDR) A # Store in CDR of link ret end else # Symbol is greater atom (X CDR) # Already has link? if nz # No call cons_E # New symbol pop (E) # Retrieve name or (E) SYM # Set 'extern' tag or E SYM # Make symbol ld (E) Nil # Init to 'NIL' call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil call consA_C # Cons into a new link ld (C) A ld (C CDR) Nil ld (X CDR) C ret end ld X (X CDR) atom (X) # CAR of link? ldz X (X) # Yes: Get CAR of link in X if nz # No call cons_E # New symbol pop (E) # Retrieve name or (E) SYM # Set 'extern' tag or E SYM # Make symbol ld (E) Nil # Init to 'NIL' call consE_A # Cons into a new node ld (A) E ld (A CDR) Nil ld (X) A # Store in CAR of link ret end end loop ### Unintern a symbol ### # E symbol # X name # Y tree (code 'uninternEXY 0) cmp X ZERO # Name? jeq ret # No cnt X # Short name? if nz # Yes do # Y on first tree ld C (Y) # Next node atom C # Empty? jnz ret # Yes ld A ((C) TAIL) # Next symbol call nameA_A # Get name cmp A X # Equal? if eq # Yes cmp E (C) # Correct symbol? jne Ret # No ld A (C CDR) # Get subtrees atom (A) # Left branch? if nz # No ld (Y) (A CDR) # Use right branch ret end atom (A CDR) # Right branch? if nz # No ld (Y) (A) # Use left branch ret end ld A (A CDR) # A on right branch ld Y (A CDR) # Y on sub-branches atom (Y) # Left? if nz # No ld (C) (A) # Insert right sub-branch ld ((C CDR) CDR) (Y CDR) ret end ld Y (Y) # Left sub-branch do ld X (Y CDR) # More left branches? atom (X) while z # Yes ld A Y # Go down left ld Y (X) loop ld (C) (Y) # Insert left sub-branch ld ((A CDR)) (X CDR) ret end ld C (C CDR) if lt # Symbol is smaller atom C # Link? jnz ret # No lea Y (C CDR) # Go right else # Symbol is greater atom C # Link? jnz ret # No ld Y C # Go left end loop end # Long name lea Y (Y CDR) do # Y on second tree ld C (Y) # Get next node atom C # Empty? jnz ret # Yes ld A ((C) TAIL) # Next symbol call nameA_A # Get name call cmpLongAX_F # Equal? if eq # Yes cmp E (C) # Correct symbol? jne Ret # No ld A (C CDR) # Get subtrees atom (A) # Left branch? if nz # No ld (Y) (A CDR) # Use right branch ret end atom (A CDR) # Right branch? if nz # No ld (Y) (A) # Use left branch ret end ld A (A CDR) # A on right branch ld Y (A CDR) # Y on sub-branches atom (Y) # Left? if nz # No ld (C) (A) # Insert right sub-branch ld ((C CDR) CDR) (Y CDR) ret end ld Y (Y) # Left sub-branch do ld X (Y CDR) # More left branches? atom (X) while nz # Yes ld A Y # Go down left ld Y (X) loop ld (C) (Y) # Insert left sub-branch ld ((A CDR)) (X CDR) ret end ld C (C CDR) if lt # Symbol is smaller atom C # Link? jnz ret # No lea Y (C CDR) # Go right else # Symbol is greater atom C # Link? jnz ret # No ld Y C # Go left end loop (code 'nameA_A 0) off A SYM # Clear 'extern' tag do num A # Find name jnz ret ld A (A CDR) # Skip property loop (code 'nameE_E 0) off E SYM # Clear 'extern' tag do num E # Find name jnz ret ld E (E CDR) # Skip property loop (code 'nameX_X 0) off X SYM # Clear 'extern' tag do num X # Find name jnz ret ld X (X CDR) # Skip property loop (code 'nameY_Y 0) off Y SYM # Clear 'extern' tag do num Y # Find name jnz ret ld Y (Y CDR) # Skip property loop # (name 'sym ['sym2]) -> sym (code 'doName 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval 'sym' eval num E # Need symbol jnz symErrEX sym E jz symErrEX ld Y (Y CDR) # Second arg? atom Y if nz # No cmp E Nil # NIL? if ne # No ld X (E TAIL) sym X # External symbol? if z # No call nameX_X # Get name call consSymX_E # Make new transient symbol else call nameX_X # Get name call packExtNmX_E # Pack it end end else cmp E Nil # NIL? jeq renErrEX # Yes sym (E TAIL) # External symbol? jnz renErrEX # Yes push X # Save expression push Y ld X (E TAIL) call nameX_X # Get name ld Y ((EnvIntern)) # Internal symbol? call isInternEXY_F pop Y pop X jz renErrEX # Yes link push E # First (transient) symbol link ld E (Y) eval # Eval second arg num E # Need symbol jnz symErrEX sym E jz symErrEX ld X (E TAIL) call nameX_X # Get name push X # Save new name ld E (L I) # Get first symbol ld X (E TAIL) call nameX_X # Get name ld Y Transient call uninternEXY # Unintern lea Y (E TAIL) do num (Y) # Find name while z lea Y ((Y) CDR) loop pop (Y) # Store name of second drop end pop Y pop X ret # Make single-char symbol (code 'mkCharA_A 0) cmp A (hex "80") # ASCII? if ge # No cmp A (hex "800") # Double-byte? if lt # Yes ld (Buf) B # 110xxxxx 10xxxxxx shr A 6 # Upper five bits and B (hex "1F") or B (hex "C0") xchg B (Buf) # Save first byte and A (hex "3F") # Lower 6 bits or B (hex "80") shl A 8 # into second byte ld B (Buf) # Get first byte else cmp A TOP # Special "top" character? if eq # Yes ld B (hex "FF") # Above legal UTF-8 zxt else push C ld C A # 1110xxxx 10xxxxxx 10xxxxxx shr A 12 # Hightest four bits and B (hex "0F") or B (hex "E0") ld (Buf) B # Save first byte ld A C shr A 6 # Middle six bits and A (hex "3F") or B (hex "80") shl A 8 # into second byte xchg A C and A (hex "3F") # Lowest 6 bits or B (hex "80") # Add third byte shl A 16 # into third byte or A C # Combine with second byte ld B (Buf) # and first byte pop C end end end shl A 4 # Make short name or A CNT push A # Save character call cons_A # New cell pop (A) # Set name or A SYM # Make symbol ld (A) A # Set value to itself ret (code 'mkStrE_E 0) null E # NULL pointer? jz retNil nul (E) # Empty string? jz retNil push C push X link push ZERO # Name ld C 4 # Build name ld X S link do ld B (E) call byteSymBCX_CX # Pack byte inc E # Next byte nul (E) # Any? until z call cons_E # Cons symbol ld (E) (L I) # Set name or E SYM # Make symbol ld (E) E # Set value to itself drop pop X pop C ret (code 'mkStrEZ_A 0) push X link push ZERO # Name ld C 4 # Build name ld X S link do ld B (E) call byteSymBCX_CX # Pack byte cmp E Z # Reached Z? while ne # No inc E # Next byte nul (E) # Any? until z call cons_A # Cons symbol ld (A) (L I) # Set name or A SYM # Make symbol ld (A) A # Set value to itself drop pop X ret (code 'firstByteA_B 0) sym A # External symbol? if z # No call nameA_A # Get name cnt A # Short? if nz # Yes shr A 4 # Normalize else ld A (A DIG) # Get first digit end ret end ld A 0 ret (code 'firstCharE_A 0) ld A 0 cmp E Nil # NIL? if ne # No push X ld X (E TAIL) sym X # External symbol? if z # No call nameX_X # Get name ld C 0 call symCharCX_FACX # Get first character end pop X end ret (code 'isBlankE_F 0) num E # Symbol? jnz ret # No sym E jz retnz # No cmp E Nil # NIL? jeq ret # Yes sym (E TAIL) # External symbol? jnz ret # Yes push X ld X (E TAIL) call nameX_X # Get name ld C 0 do call symByteCX_FACX # Next byte while nz cmp B 32 # Larger than blank? break gt # Yes loop pop X ret # (sp? 'any) -> flg (code 'doSpQ 2) ld E ((E CDR)) # Get arg eval # Eval it call isBlankE_F # Blank? ld E TSym # Yes ldnz E Nil ret # (pat? 'any) -> sym | NIL (code 'doPatQ 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jnz retNil # Yes sym E # Symbol? jz retNil # No ld A (E TAIL) call firstByteA_B # starting with "@"? cmp B (char "@") ldnz E Nil # No ret # (fun? 'any) -> any (code 'doFunQ 2) ld E ((E CDR)) # Get arg eval # Eval it call funqE_FE # Function definition? ldnz E Nil # No ret # (getd 'any) -> fun | NIL (code 'doGetd 2) ld E ((E CDR)) # E on arg eval # Eval it num E # No number? if z # Yes sym E # Symbol? if nz # Yes push E ld E (E) # Get value call funqE_FE # Function definition? pop E if eq # Yes ld E (E) # Return value ret end cmp (E) Nil # Value NIL? if eq # Yes ld C E call sharedLibC_FA # Dynamically loaded? if nz # Yes ld E A # Return function pointer ret end end end end ld E Nil ret # (all ['NIL | 'T | '0 | '(NIL . flg) | '(T . flg) | '(0)]) -> lst (code 'doAll 2) push X ld E ((E CDR)) # Eval arg eval atom E # Direct tree? if z # Yes cmp (E) Nil # Internal trees? if eq # Yes cmp (E CDR) Nil # Short names? ldz E (((EnvIntern))) # Yes ldnz E (((EnvIntern)) I) else cmp (E) TSym # Transient trees? ldnz E Extern # No: External symbols if eq # Yes cmp (E CDR) Nil # Short names? ldz E (Transient) # Yes ldnz E (Transient I) end end else cmp E Nil # Nil? if eq # Yes ld X (((EnvIntern)) I) # Internal symbols call consTreeXE_E ld X (((EnvIntern))) else cmp E TSym # T? if eq # Yes ld E Nil ld X (Transient I) # Transient symbols call consTreeXE_E ld X (Transient) else ld E Nil ld X Extern # External symbols end end call consTreeXE_E end pop X ret # Build sorted list from tree (code 'consTreeXE_E 0) atom X # Tree empty? jnz ret # Yes link push X # Tree push Nil # TOS link do do ld A (X CDR) # Get subtrees atom (A CDR) # Right subtree? while z # Yes ld C X # Go right ld X (A CDR) # Invert tree ld (A CDR) (L I) # TOS ld (L I) C loop ld (L II) X # Save tree do call consE_A # Cons value ld (A) (X) ld (A CDR) E ld E A # into E ld A (X CDR) # Left subtree? atom (A) if z # Yes ld C X # Go left ld X (A) # Invert tree ld (A) (L I) # TOS or C SYM # First visit ld (L I) C ld (L II) X # Save tree break T end do ld A (L I) # TOS cmp A Nil # Empty? jeq 90 # Done sym A # Second visit? if z # Yes ld C (A CDR) # Nodes ld (L I) (C CDR) # TOS on up link ld (C CDR) X ld X A ld (L II) X # Save tree break T end off A SYM # Set second visit ld C (A CDR) # Nodes ld (L I) (C) ld (C) X ld X A ld (L II) X # Save tree loop loop loop 90 drop # Return E ret # Build balanced copy of a namespace (code 'balanceXY) # ACE ld E Nil # Build list call consTreeXE_E link push E # Save list link ld A E # Get list in A ld C 0 # Calculate length do atom A # More cells? while z # Yes inc C # Increment length ld A (A CDR) # Next cell loop call balanceCEY drop ret (code 'balanceCEY 0) do null C # Length zero? jz ret # Yes push C # Save length push E # and list inc C # (length + 1) / 2 shr C 1 push C # Rest length do dec C # nth while nsz ld E (E CDR) loop push (E CDR) # Save rest ld E (E) # Next symbol ld X (E TAIL) # Get name call nameX_X call internEXY_FE # Insert pop E # Retrieve rest ld C (S II) # Get length sub C (S) # minus rest length call balanceCEY # Recurse pop C # Retrieve rest length dec C # Decrement pop E # Retrieve list add S I # Drop length loop # Tail recurse # (symbols) -> sym # (symbols 'sym1) -> sym2 # (symbols 'sym1 'sym ..) -> sym2 (code 'doSymbols 2) push X push Y push Z ld X E ld Z (E CDR) # Z on args atom Z # Any? if nz # No ld E (EnvIntern) # Return current symbol namespace else ld E (Z) # Eval first eval num E # Need symbol jnz symErrEX sym E jz symErrEX ld Z (Z CDR) # Second arg atom Z # Any? if nz # No atom (E) # Value must be a pair jnz symNsErrEX else call checkVarEX link push E # Save new symbol namespace push Nil # Space for value push Nil # and source link call cons_Y # Create namespace cell ld (Y) Nil # Initialize ld (Y CDR) Nil ld (L II) Y # New value do ld E (Z) eval # Eval next source symbol namespace ld (L I) E # Save source num E # Need symbol jnz symErrEX sym E jz symErrEX ld C (E) # Get source value atom C # Must be a pair jnz symNsErrEX push X ld X (C) # Source short names call balanceXY # Balanced copy of short names ld X (((L I)) CDR) # Source long names call balanceXY # Balanced copy of long names pop X ld Z (Z CDR) # Next arg atom Z # Any? until nz # No ld C (L II) # Get value ld E (L III) # And new symbol namespace call redefineCE # Redefine drop end xchg (EnvIntern) E # Set new symbol namespace, return old end pop Z pop Y pop X ret # (intern 'sym) -> sym (code 'doIntern 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it num E # Need symbol jnz symErrEX sym E jz symErrEX ld X (E TAIL) call nameX_X # Get name cmp X ZERO # Any? if ne # Yes push Y ld Y ((EnvIntern)) # Insert internal call internEXY_FE pop Y pop X ret end ld E Nil pop X ret # (extern 'sym) -> sym | NIL (code 'doExtern 2) push X push Y ld X E ld E ((E CDR)) # E on arg eval # Eval it num E # Need symbol jnz symErrEX sym E jz symErrEX ld X (E TAIL) call nameX_X # Get name cmp X ZERO # Any? if ne # Yes ld C 0 # Character index call symCharCX_FACX # First char cmp B (char "{") # Open brace? if eq # Yes call symCharCX_FACX # Skip it end ld E 0 # Init file number do cmp B (char "@") # File done? while ge # No cmp B (char "O") # In A-O range? jgt 90 # Yes sub B (char "@") shl E 4 # Add to file number add E A call symCharCX_FACX # Next char? jz 90 # No loop cmp B (char "0") # Octal digit? jlt 90 cmp B (char "7") jgt 90 # No sub B (char "0") zxt ld Y A # Init object ID do call symCharCX_FACX # Next char? while nz # Yes cmp B (char "}") # Closing brace? while ne # No cmp B (char "0") # Octal digit? jlt 90 cmp B (char "7") jgt 90 # No sub B (char "0") shl Y 3 # Add to object ID add Y A loop ld C Y # Object ID call extNmCE_X # Build external symbol name call externX_E # New external symbol call isLifeE_F # Alive? ldnz E Nil # No pop Y pop X ret end 90 ld E Nil pop Y pop X ret # (==== ['sym ..]) -> NIL (code 'doHide 2) ld A Nil # Clear transient index trees ld (Transient) A ld (Transient I) A push X push Y push Z ld X E ld Z (E CDR) # Args do atom Z # More? while z # Yes ld E (Z) # Eval next eval num E # Need symbol jnz symErrEX sym E jz symErrEX push X ld X (E TAIL) call nameX_X # Get name ld Y Transient # Insert transient call internEXY_FE pop X ld Z (Z CDR) # Z on rest loop pop Z pop Y pop X ret # (box? 'any) -> sym | NIL (code 'doBoxQ 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jnz retNil # Yes sym E # Symbol? jz retNil # No ld A (E TAIL) call nameA_A # Get name cmp A ZERO # Any? jne retNil ret # (str? 'any) -> sym | NIL (code 'doStrQ 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jnz retNil # Yes sym E # Symbol? jz retNil # No sym (E TAIL) # External symbol? jnz retNil # Yes push X push Y ld X (E TAIL) # Get name call nameX_X ld Y ((EnvIntern)) # Internal symbol? call isInternEXY_F ldz E Nil # Return NIL pop Y pop X ret # (ext? 'any) -> sym | NIL (code 'doExtQ 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jnz retNil # Yes sym E # Symbol? jz retNil # No ld A (E TAIL) sym A # External symbol? jz retNil # No call isLifeE_F # Alive? ldnz E Nil # No ret # (touch 'sym) -> sym (code 'doTouch 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end ret # (zap 'sym) -> sym (code 'doZap 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it num E # Need symbol jnz symErrEX sym E jz symErrEX ld A (E TAIL) sym A # External symbol? if nz # Yes call dbZapE # Mark as "deleted" else cmp (EnvIntern) pico # Inside 'pico'? if eq # Yes cmp E Nil # Between 'NIL' and '*Bye'? if ge cmp E Bye jle protErrEX # Yes end end push Y ld X (E TAIL) call nameX_X # Get name ld Y ((EnvIntern)) call uninternEXY # Unintern symbol pop Y end pop X ret # (chop 'any) -> lst (code 'doChop 2) ld E ((E CDR)) # Get arg eval # Eval it atom E # Atomic? if nz # Yes cmp E Nil # NIL? if ne # No push X call xSymE_E # Extract symbol ld X (E TAIL) call nameX_X # Get name sym (E TAIL) # External symbol? if z # No ld C 0 call symCharCX_FACX # First char? if nz # Yes push Y link push X # Save name link call mkCharA_A # Make single character call consA_Y # Cons it ld (Y) A ld (Y CDR) Nil # with NIL tuck Y # Result link do call symCharCX_FACX # Next char while nz call mkCharA_A # Make char call consA_E # Cons it ld (E) A ld (E CDR) Nil ld (Y CDR) E # Append to result ld Y E loop ld E (L I) # Get result drop pop Y else ld E Nil # Else return NIL end else # External symbol call chopExtNmX_E end pop X end end ret # (pack 'any ..) -> sym (code 'doPack 2) push X push Y push Z ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'any' push ZERO # Safe push ZERO # Result ld C 4 # Build name ld X S link do call packECX_CX ld Y (Y CDR) # More args? atom Y while z # Yes ld Z C # Save C ld E (Y) # Eval next arg eval ld (L III) E # Save ld C Z loop ld X (L I) # Get result call consSymX_E # Make transient symbol drop pop Z pop Y pop X ret (code 'packECX_CX 0) atom E # Atomic? if z # No do # List push (E CDR) # Save rest ld E (E) # Recurse on CAR cmp S (StkLimit) # Stack check jlt stkErr call packECX_CX pop E # Done? atom E until nz # Yes end cmp E Nil # NIL? jeq ret # Yes num E # Number? if z # No sym (E TAIL) # External symbol? if nz # Yes ld B (char "{") call byteSymBCX_CX # Pack "{" push C # Save status push X ld X (E TAIL) # Get name call nameX_X call packExtNmX_E # Pack name ld (L II) E # Save pop X # Restore status pop C call 10 # Pack external symbol ld B (char "}") jmp byteSymBCX_CX # Pack "}" end else ld A 0 # Scale call fmtNum0AE_E # Convert to symbol ld (L II) E # Save end 10 push C # Save status push X ld X (E TAIL) call nameX_X # Get name ld C 0 do call symByteCX_FACX # Next char while nz xchg C (S I) # Swap status xchg X (S) call byteSymBCX_CX # Pack byte xchg X (S) # Swap status xchg C (S I) loop pop X # Restore status pop C ret # (glue 'any 'lst) -> sym (code 'doGlue 2) push X push Y ld X (E CDR) # Args ld E (X) # Eval first eval link push E # 'any' ld X (X CDR) # X on rest ld E (X) # Eval second eval+ push E # 'lst' push ZERO # Number safe push ZERO # Result ld C 4 # Build name ld X S link atom E # Any items? if z # Yes ld Y E # 'lst' do ld E (Y) # Get next item call packECX_CX # Pack it ld Y (Y CDR) # More? atom Y while z # Yes ld E (L IV) # Get 'any' call packECX_CX # Pack it loop ld X (L I) # Get result call consSymX_E # Make transient symbol end drop pop Y pop X ret # (text 'any1 'any ..) -> sym (code 'doText 2) push X push Y ld X (E CDR) # Args call evSymX_E # Eval first cmp E Nil # NIL? if ne # No ld E (E TAIL) call nameE_E # Get name link push E # <(L) -I> Name of 'any1' do ld X (X CDR) # Next arg atom X # Any? while z # Yes ld E (X) # Eval next arg eval+ push E # and save it loop push ZERO # Number safe push ZERO # Result ld X S link push 4 # Build name push X # Pack status ld X ((L) -I) # Get name of 'any1' ld C 0 # Index do call symByteCX_FACX # Next char? while nz cmp B (char "@") # Pattern? if ne # No 10 xchg C (S I) # Swap status xchg X (S) call byteSymBCX_CX # Pack byte xchg X (S) # Swap status xchg C (S I) continue T end call symByteCX_FACX # Next char after "@"? while nz cmp B (char "@") # "@@"? jeq 10 # Yes sub B (char "0") # >= "1"? if gt # Yes cmp B 8 # > 8? if gt sub B 7 # Adjust for letter end shl A 3 # Vector index lea E ((L) -I) # Point above first 'any' arg sub E A # Get arg address lea A (L II) # Address of number save cmp E A # Arg address too low? if gt # No ld E (E) xchg C (S I) # Swap status xchg X (S) call packECX_CX # Pack it xchg X (S) # Swap status xchg C (S I) end end loop ld X (L I) # Get result call consSymX_E # Make transient symbol drop end pop Y pop X ret (code 'preCEXY_F 0) do call symByteCX_FACX # First string done? jz ret # Yes ld (Buf) B # Keep xchg C E # Second string xchg X Y call symByteCX_FACX # Next byte? jz retnz # No cmp (Buf) B # Equal? jne ret # No xchg C E # First string xchg X Y loop (code 'subStrAE_F 0) cmp A Nil # NIL? jeq ret # Yes ld A (A TAIL) # First symbol call nameA_A # Get name cmp A ZERO # None? jeq ret # Yes ld E (E TAIL) # Second symbol call nameE_E # Get name cmp E ZERO # Any? jeq retnz # No push X push Y push Z push A # First name ld Z E # Second name push 0 # Second index do ld X (S I) # First name ld C 0 # First index ld Y Z # Second name ld E (S) # Second index call preCEXY_F # Prefix? while ne # No ld A (S) shr A 8 # New round in second index? if z # Yes cmp Z ZERO # Second done? if eq # Yes clrz # 'nz' break T end cnt Z # Short? if nz # Yes ld A Z # Get short shr A 4 # Normalize ld Z ZERO # Clear for next round else ld A (Z DIG) # Get next digit ld Z (Z BIG) end end ld (S) A loop lea S (S II) # Drop locals pop Z pop Y pop X ret # 'z' or 'nz' # (pre? 'any1 'any2) -> any2 | NIL (code 'doPreQ 2) push X push Y push Z ld X (E CDR) # X on args call evSymX_E # Eval first link push E # 'any1' link ld X (X CDR) # Next arg call evSymX_E # Eval second ld X (L I) # 'any1' cmp X Nil # NIL? if ne # No ld Z E # Keep second in Z ld X (X TAIL) # 'any1' call nameX_X # First name ld C 0 ld E (E TAIL) # 'any2' call nameE_E # Second name ld Y E ld E 0 call preCEXY_F # Prefix? ld E Nil ldz E Z # Yes end drop pop Z pop Y pop X ret # (sub? 'any1 'any2) -> any2 | NIL (code 'doSubQ 2) push X ld X (E CDR) # X on args call evSymX_E # Eval first link push E # 'any1' link ld X (X CDR) # Next arg call evSymX_E # Eval second ld A (L I) # 'any1' ld X E # Keep second in X call subStrAE_F # Substring? ld E Nil ldz E X # Yes drop pop X ret # (val 'var) -> any (code 'doVal 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it num E # Need variable jnz varErrEX sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end end ld E (E) # Return value pop X ret # (set 'var 'any ..) -> any (code 'doSet 2) push X push Y ld X E ld Y (E CDR) # Y on args link push ZERO # Safe link do ld E (Y) # Eval next eval call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end ld (L I) E # Save it ld Y (Y CDR) # Next arg ld E (Y) eval # Eval 'any' ld ((L I)) E # Set value ld Y (Y CDR) # Next arg atom Y # Any? until nz # No drop pop Y pop X ret # (setq var 'any ..) -> any (code 'doSetq 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args do ld E (Y) # Next var call needVarEX # Need variable ld Z E # Keep in Z ld Y (Y CDR) # Eval next arg ld E (Y) eval ld (Z) E # Store value ld Y (Y CDR) # More args? atom Y until nz # No pop Z pop Y pop X ret # (swap 'var 'any) -> any (code 'doSwap 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end link push E # 'var' link ld E ((Y CDR)) # Eval next arg eval xchg E ((L I)) # Swap value drop pop Y pop X ret # (xchg 'var 'var ..) -> any (code 'doXchg 2) push X push Y ld X E ld Y (E CDR) # Y on args link push ZERO # Safe link do ld E (Y) # Eval next eval call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end ld (L I) E # Save it ld Y (Y CDR) # Next arg ld E (Y) eval # Eval next arg call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end ld C (L I) # Get first 'var' ld A (C) # Get value ld (C) (E) # Set new ld (E) A ld Y (Y CDR) # Next arg atom Y # Any? until nz # No ld E A # Return last drop pop Y pop X ret # (on var ..) -> T (code 'doOn 2) push X ld X (E CDR) do ld E (X) # Get next arg call needVarEX # Need variable ld (E) TSym # Set to 'T' ld X (X CDR) # More? atom X until nz # No ld E TSym pop X ret # (off var ..) -> NIL (code 'doOff 2) push X ld X (E CDR) do ld E (X) # Get next arg call needVarEX # Need variable ld (E) Nil # Set to 'NIL' ld X (X CDR) # More? atom X until nz # No ld E Nil pop X ret # (onOff var ..) -> flg (code 'doOnOff 2) push X ld X (E CDR) do ld E (X) # Get next arg call needVarEX # Need variable cmp (E) Nil # Value NIL? ld A TSym # Negate ldnz A Nil ld (E) A # Set new value ld X (X CDR) # More? atom X until nz # No ld E A # Return last pop X ret # (zero var ..) -> 0 (code 'doZero 2) push X ld X (E CDR) do ld E (X) # Get next arg call needVarEX # Need variable ld (E) ZERO # Set to '0' ld X (X CDR) # More? atom X until nz # No ld E ZERO pop X ret # (one var ..) -> 1 (code 'doOne 2) push X ld X (E CDR) do ld E (X) # Get next arg call needVarEX # Need variable ld (E) ONE # Set to '1' ld X (X CDR) # More? atom X until nz # No ld E ONE pop X ret # (default sym 'any ..) -> any (code 'doDefault 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args do ld E (Y) # Next var ld Y (Y CDR) call needVarEX # Need variable ld Z E # Keep in Z cmp (Z) Nil # Value 'NIL'? if eq # Yes ld E (Y) # Eval next arg eval ld (Z) E # Store value end ld Y (Y CDR) # More args? atom Y until nz # No ld E (Z) # Return value pop Z pop Y pop X ret # (push 'var 'any ..) -> any (code 'doPush 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end link push E # 'var' link ld Y (Y CDR) # Second arg do ld E (Y) eval # Eval next arg call consE_A # Cons into value ld (A) E ld C (L I) # 'var' ld (A CDR) (C) ld (C) A ld Y (Y CDR) # Next arg atom Y # Any? until nz # No drop pop Y pop X ret # (push1 'var 'any ..) -> any (code 'doPush1 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end link push E # 'var' link ld Y (Y CDR) # Second arg do ld E (Y) eval # Eval next arg ld C ((L I)) # Value of 'var' do # 'member' atom C # List? while z # Yes ld A (C) ld Z E # Preserve E call equalAE_F # Member? ld E Z jeq 10 # Yes ld C (C CDR) loop call consE_A # Cons into value ld (A) E ld C (L I) # 'var' ld (A CDR) (C) ld (C) A 10 ld Y (Y CDR) # Next arg atom Y # Any? until nz # No drop pop Z pop Y pop X ret # (pop 'var) -> any (code 'doPop 2) push X ld X E ld E ((E CDR)) # E on arg eval # Eval it call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end ld A E # 'var' in A ld E (A) # Get value atom E # List? if z # Yes ld (A) (E CDR) # Set to CDR ld E (E) # Return CAR end pop X ret # (cut 'cnt 'var) -> lst (code 'doCut 2) push X push Y ld X E ld Y (E CDR) # Y on args call evCntXY_FE # Eval 'cnt' if nsz # Yes ld Y ((Y CDR)) # Second arg xchg E Y # 'cnt' in Y eval # Eval 'var' call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end atom (E) # List value? ldnz E (E) if z # Yes call consE_X # Cons first cell ld C (E) # Get value ld (X) (C) # CAR ld (X CDR) Nil link push E # 'var' push X # 'lst' link do ld C (C CDR) # More elements? atom C while z # Yes dec Y # Count? while nz # Yes call cons_A # Copy next cell ld (A) (C) ld (A CDR) Nil ld (X CDR) A # Append to result ld X (X CDR) loop ld ((L II)) C # Set new value ld E (L I) # Get result drop end pop Y pop X ret end ld E Nil pop Y pop X ret # (del 'any 'var) -> lst (code 'doDel 2) push X push Y push Z ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'any' ld Y (Y CDR) ld E (Y) # Eval second eval+ push E # 'var' link call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end ld E ((L I)) # Get value of 'var' atom E # List? if z # Yes ld Y E # Keep value in Y ld E (Y) # First element ld A (L II) # 'any' call equalAE_F # Equal? if eq # Yes ld E (Y CDR) # Get value's CDR ld ((L I)) E # Set 'var' else call cons_Z # Copy first cell ld (Z) (Y) ld (Z CDR) Nil tuck Z # Save it link do ld Y (Y CDR) # More cells? atom Y while z # Yes ld E (Y) # Next element ld A (L III) # 'any' call equalAE_F # Equal? if eq # Yes ld (Z CDR) (Y CDR) # Skip found element ld E (L I) # Result ld ((L II)) E # Set 'var' jmp 90 end call cons_A # Copy next cell ld (A) (Y) ld (A CDR) Nil ld (Z CDR) A # Append to result ld Z (Z CDR) loop ld E ((L II)) # Not found: Return old value of 'var' end end 90 drop pop Z pop Y pop X ret # (queue 'var 'any) -> any (code 'doQueue 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end link push E # 'var' link ld E ((Y CDR)) # Eval next arg eval call consE_C # Build cell ld (C) E ld (C CDR) Nil ld X (L I) # Get 'var' ld Y (X) # Value atom Y # Atomic? if nz # Yes ld (X) C # Store first cell else do atom (Y CDR) # Find last cell while z ld Y (Y CDR) loop ld (Y CDR) C end drop pop Y pop X ret # (fifo 'var ['any ..]) -> any (code 'doFifo 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval call needVarEX # Need variable sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end end link push E # 'var' link ld Y (Y CDR) # More args? atom Y if z # Yes ld E (Y) # Eval 'any' eval call consE_A # Cons into new cell ld (A) E ld C (L I) # Get 'var' ld X (C) # Value in X atom X # List? if z # Yes ld (A CDR) (X CDR) # Concat to value ld (X CDR) A else ld (A CDR) A # Circular cell ld (C) X # Set new value end ld X A do ld Y (Y CDR) # More args? atom Y while z # Yes ld E (Y) # Eval next 'any' eval call consE_A # Cons into new cell ld (A) E ld (A CDR) (X CDR) # Concat to value ld (X CDR) A ld X A loop ld ((L I)) X # Set new value else ld C (L I) # Get 'var' ld X (C) # Value in X atom X # Any? if nz # No ld E Nil else cmp X (X CDR) # Single cell? if eq # Yes ld E (X) # Return CAR ld (C) Nil # Clear value else ld E ((X CDR)) # Return CADR ld (X CDR) ((X CDR) CDR) # Cut cell end end end drop pop Y pop X ret # (idx 'var 'any 'flg) -> lst # (idx 'var 'any) -> lst # (idx 'var) -> lst (code 'doIdx 2) push X ld X E ld E ((E CDR)) # Eval first arg eval call needVarEX # Need variable ld X ((X CDR) CDR) # Second arg? atom X if nz # No ld X (E) # Get tree ld E Nil # Cons a list call consTreeXE_E else push Y link push E # 'var' ld E (X) eval+ # Eval second arg push E # 'any' link # Save it ld Y E # Keep in Y ld X (X CDR) # Third arg? atom X if nz # No ld X (L II) # Get 'var' call idxGetXY_E # Find else ld E (X) # Eval last arg eval ld X (L II) # Get 'var' cmp E Nil # Delete? if ne # No call idxPutXY_E # Insert else call idxDelXY_E # Delete end end drop pop Y end pop X ret (code 'idxGetXY_E 0) ld X (X) # Get value of 'var' do atom X # More nodes? ld E Nil while z # Yes ld A Y # Get key ld E (X) # Compare with node value call compareAE_F # Found? ld E X while ne # No ld X (X CDR) ldc X (X) # Smaller ldnc X (X CDR) # Greater loop ret (code 'idxPutXY_E 0) atom (X) # First insert? if nz # Yes call cons_A # Cons new node ld (A) Y # 'any' ld (A CDR) Nil ld (X) A # Set 'var' ld E Nil # return NIL else ld X (X) # Get value of 'var' do ld A Y # Get key ld E (X) # Compare with node value call compareAE_F # Equal? ld E X while ne # No ld A (X CDR) if ge # Greater atom A # Already has link? if nz # No call cons_A # Cons into a new node ld (A) Y # key ld (A CDR) Nil call consA_C # Cons a new link ld (C) Nil ld (C CDR) A ld (X CDR) C ld E Nil # Return NIL break T end ld X A atom (X CDR) # CDR of link? ldz X (X CDR) # Yes: Get CDR of link in X if nz # No call cons_A # Else cons into a new node ld (A) Y # key ld (A CDR) Nil ld (X CDR) A # Store in CDR of link ld E Nil # Return NIL break T end else # Smaller atom A # Already has link? if nz # No call cons_A # Cons into a new node ld (A) Y # key ld (A CDR) Nil call consA_C # Cons a new link ld (C) A ld (C CDR) Nil ld (X CDR) C ld E Nil # Return NIL break T end ld X A atom (X) # CAR of link? ldz X (X) # Yes: Get CAR of link in X if nz # No call cons_A # Else cons into a new node ld (A) Y # key ld (A CDR) Nil ld (X) A # Store in CAR of link ld E Nil # Return NIL break T end end loop end ret (code 'idxDelXY_E 0) do atom (X) # Next node? ld E Nil while z # Yes ld A Y # Get key ld E ((X)) # Compare with node value call compareAE_F # Equal? if eq # Yes ld C (X) # Found subtree ld E C # Preset return value ld A (C CDR) # Get subtrees atom (A) # Left branch? if nz # No ld (X) (A CDR) # Use right branch ret end atom (A CDR) # Right branch? if nz # No ld (X) (A) # Use left branch ret end ld A (A CDR) # A on right branch ld X (A CDR) # X on sub-branches atom (X) # Left? if nz # No ld (C) (A) # Insert right sub-branch ld ((C CDR) CDR) (X CDR) ret end push E # Save return value ld X (X) # Left sub-branch do ld E (X CDR) # More left branches? atom (E) while z # Yes ld A X # Go down left ld X (E) loop ld (C) (X) # Insert left sub-branch ld ((A CDR)) (E CDR) pop E ret end ld E Nil ld X ((X) CDR) if ge # Node value is greater atom X # Link? break nz # No lea X (X CDR) # Go right else # Node value is smaller atom X # Link? break nz # No end loop ret # (lup 'lst 'any) -> lst # (lup 'lst 'any 'any2) -> lst (code 'doLup 2) push X ld X (E CDR) # Args ld E (X) # Eval first eval atom E # List? if z # Yes link push E # 'lst' ld X (X CDR) # Eval second ld E (X) eval+ # 'any' ld X (X CDR) # Next arg? atom X if nz # No pop X # Get 'lst' in X pop L # Discard partial stack frame push Y ld Y E # Get 'any' in Y do ld E (X) # CAR of 'lst' cmp E TSym # Is it T? if eq # Yes ld X ((X CDR)) # Go to CADR else atom E # Atomic? if nz # Yes ld X ((X CDR) CDR) # Go to CDDR else ld A Y # Key 'any' ld E (E) # CAAR of 'lst' call compareAE_F # Equal? if eq # Yes ld E (X) # Return CAR of 'lst' pop Y pop X ret end ld X (X CDR) ldc X (X) # Smaller ldnc X (X CDR) # Greater end end atom X # Reached leaf? until nz # Yes ld E Nil # Return NIL pop Y else push E # "from" key ld E (X) # Eval next eval+ push E # "to" key push Nil # TOS push Nil # Result link ld X (L V) # Get 'lst' in X do do ld A (X CDR) atom (A CDR) # Right subtree? while z # Yes ld E (X) # CAR of 'lst' cmp E TSym # Is it T? while ne # No atom E # Atomic? jnz 10 # Yes ld A (L III) # "to" key ld E (E) # CAAR of 'lst' call compareAE_F # Greater or equal? while ge # Yes 10 ld C X # Go right ld A (X CDR) ld X (A CDR) # Invert tree ld (A CDR) (L II) # TOS ld (L II) C loop ld (L V) X # Save tree do ld E (X) # CAR of 'lst' atom E # Atomic? if z # No ld A (L IV) # "from" key ld E (E) # CAAR of 'lst' call compareAE_F # Less or equal? if le # Yes ld A (L III) # "to" key ld E ((X)) # CAAR of 'lst' call compareAE_F # Greater or equal? if ge # Yes call cons_A # Cons value ld (A) (X) ld (A CDR) (L I) # Into result ld (L I) A end ld A (X CDR) # Left subtree? atom (A) if z # Yes ld C X # Go left ld X (A) # Invert tree ld (A) (L II) # TOS or C SYM # First visit ld (L II) C ld (L V) X # Save tree break T end end end do ld A (L II) # TOS cmp A Nil # Empty? if eq # Yes ld E (L I) # Return result drop pop X ret end sym A # Second visit? if z # Yes ld C (A CDR) # Nodes ld (L II) (C CDR) # TOS on up link ld (C CDR) X ld X A ld (L V) X # Save tree break T end off A SYM # Set second visit ld C (A CDR) # Nodes ld (L II) (C) ld (C) X ld X A ld (L V) X # Save tree loop loop loop end end pop X ret ### Property access ### (code 'putACE 0) push X ld X (A TAIL) # Properties num X # Any? if z # Yes off X SYM # Clear 'extern' tag atom (X) # First property atomic? if nz # Yes cmp C (X) # Found flag? if eq # Yes cmp E Nil # Value NIL? if eq # Yes 10 ld X (X CDR) # Remove property sym (A TAIL) # Extern? if nz # Yes or X SYM # Set 'extern' tag end ld (A TAIL) X 20 pop X ret end cmp E TSym # Value T? jeq 20 # No change push C call consE_C # New property cell ld (C) E pop (C CDR) ld (X) C pop X ret end else cmp C ((X) CDR) # Found property? if eq # Yes cmp E Nil # Value NIL? jeq 10 # Yes cmp E TSym # Value T? if ne # No ld ((X)) E # Set new value else ld (X) C # Change to flag end pop X ret end end push Y do ld Y (X CDR) # Next property atom Y # Any? while z # Yes atom (Y) # Atomic? if nz # Yes cmp C (Y) # Found flag? if eq # Yes cmp E Nil # Value NIL? if eq # Yes ld (X CDR) (Y CDR) # Remove cell else cmp E TSym # Value T? if ne # No push C call consE_C # New property cell ld (C) E pop (C CDR) ld (Y) C # Store end ld (X CDR) (Y CDR) # Unlink cell ld X (A TAIL) # Get tail sym X # Extern? if z # No ld (Y CDR) X # Insert cell in front else off X SYM # Clear 'extern' tag ld (Y CDR) X # Insert cell in front or Y SYM # Set 'extern' tag end ld (A TAIL) Y pop Y pop X ret end end else cmp C ((Y) CDR) # Found property? if eq # Yes cmp E Nil # Value NIL? if eq # Yes ld (X CDR) (Y CDR) # Remove cell else cmp E TSym # Value T? if ne # No ld ((Y)) E # Set new value else ld (Y) C # Change to flag end ld (X CDR) (Y CDR) # Unlink cell ld X (A TAIL) # Get tail sym X # Extern? if z # No ld (Y CDR) X # Insert cell in front else off X SYM # Clear 'extern' tag ld (Y CDR) X # Insert cell in front or Y SYM # Set 'extern' tag end ld (A TAIL) Y pop Y pop X ret end end end ld X Y loop pop Y ld X (A TAIL) # Get properties again end cmp E Nil # Value Non-NIL? if ne # Yes cmp E TSym # Flag? if ne # No push C call consE_C # New property cell ld (C) E pop (C CDR) end push C call consC_C # New first property pop (C) sym X # Extern? if z # No ld (C CDR) X else off X SYM # Clear 'extern' tag ld (C CDR) X or C SYM # Set 'extern' tag end ld (A TAIL) C # Set new tail end pop X ret (code 'getnECX_E 0) num E # Need symbol or pair jnz argErrEX atom E # List? if z # Yes num C # Numeric key? if nz # Yes shr C 4 # Positive? if nc # Yes jz retNil # Return NIL if zero do dec C # nth jz retE_E ld E (E CDR) loop end # Key is negative do ld E (E CDR) dec C # nth until z ret end do # asoq atom (E) # CAR atomic? if z # No cmp C ((E)) # Found? break eq # Yes end ld E (E CDR) # Next atom E # Done? jnz retNil # Return NIL loop ld E ((E) CDR) # Return CDAR ret end # E is symbolic sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end (code 'getEC_E 0) cmp C ZERO # Key is zero? jeq retE_E # Get value ld A (E TAIL) # Get tail num A # No properties? jnz retNil # Return NIL off A SYM # Clear 'extern' tag atom (A) # First property atomic? if nz # Yes cmp C (A) # Found flag? jeq retT # Return T else cmp C ((A) CDR) # Found property? if eq # Yes ld E ((A)) # Return value ret end end push X do ld X (A CDR) # Next property atom X # Any? while z # Yes atom (X) # Atomic? if nz # Yes cmp C (X) # Found flag? if eq # Yes ld (A CDR) (X CDR) # Unlink cell ld A (E TAIL) # Get tail sym A # Extern? if z # No ld (X CDR) A # Insert cell in front else off A SYM # Clear 'extern' tag ld (X CDR) A # Insert cell in front or X SYM # Set 'extern' tag end ld (E TAIL) X ld E TSym # Return T pop X ret end else cmp C ((X) CDR) # Found property? if eq # Yes ld (A CDR) (X CDR) # Unlink cell ld A (E TAIL) # Get tail sym A # Extern? if z # No ld (X CDR) A # Insert cell in front ld (E TAIL) X ld E ((X)) # Return value else off A SYM # Clear 'extern' tag ld (X CDR) A # Insert cell in front ld A ((X)) # Return value or X SYM # Set 'extern' tag ld (E TAIL) X ld E A end pop X ret end end ld A X loop ld E Nil # Return NIL pop X ret (code 'propEC_E 0) push X ld A (E TAIL) # Get tail num A # Properties? if z # Yes off A SYM # Clear 'extern' tag atom (A) # First property atomic? if nz # Yes cmp C (A) # Found flag? if eq # Yes ld E C # Return key pop X ret end else cmp C ((A) CDR) # Found property? if eq # Yes ld E (A) # Return property pop X ret end end do ld X (A CDR) # Next property atom X # Any? while z # Yes atom (X) # Atomic? if nz # Yes cmp C (X) # Found flag? if eq # Yes ld (A CDR) (X CDR) # Unlink cell ld A (E TAIL) # Get tail sym A # Extern? if z # No ld (X CDR) A # Insert cell in front else off A SYM # Clear 'extern' tag ld (X CDR) A # Insert cell in front or X SYM # Set 'extern' tag end ld (E TAIL) X ld E C # Return key pop X ret end else cmp C ((X) CDR) # Found property? if eq # Yes ld (A CDR) (X CDR) # Unlink cell ld A (E TAIL) # Get tail sym A # Extern? if z # No ld (X CDR) A # Insert cell in front ld (E TAIL) X ld E (X) # Return property else off A SYM # Clear 'extern' tag ld (X CDR) A # Insert cell in front ld A (X) # Return property or X SYM # Set 'extern' tag ld (E TAIL) X ld E A end pop X ret end end ld A X loop end call cons_A # New property cell ld (A) Nil # (NIL . key) ld (A CDR) C call consA_C # New first property ld (C) A ld X (E TAIL) # Get tail sym X # Extern? if z # No ld (C CDR) X else off X SYM # Clear 'extern' tag ld (C CDR) X or C SYM # Set 'extern' tag end ld (E TAIL) C # Set new tail ld E A # Return first (new) cell pop X ret # (put 'sym1|lst ['sym2|cnt ..] 'sym|0 'any) -> any (code 'doPut 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'sym1|lst' item ld Y (Y CDR) ld E (Y) # Eval second eval+ push E # 'sym2|cnt' key link do ld Y (Y CDR) # Args atom (Y CDR) # More than one? while z # Yes ld C E # Key ld E (L II) # Current item call getnECX_E ld (L II) E # Store item ld E (Y) eval # Eval next arg ld (L I) E # Save it loop ld E (L II) # Get item num E # Need symbol jnz symErrEX sym E jz symErrEX ld E (Y) # Eval 'any' eval ld A (L II) # Get symbol ld C (L I) # Get key sym (A TAIL) # External symbol? if nz # Yes push E # Save 'any' ld E A # Get symbol cmp C Nil # Volatile property? if ne # No call dbTouchEX # Touch it else call dbFetchEX # else fetch end ld A E pop E end cmp C ZERO # Key is zero? if eq # Yes call checkVarAX # Check variable ld (A) E # Set value else call putACE # Put value or propery end drop pop Y pop X ret # (get 'sym1|lst ['sym2|cnt ..]) -> any (code 'doGet 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval ld Y (Y CDR) # Next arg? atom Y if z # Yes link push E # 'sym|lst' item link do ld E (Y) eval # Eval next arg ld C E # Key ld E (L I) # Current item call getnECX_E ld Y (Y CDR) # More args? atom Y while z # Yes ld (L I) E # Save item loop drop end pop Y pop X ret # (prop 'sym1|lst ['sym2|cnt ..] 'sym) -> var (code 'doProp 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'sym|lst' item ld Y (Y CDR) # Next arg ld E (Y) eval+ # Eval next arg push E # 'sym2|cnt' key link do ld Y (Y CDR) # More args? atom Y while z # Yes ld C E # Key ld E (L II) # Current item call getnECX_E ld (L II) E # Store item ld E (Y) eval # Eval next arg ld (L I) E # Save it loop ld E (L II) # Get item num E # Need symbol jnz symErrEX sym E jz symErrEX cmp E Nil # Can't be NIL jeq protErrEX ld C (L I) # Get key sym (E TAIL) # External symbol? if nz # Yes cmp C Nil # Volatile property? if ne # No call dbTouchEX # Touch symbol else call dbFetchEX # else fetch end end call propEC_E drop pop Y pop X ret # (; 'sym1|lst [sym2|cnt ..]) -> any (code 'doSemicol 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval ld Y (Y CDR) # Next arg? atom Y if z # Yes link push E # 'sym|lst' item link do ld C (Y) # Key ld E (L I) # Current item call getnECX_E ld Y (Y CDR) # More args? atom Y while z # Yes ld (L I) E # Save item loop drop end pop Y pop X ret # (=: sym|0 [sym1|cnt .. sym2|0] 'any) -> any (code 'doSetCol 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (This) # Get value of This ld C (Y) # sym1|cnt ld Y (Y CDR) # Args atom (Y CDR) # More than one? if z # Yes sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end call getEC_E do ld C (Y) # sym2|cnt ld Y (Y CDR) # Args atom (Y CDR) # More than one? while z # Yes call getnECX_E loop end num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? if nz # Yes cmp C Nil # Volatile property? if ne # No call dbTouchEX # Touch symbol else call dbFetchEX # else fetch end end push C # Save key push E # Save symbol ld E (Y) # Eval 'any' eval pop A # Retrieve symbol pop C # and key cmp C ZERO # Key is zero? if eq # Yes call checkVarAX # Check variable ld (A) E # Set value else call putACE # Put value or propery end pop Y pop X ret # (: sym|0 [sym1|cnt ..]) -> any (code 'doCol 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (This) # Get value of This sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end ld C (Y) # Next key call getEC_E do ld Y (Y CDR) # More args? atom Y while z # Yes ld C (Y) # Next key call getnECX_E loop pop Y pop X ret # (:: sym|0 [sym1|cnt .. sym2]) -> var (code 'doPropCol 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (This) # Get value of This ld C (Y) # Next key atom (Y CDR) # More than one arg? if z # Yes sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end call getEC_E do ld Y (Y CDR) ld C (Y) # Next key atom (Y CDR) # More than one arg? while z # Yes call getnECX_E loop end num E # Need symbol jnz symErrEX sym E jz symErrEX cmp E Nil # Can't be NIL jeq protErrEX sym (E TAIL) # External symbol? if nz # Yes cmp C Nil # Volatile property? if ne # No call dbTouchEX # Touch symbol else call dbFetchEX # else fetch end end call propEC_E pop Y pop X ret # (putl 'sym1|lst1 ['sym2|cnt ..] 'lst) -> lst (code 'doPutl 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'sym|lst' item ld Y (Y CDR) # Next arg ld E (Y) eval+ # Eval next arg push E # 'sym2|cnt' key link do ld Y (Y CDR) # More args? atom Y while z # Yes ld C E # Key ld E (L II) # Current item call getnECX_E ld (L II) E # Store item ld E (Y) eval # Eval next arg ld (L I) E # Save it loop ld E (L II) # Get item num E # Need symbol jnz symErrEX sym E jz symErrEX cmp E Nil # Can't be NIL jeq protErrEX sym (E TAIL) # External symbol? if nz # Yes call dbTouchEX # Touch it end ld X (E TAIL) # Skip old properties off X SYM # Clear 'extern' tag do num X # More properties? while z # Yes ld X (X CDR) loop ld Y (L I) # New property list do atom Y # Any? while z # Yes ld C (Y) atom C # Flag? if nz # Yes ld A X call consA_X # New property cell ld (X) C ld (X CDR) A else cmp (C) Nil # Value Nil? if ne # No cmp (C) TSym # Flag? if eq # Yes ld C (C CDR) # Get key end ld A X call consA_X # New property cell ld (X) C ld (X CDR) A end end ld Y (Y CDR) loop sym (E TAIL) # Extern? if nz # Yes or X SYM # Set 'extern' tag end ld (E TAIL) X ld E (L I) # Return new property list drop pop Y pop X ret # (getl 'sym1|lst1 ['sym2|cnt ..]) -> lst (code 'doGetl 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'sym|lst' item link do ld Y (Y CDR) # More args? atom Y while z ld E (Y) eval # Eval next arg ld C E # Key ld E (L I) # Current item call getnECX_E ld (L I) E # Save item loop num E # Need symbol jnz symErrEX sym E jz symErrEX sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end ld X (E TAIL) # Get tail num X # No properties? if nz # Yes ld E Nil else off X SYM # Clear 'extern' tag call cons_C # Copy first cell ld (C) (X) ld (C CDR) Nil tuck C # Save it link do ld X (X CDR) # More properties? atom X while z # Yes call cons_A # Copy next cell ld (A) (X) ld (A CDR) Nil ld (C CDR) A # Append ld C A loop ld E (L I) # Get result end drop pop Y pop X ret # (wipe 'sym|lst) -> sym|lst (code 'doWipe 2) ld E ((E CDR)) # Get arg eval # Eval it cmp E Nil # NIL? if ne # No atom E # List? if nz # No call wipeE # Wipe it else push E # Save ld C E # Get list do ld E (C) # Next symbol call wipeE # Wipe it ld C (C CDR) atom C # More? until nz # No pop E end end ret (code 'wipeE 0) ld A (E TAIL) # Get tail sym A # Extern? if z # No call nameA_A # Get name ld (E) Nil # Clear value ld (E TAIL) A # And properties ret end call nameA_A # Get name shl A 1 # Dirty? if nc # No shl A 1 # Loaded? if c # Yes ror A 2 # Set "not loaded" ld (E) Nil # Clear value or A SYM # Set 'extern' tag ld (E TAIL) A end end ret # (meta 'obj|typ 'sym ['sym2|cnt ..]) -> any (code 'doMeta 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval link push E # 'obj|typ' link num E # Need symbol or pair jnz argErrEX sym E # Symbol? if nz # Yes sym (E TAIL) # External symbol? if nz # Yes call dbFetchEX # Fetch it end ld (L I) (E) # Get value end ld Y (Y CDR) # Next arg ld E (Y) eval # Eval next arg ld C E # Key ld X (L I) # 'obj|typ' call metaCX_E # Fetch do ld Y (Y CDR) # More args? atom Y while z # Yes ld (L I) E # Save item ld E (Y) eval # Eval next arg ld C E # Key ld E (L I) # Current item call getnECX_E loop drop pop Y pop X ret (code 'metaCX_E 0) do atom X # List? jnz retNil # No ld E (X) # Next item num E # Symbol? if z sym E if nz # Yes call getEC_E # Propery cmp E Nil # found? jne Ret # No push X ld X ((X)) # Try in superclass(es) cmp S (StkLimit) # Stack check jlt stkErr call metaCX_E pop X cmp E Nil # found? jne Ret # No end end ld X (X CDR) loop ### Case mappings from the GNU Kaffe Project ### (code 'caseDataA_AC 0) ld C A # Keep character in C shr A 4 # Make index off A 1 ld2 (A CaseBlocks) # Get blocks entry add A C # Add character and A (hex "FFFF") # Limit to 16 bits shl A 1 # Adjust index ld2 (A CaseData) # Get case data ret # (low? 'any) -> sym | NIL (code 'doLowQ 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jnz retNil # Yes sym E # Symbol? jz retNil # No call firstCharE_A # Get first character call caseDataA_AC # Get case info and B (hex "1F") # Character type cmp B CHAR_LOWERCASE # Lower case? ldnz E Nil # No ret # (upp? 'any) -> sym | NIL (code 'doUppQ 2) ld E ((E CDR)) # Get arg eval # Eval it num E # Number? jnz retNil # Yes sym E # Symbol? jz retNil # No call firstCharE_A # Get first character call caseDataA_AC # Get case info and B (hex "1F") # Character type cmp B CHAR_UPPERCASE # Lower case? ldnz E Nil # No ret # (lowc 'any) -> any (code 'doLowc 2) push X ld E ((E CDR)) # Get arg eval # Eval it num E # Number? if z # No sym E # Symbol? if nz # Yes cmp E Nil # NIL? if ne # No sym (E TAIL) # External symbol? if z # No ld E (E TAIL) call nameE_E # Get name link push E # Name push ZERO # Result ld X S link push 4 # Build name push X # Pack status ld X (L II) # Get name ld C 0 # Index do call symCharCX_FACX # Next char? while nz ld E C # Save C call caseDataA_AC # Get case info and A (hex "FFFF") shr A 6 # Make index off A 1 ld2 (A CaseLower) # Get lower case entry add A C # plus character and A (hex "FFFF") ld C (S I) # Swap status xchg X (S) call charSymACX_CX # Pack char xchg X (S) # Swap status ld (S I) C ld C E # Restore C loop ld X (L I) # Get result call consSymX_E # Make transient symbol drop end end end end pop X ret # (uppc 'any) -> any (code 'doUppc 2) push X ld E ((E CDR)) # Get arg eval # Eval it num E # Number? if z # No sym E # Symbol? if nz # Yes cmp E Nil # NIL? if ne # No sym (E TAIL) # External symbol? if z # No ld E (E TAIL) call nameE_E # Get name link push E # Name push ZERO # Result ld X S link push 4 # Build name push X # Pack status ld X (L II) # Get name ld C 0 # Index do call symCharCX_FACX # Next char? while nz ld E C # Save C call caseDataA_AC # Get case info and A (hex "FFFF") shr A 6 # Make index off A 1 ld2 (A CaseUpper) # Get upper case entry add A C # plus character and A (hex "FFFF") ld C (S I) # Swap status xchg X (S) call charSymACX_CX # Pack char xchg X (S) # Swap status ld (S I) C ld C E # Restore C loop ld X (L I) # Get result call consSymX_E # Make transient symbol drop end end end end pop X ret # (fold 'any ['cnt]) -> sym (code 'doFold 2) push X push Y ld X E ld Y (E CDR) # Y on args ld E (Y) # Eval first eval num E # Number? if z # No sym E # Symbol? if nz # Yes cmp E Nil # NIL? if ne sym (E TAIL) # External symbol? if z # No ld E (E TAIL) call nameE_E # Get name link push E # Name push ZERO # Result link ld Y (Y CDR) # Next arg? atom Y if nz # No push 0 # Default 'cnt' zero else call evCntXY_FE # Eval 'cnt' push E # 'cnt' end push 4 # Build name lea X (L I) push X # Pack status ld X (L II) # Get name ld C 0 # Index do call symCharCX_FACX # Next char? while nz ld E C # Save C call isLetterOrDigitA_F # Letter or digit? if nz # Yes call caseDataA_AC # Get case info and A (hex "FFFF") shr A 6 # Make index off A 1 ld2 (A CaseLower) # Get lower case entry add A C # plus character and A (hex "FFFF") ld C (S I) # Swap status xchg X (S) call charSymACX_CX # Pack char xchg X (S) # Swap status ld (S I) C dec (S II) # Decrement 'cnt' break z end ld C E # Restore C loop ld X (L I) # Get result call consSymX_E # Make transient symbol drop end end end end pop Y pop X ret (code 'isLetterOrDigitA_F 0) # C push A call caseDataA_AC # Get case info and B (hex "1F") # Character type ld C 1 zxt shl C A test C (| CHAR_DIGIT CHAR_LETTER) pop A ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/0000755000000000000000000000000012265263724014727 5ustar rootrootpicolisp-3.1.5.2.orig/src64/sys/emu.code.l0000644000000000000000000000144512265263724016607 0ustar rootroot# 13oct12abu # (c) Software Lab. Alexander Burger # System macros (push '*SysFun "void errno_A(void) {A.n = (uint64_t)errno;}" ) (code 'errno_A 0) cc errno_A() # Get 'errno' into A ret (push '*SysFun "void errnoC(void) {errno = (int)C.n;}" ) (code 'errnoC 0) cc errnoC() # Store 'errno' ret (push '*SysFun '"void wifstoppedS_F(void) {Result = !WIFSTOPPED(*(int*)(S.p + 8));}" ) (code 'wifstoppedS_F 0) # WIFSTOPPED cc wifstoppedS_F() ret (push '*SysFun '"void wifsignaledS_F(void) {Result = WIFSIGNALED(*(int*)(S.p + 8));}" ) (code 'wifsignaledS_F 0) # WIFSIGNALED cc wifsignaledS_F() ret (push '*SysFun '"int wtermsigS_A(void) {return WTERMSIG(*(int*)(S.p + 8));}" ) (code 'wtermsigS_A 0) # WTERMSIG cc wtermsigS_A() ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/emu.defs.l0000644000000000000000000000040312265263724016607 0ustar rootroot# 05oct12abu # (c) Software Lab. Alexander Burger (load '("./sysdefs")) # Standard I/O (def 'stdin 'sys 'stdin) (def 'stdout 'sys 'stdout) (def 'stderr 'sys 'stderr) # Function pointers (def 'sig 'sys 'sig) (def 'sigTerm 'sys 'sigTerm) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/ppc64.linux.code.l0000644000000000000000000000127612265263724020115 0ustar rootroot# 30sep12abu # (c) Software Lab. Alexander Burger # System macros (code 'errno_A 0) cc __errno_location() # Get address of 'errno' ld4 (A) # Load value ret (code 'errnoC 0) cc __errno_location() # Get address of 'errno' xchg A C st4 (C) # Store new value ret (code 'wifstoppedS_F 0) # WIFSTOPPED ld4 (S I) # Get status cmp B `(hex "7F") # (((status) & 0xff) == 0x7f) ret (code 'wifsignaledS_F 0) # WIFSIGNALED ld4 (S I) # Get status and B `(hex "7F") # (((status) & 0x7f) + 1) >> 1) > 0) inc B shr B 1 ret (code 'wtermsigS_A 0) # WTERMSIG ld4 (S I) # Get status and B `(hex "7F") # ((status) & 0x7f) zxt ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/ppc64.linux.defs.l0000644000000000000000000000476212265263724020127 0ustar rootroot# 20oct11abu # (c) Software Lab. Alexander Burger # errno (equ ENOENT 2) # No such file or directory (equ EINTR 4) # Interrupted system call (equ EBADF 9) # Bad file number (equ EAGAIN 11) # Try again (equ EACCES 13) # Permission denied (equ EPIPE 32) # Broken pipe (equ ECONNRESET 104) # Connection reset by peer # open/fcntl (equ O_RDONLY 0) (equ O_WRONLY 1) (equ O_RDWR 2) (equ O_CREAT 64) (equ O_EXCL 128) (equ O_TRUNC 512) (equ O_APPEND 1024) (equ F_GETFD 1) (equ F_SETFD 2) (equ FD_CLOEXEC 1) # stdio (equ BUFSIZ 8192) (equ PIPE_BUF 4096) (equ MAXPATHLEN 4096) # dlfcn (equ RTLD_LAZY 1) (equ RTLD_GLOBAL 256) # fcntl (equ FLOCK 32) # File lock structure (equ L_TYPE 0) # 2 (equ L_WHENCE 2) # 2 (equ L_START 8) (equ L_LEN 16) (equ L_PID 24) (equ SEEK_SET 0) (equ SEEK_CUR 1) (equ F_RDLCK 0) (equ F_WRLCK 1) (equ F_UNLCK 2) (equ F_GETFL 3) (equ F_SETFL 4) (equ F_GETLK 5) (equ F_SETLK 6) (equ F_SETLKW 7) (equ F_SETOWN 8) (equ O_NONBLOCK 2048) (equ O_ASYNC 8192) # stat (equ STAT 144) # File status structure (equ ST_MODE 24) # 4 (equ ST_SIZE 48) (equ ST_MTIME 88) (equ S_IFMT (hex "F000")) (equ S_IFDIR (hex "4000")) # times (equ TMS 32) # 'times' structure (equ TMS_UTIME 0) (equ TMS_STIME 8) # termios (equ TERMIOS 60) # Terminal I/O structure (equ C_IFLAG 0) (equ C_LFLAG 12) (equ C_CC 17) (equ ISIG 128) (equ VMIN 5) (equ VTIME 7) (equ TCSADRAIN 1) # signal (equ SIGACTION 152) # Sigaction structure (equ SIGSET_T 128) (equ SA_HANDLER 0) (equ SA_MASK 8) (equ SA_FLAGS 136) (equ SIG_DFL 0) (equ SIG_IGN 1) (equ SIG_UNBLOCK 1) (equ SIGHUP 1) # Signals (equ SIGINT 2) (equ SIGUSR1 10) (equ SIGUSR2 12) (equ SIGPIPE 13) (equ SIGALRM 14) (equ SIGTERM 15) (equ SIGCHLD 17) (equ SIGCONT 18) (equ SIGSTOP 19) (equ SIGTSTP 20) (equ SIGTTIN 21) (equ SIGTTOU 22) (equ SIGIO 29) (equ SIGNALS 30) # Highest used signal number plus 1 # wait (equ WNOHANG 1) (equ WUNTRACED 2) # select (equ FD_SET 128) # 1024 bit # time (equ TM_SEC 0) (equ TM_MIN 4) (equ TM_HOUR 8) (equ TM_MDAY 12) (equ TM_MON 16) (equ TM_YEAR 20) # dir (equ D_NAME 19) # Sockets (equ SOCK_STREAM 1) (equ SOCK_DGRAM 2) (equ AF_UNSPEC 0) (equ AF_INET6 10) (equ SOL_SOCKET 1) (equ SO_REUSEADDR 2) (equ IPPROTO_IPV6 41) (equ IPV6_V6ONLY 26) (equ INET6_ADDRSTRLEN 46) (equ NI_MAXHOST 1025) (equ NI_NAMEREQD 8) (equ SOCKADDR_IN6 28) (equ SIN6_FAMILY 0) (equ SIN6_PORT 2) (equ SIN6_ADDR 8) (equ ADDRINFO 48) (equ AI_FAMILY 4) (equ AI_SOCKTYPE 8) (equ AI_ADDRLEN 16) (equ AI_ADDR 24) (equ AI_NEXT 40) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/x86-64.freeBsd.code.l0000644000000000000000000000201412265263724020237 0ustar rootroot# 07jan13abu # Mansur Mamkin # System macros (code 'errno_A 0) call __error # Get address of 'errno' ld A (A) # Load value ret (code 'errnoC 0) call __error # Get address of 'errno' ld (A) C # Store new value ret #define>_WSTATUS(x)<--->(_W_INT(x) & 0177) #define>_WSTOPPED<----->0177<--><------>/* _WSTATUS if process is stopped */ #define>WIFSTOPPED(x)<->(_WSTATUS(x) == _WSTOPPED) #define>WIFSIGNALED(x)<>(_WSTATUS(x) != _WSTOPPED && _WSTATUS(x) != 0) #define>WTERMSIG(x)<--->(_WSTATUS(x)) (code 'wifstoppedS_F 0) # WIFSTOPPED ld A (S I) # Get status and B `(oct "0177") cmp B `(oct "0177") # (((status) & 0177) == 0177) ret (code 'wifsignaledS_F 0) # WIFSIGNALED ld A (S I) # Get status and B `(oct "0177") # ((((status) & 0177) != 0177) && ((status) & 0177) != 0) cmp B `(oct "0177") if ne nul B end ret (code 'wtermsigS_A 0) # WTERMSIG ld A (S I) # Get status and B `(oct "0177") # ((status) & 0177) zxt ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/x86-64.freeBsd.defs.l0000644000000000000000000000425212265263724020254 0ustar rootroot# 07jan13abu # Mansur Mamkin # errno (equ ENOENT 2) (equ EINTR 4) (equ EBADF 9) (equ EAGAIN 35) (equ EACCES 13) (equ EPIPE 32) (equ ECONNRESET 54) # open/fcntl (equ O_RDONLY 0) (equ O_WRONLY 1) (equ O_RDWR 2) (equ O_CREAT 512) (equ O_EXCL 2048) (equ O_TRUNC 1024) (equ O_APPEND 8) (equ F_GETFD 1) (equ F_SETFD 2) (equ FD_CLOEXEC 1) # stdio (equ BUFSIZ 1024) (equ PIPE_BUF 512) (equ MAXPATHLEN 0) (equ stdin "$__stdinp") (equ stdout "$__stdoutp") (equ stderr "$__stderrp") # dlfcn (equ RTLD_LAZY 1) (equ RTLD_GLOBAL 256) # fcntl (equ FLOCK 32) (equ L_TYPE 20) (equ L_WHENCE 22) (equ L_START 0) (equ L_LEN 8) (equ L_PID 16) (equ SEEK_SET 0) (equ SEEK_CUR 1) (equ F_RDLCK 1) (equ F_WRLCK 3) (equ F_UNLCK 2) (equ F_GETFL 3) (equ F_SETFL 4) (equ F_GETLK 11) (equ F_SETLK 12) (equ F_SETLKW 13) (equ F_SETOWN 6) (equ O_NONBLOCK 4) (equ O_ASYNC 64) # stat (equ STAT 120) (equ ST_MODE 8) (equ ST_SIZE 72) (equ ST_MTIME 40) (equ S_IFMT 61440) (equ S_IFDIR 16384) # times (equ TMS 16) (equ TMS_UTIME 0) (equ TMS_STIME 4) # termios (equ TERMIOS 44) (equ C_IFLAG 0) (equ C_LFLAG 12) (equ C_CC 16) (equ ISIG 128) (equ VMIN 16) (equ VTIME 17) (equ TCSADRAIN 1) # signal (equ SIGACTION 32) (equ SIGSET_T 16) (equ SA_HANDLER 0) (equ SA_MASK 12) (equ SA_FLAGS 8) (equ SIG_DFL 0) (equ SIG_IGN 1) (equ SIG_UNBLOCK 2) (equ SIGHUP 1) (equ SIGINT 2) (equ SIGUSR1 30) (equ SIGUSR2 31) (equ SIGPIPE 13) (equ SIGALRM 14) (equ SIGTERM 15) (equ SIGCHLD 20) (equ SIGCONT 19) (equ SIGSTOP 17) (equ SIGTSTP 18) (equ SIGTTIN 21) (equ SIGTTOU 22) (equ SIGIO 23) (equ SIGNALS 32) # wait (equ WNOHANG 1) (equ WUNTRACED 2) # select (equ FD_SET 128) # time (equ TM_SEC 0) (equ TM_MIN 4) (equ TM_HOUR 8) (equ TM_MDAY 12) (equ TM_MON 16) (equ TM_YEAR 20) # dir (equ D_NAME 8) # Sockets (equ SOCK_STREAM 1) (equ SOCK_DGRAM 2) (equ AF_UNSPEC 0) (equ AF_INET6 28) (equ SOL_SOCKET 65535) (equ SO_REUSEADDR 4) (equ IPPROTO_IPV6 41) (equ IPV6_V6ONLY 27) (equ INET6_ADDRSTRLEN 46) (equ NI_MAXHOST 1025) (equ NI_NAMEREQD 4) (equ SOCKADDR_IN6 28) (equ SIN6_FAMILY 1) (equ SIN6_PORT 2) (equ SIN6_ADDR 8) (equ ADDRINFO 48) (equ AI_FAMILY 4) (equ AI_SOCKTYPE 8) (equ AI_ADDRLEN 16) (equ AI_ADDR 32) (equ AI_NEXT 40) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/x86-64.linux.code.l0000644000000000000000000000130112265263724020022 0ustar rootroot# 30sep12abu # (c) Software Lab. Alexander Burger # System macros (code 'errno_A 0) call __errno_location # Get address of 'errno' ld4 (A) # Load value ret (code 'errnoC 0) call __errno_location # Get address of 'errno' xchg A C st4 (C) # Store new value ret (code 'wifstoppedS_F 0) # WIFSTOPPED ld A (S I) # Get status cmp B `(hex "7F") # (((status) & 0xff) == 0x7f) ret (code 'wifsignaledS_F 0) # WIFSIGNALED ld A (S I) # Get status and B `(hex "7F") # (((status) & 0x7f) + 1) >> 1) > 0) inc B shr B 1 ret (code 'wtermsigS_A 0) # WTERMSIG ld A (S I) # Get status and B `(hex "7F") # ((status) & 0x7f) zxt ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/x86-64.linux.defs.l0000644000000000000000000000475512265263724020051 0ustar rootroot# 19oct11abu # (c) Software Lab. Alexander Burger # errno (equ ENOENT 2) # No such file or directory (equ EINTR 4) # Interrupted system call (equ EBADF 9) # Bad file number (equ EAGAIN 11) # Try again (equ EACCES 13) # Permission denied (equ EPIPE 32) # Broken pipe (equ ECONNRESET 104) # Connection reset by peer # open/fcntl (equ O_RDONLY 0) (equ O_WRONLY 1) (equ O_RDWR 2) (equ O_CREAT 64) (equ O_EXCL 128) (equ O_TRUNC 512) (equ O_APPEND 1024) (equ F_GETFD 1) (equ F_SETFD 2) (equ FD_CLOEXEC 1) # stdio (equ BUFSIZ 8192) (equ PIPE_BUF 4096) (equ MAXPATHLEN 0) # dlfcn (equ RTLD_LAZY 1) (equ RTLD_GLOBAL 256) # fcntl (equ FLOCK 32) # File lock structure (equ L_TYPE 0) # 2 (equ L_WHENCE 2) # 2 (equ L_START 8) (equ L_LEN 16) (equ L_PID 24) (equ SEEK_SET 0) (equ SEEK_CUR 1) (equ F_RDLCK 0) (equ F_WRLCK 1) (equ F_UNLCK 2) (equ F_GETFL 3) (equ F_SETFL 4) (equ F_GETLK 5) (equ F_SETLK 6) (equ F_SETLKW 7) (equ F_SETOWN 8) (equ O_NONBLOCK 2048) (equ O_ASYNC 8192) # stat (equ STAT 144) # File status structure (equ ST_MODE 24) # 4 (equ ST_SIZE 48) (equ ST_MTIME 88) (equ S_IFMT (hex "F000")) (equ S_IFDIR (hex "4000")) # times (equ TMS 32) # 'times' structure (equ TMS_UTIME 0) (equ TMS_STIME 8) # termios (equ TERMIOS 60) # Terminal I/O structure (equ C_IFLAG 0) (equ C_LFLAG 12) (equ C_CC 17) (equ ISIG 1) (equ VMIN 6) (equ VTIME 5) (equ TCSADRAIN 1) # signal (equ SIGACTION 152) # Sigaction structure (equ SIGSET_T 128) (equ SA_HANDLER 0) (equ SA_MASK 8) (equ SA_FLAGS 136) (equ SIG_DFL 0) (equ SIG_IGN 1) (equ SIG_UNBLOCK 1) (equ SIGHUP 1) # Signals (equ SIGINT 2) (equ SIGUSR1 10) (equ SIGUSR2 12) (equ SIGPIPE 13) (equ SIGALRM 14) (equ SIGTERM 15) (equ SIGCHLD 17) (equ SIGCONT 18) (equ SIGSTOP 19) (equ SIGTSTP 20) (equ SIGTTIN 21) (equ SIGTTOU 22) (equ SIGIO 29) (equ SIGNALS 30) # Highest used signal number plus 1 # wait (equ WNOHANG 1) (equ WUNTRACED 2) # select (equ FD_SET 128) # 1024 bit # time (equ TM_SEC 0) (equ TM_MIN 4) (equ TM_HOUR 8) (equ TM_MDAY 12) (equ TM_MON 16) (equ TM_YEAR 20) # dir (equ D_NAME 19) # Sockets (equ SOCK_STREAM 1) (equ SOCK_DGRAM 2) (equ AF_UNSPEC 0) (equ AF_INET6 10) (equ SOL_SOCKET 1) (equ SO_REUSEADDR 2) (equ IPPROTO_IPV6 41) (equ IPV6_V6ONLY 26) (equ INET6_ADDRSTRLEN 46) (equ NI_MAXHOST 1025) (equ NI_NAMEREQD 8) (equ SOCKADDR_IN6 28) (equ SIN6_FAMILY 0) (equ SIN6_PORT 2) (equ SIN6_ADDR 8) (equ ADDRINFO 48) (equ AI_FAMILY 4) (equ AI_SOCKTYPE 8) (equ AI_ADDRLEN 16) (equ AI_ADDR 24) (equ AI_NEXT 40) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/x86-64.sunOs.code.l0000644000000000000000000000130112265263724017772 0ustar rootroot# 19may10 # zonick # (c) Software Lab. Alexander Burger # System macros (code 'errno_A 0) call ___errno # Get address of 'errno' ld A (A) # Load value ret (code 'errnoC 0) call ___errno # Get address of 'errno' ld (A) C # Store new value ret (code 'wifstoppedS_F 0) # WIFSTOPPED ld A (S I) # Get status cmp B `(hex "7F") # (((status) & 0xff) == 0x7f) ret (code 'wifsignaledS_F 0) # WIFSIGNALED ld A (S I) # Get status and B `(hex "7F") # (((status) & 0x7f) + 1) >> 1) > 0) inc B shr B 1 ret (code 'wtermsigS_A 0) # WTERMSIG ld A (S I) # Get status and B `(hex "7F") # ((status) & 0x7f) zxt ret # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sys/x86-64.sunOs.defs.l0000644000000000000000000000514312265263724020011 0ustar rootroot# 17sep10 # zonick # (c) Software Lab. Alexander Burger # errno (equ ENOENT 2) # No such file or directory (equ EINTR 4) # Interrupted system call (equ EBADF 9) # Bad file number (equ EAGAIN 11) # Try again (equ EACCES 13) # Permission denied (equ EPIPE 32) # Broken pipe (equ ECONNRESET 131) # Connection reset by peer # open/fcntl (equ O_RDONLY 0) (equ O_WRONLY 1) (equ O_RDWR 2) (equ O_CREAT 256) (equ O_EXCL 1024) (equ O_TRUNC 512) (equ O_APPEND 8) (equ F_GETFD 1) (equ F_SETFD 2) (equ FD_CLOEXEC 1) # stdio (equ BUFSIZ 1024) (equ PIPE_BUF 5120) (equ stdin "$__iob") (equ stdout "$__iob+128") (equ stderr "$__iob+256") (equ MAXPATHLEN 1024) # dlfcn (equ RTLD_LAZY 1) (equ RTLD_GLOBAL 256) # fcntl (equ FLOCK 64) # File lock structure (equ L_TYPE 0) # 2 (equ L_WHENCE 2) # 2 (equ L_START 8) (equ L_LEN 16) (equ L_PID 28) (equ SEEK_SET 0) (equ SEEK_CUR 1) (equ F_RDLCK 1) (equ F_WRLCK 2) (equ F_UNLCK 3) (equ F_GETFL 3) (equ F_SETFL 4) (equ F_GETLK 14) (equ F_SETLK 6) (equ F_SETLKW 7) (equ F_SETOWN 24) (equ O_NONBLOCK 128) (equ O_ASYNC 0) # stat (equ STAT 128) # File status structure (equ ST_MODE 16) # 4 (equ ST_SIZE 40) (equ ST_MTIME 64) (equ S_IFMT (hex "F000")) (equ S_IFDIR (hex "4000")) # times (equ TMS 32) # 'times' structure (equ TMS_UTIME 0) (equ TMS_STIME 8) # termios (equ TERMIOS 36) # Terminal I/O structure (equ C_IFLAG 0) (equ C_LFLAG 12) (equ C_CC 16) (equ ISIG 1) (equ VMIN 4) (equ VTIME 5) (equ TCSADRAIN 21519) # signal (equ SIGACTION 32) # Sigaction structure (equ SIGSET_T 16) (equ SA_HANDLER 8) (equ SA_MASK 16) (equ SA_FLAGS 0) (equ SIG_DFL 0) (equ SIG_IGN 1) (equ SIG_UNBLOCK 2) (equ SIGHUP 1) # Signals (equ SIGINT 2) (equ SIGUSR1 16) (equ SIGUSR2 17) (equ SIGPIPE 13) (equ SIGALRM 14) (equ SIGTERM 15) (equ SIGCHLD 18) (equ SIGCONT 25) (equ SIGSTOP 23) (equ SIGTSTP 24) (equ SIGTTIN 26) (equ SIGTTOU 27) (equ SIGIO 22) (equ SIGNALS 28) # Highest used signal number plus 1 # wait (equ WNOHANG 64) (equ WUNTRACED 4) # select (equ FD_SET 8192) # 1024 bit # time (equ TM_SEC 0) (equ TM_MIN 4) (equ TM_HOUR 8) (equ TM_MDAY 12) (equ TM_MON 16) (equ TM_YEAR 20) # dir (equ D_NAME 18) # Sockets (equ SOCK_STREAM 2) (equ SOCK_DGRAM 1) (equ AF_UNSPEC 0) (equ AF_INET6 26) (equ SOL_SOCKET 65535) (equ SO_REUSEADDR 4) (equ IPPROTO_IPV6 41) (equ IPV6_V6ONLY 39) (equ INET6_ADDRSTRLEN 46) (equ NI_MAXHOST 1025) (equ NI_NAMEREQD 4) (equ SOCKADDR_IN6 32) (equ SIN6_FAMILY 0) (equ SIN6_PORT 2) (equ SIN6_ADDR 8) (equ ADDRINFO 48) (equ AI_FAMILY 4) (equ AI_SOCKTYPE 8) (equ AI_ADDRLEN 16) (equ AI_ADDR 32) (equ AI_NEXT 40) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/src64/sysdefs.c0000644000000000000000000001274012265263724015741 0ustar rootroot/* 18nov13abu * (c) Software Lab. Alexander Burger */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include static int SigNums[] = { SIGHUP, SIGINT, SIGUSR1, SIGUSR2, SIGPIPE, SIGALRM, SIGTERM, SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGIO }; static char *SigNames[] = { "SIGHUP", "SIGINT", "SIGUSR1", "SIGUSR2", "SIGPIPE", "SIGALRM", "SIGTERM", "SIGCHLD", "SIGCONT", "SIGSTOP", "SIGTSTP", "SIGTTIN", "SIGTTOU", "SIGIO" }; static void comment(char *s) { printf("\n# %s\n", s); } static void equ(char *sym, long val) { printf("(equ %s %ld)\n", sym, val); } int main(void) { int i, n; struct flock fl; struct stat st; struct tms tim; struct termios term; struct sigaction act; fd_set rdSet; struct tm tm; struct dirent dir; struct sockaddr_in6 addr; struct addrinfo ai; i = 1; printf("# Endianess\n%c\n# Wordsize\n%d\n", *(char*)&i == 1? 'L' : 'B', (int)sizeof(char*) * 8 ); comment("errno"); equ("ENOENT", ENOENT); equ("EINTR", EINTR); equ("EBADF", EBADF); equ("EAGAIN", EAGAIN); equ("EACCES", EACCES); equ("EPIPE", EPIPE); equ("ECONNRESET", ECONNRESET); comment("open/fcntl"); equ("O_RDONLY", O_RDONLY); equ("O_WRONLY", O_WRONLY); equ("O_RDWR", O_RDWR); equ("O_CREAT", O_CREAT); equ("O_EXCL", O_EXCL); equ("O_TRUNC", O_TRUNC); equ("O_APPEND", O_APPEND); equ("F_GETFD", F_GETFD); equ("F_SETFD", F_SETFD); equ("FD_CLOEXEC", FD_CLOEXEC); comment("stdio"); equ("BUFSIZ", BUFSIZ); equ("PIPE_BUF", PIPE_BUF); equ("MAXPATHLEN", 0); // getcwd(NULL,0) comment("dlfcn"); equ("RTLD_LAZY", RTLD_LAZY); equ("RTLD_GLOBAL", RTLD_GLOBAL); comment("fcntl"); equ("FLOCK", sizeof(fl)); equ("L_TYPE", (char*)&fl.l_type - (char*)&fl); equ("L_WHENCE", (char*)&fl.l_whence - (char*)&fl); equ("L_START", (char*)&fl.l_start - (char*)&fl); equ("L_LEN", (char*)&fl.l_len - (char*)&fl); equ("L_PID", (char*)&fl.l_pid - (char*)&fl); equ("SEEK_SET", SEEK_SET); equ("SEEK_CUR", SEEK_CUR); equ("F_RDLCK", F_RDLCK); equ("F_WRLCK", F_WRLCK); equ("F_UNLCK", F_UNLCK); equ("F_GETFL", F_GETFL); equ("F_SETFL", F_SETFL); equ("F_GETLK", F_GETLK); equ("F_SETLK", F_SETLK); equ("F_SETLKW", F_SETLKW); equ("F_SETOWN", F_SETOWN); equ("O_NONBLOCK", O_NONBLOCK); equ("O_ASYNC", O_ASYNC); comment("stat"); equ("STAT", sizeof(st)); equ("ST_MODE", (char*)&st.st_mode - (char*)&st); equ("ST_SIZE", (char*)&st.st_size - (char*)&st); equ("ST_MTIME", (char*)&st.st_mtime - (char*)&st); equ("S_IFMT", S_IFMT); equ("S_IFDIR", S_IFDIR); comment("times"); equ("TMS", sizeof(tim)); equ("TMS_UTIME", (char*)&tim.tms_utime - (char*)&tim); equ("TMS_STIME", (char*)&tim.tms_stime - (char*)&tim); comment("termios"); equ("TERMIOS", sizeof(term)); equ("C_IFLAG", (char*)&term.c_iflag - (char*)&term); equ("C_LFLAG", (char*)&term.c_lflag - (char*)&term); equ("C_CC", (char*)&term.c_cc - (char*)&term); equ("ISIG", ISIG); equ("VMIN", VMIN); equ("VTIME", VTIME); equ("TCSADRAIN", TCSADRAIN); comment("signal"); equ("SIGACTION", sizeof(act)); equ("SIGSET_T", sizeof(sigset_t)); equ("SA_HANDLER", (char*)&act.sa_handler - (char*)&act); equ("SA_MASK", (char*)&act.sa_mask - (char*)&act); equ("SA_FLAGS", (char*)&act.sa_flags - (char*)&act); equ("SIG_DFL", (long)SIG_DFL); equ("SIG_IGN", (long)SIG_IGN); equ("SIG_UNBLOCK", SIG_UNBLOCK); for (i = n = 0; i < sizeof(SigNums)/sizeof(int); ++i) { equ(SigNames[i], SigNums[i]); if (SigNums[i] > n) n = SigNums[i]; } equ("SIGNALS", n + 1); // Highest used signal number plus 1 comment("wait"); equ("WNOHANG", WNOHANG); equ("WUNTRACED", WUNTRACED); comment("select"); equ("FD_SET", sizeof(rdSet)); comment("time"); equ("TM_SEC", (char*)&tm.tm_sec - (char*)&tm); equ("TM_MIN", (char*)&tm.tm_min - (char*)&tm); equ("TM_HOUR", (char*)&tm.tm_hour - (char*)&tm); equ("TM_MDAY", (char*)&tm.tm_mday - (char*)&tm); equ("TM_MON", (char*)&tm.tm_mon - (char*)&tm); equ("TM_YEAR", (char*)&tm.tm_year - (char*)&tm); comment("dir"); equ("D_NAME", (char*)&dir.d_name - (char*)&dir); comment("Sockets"); equ("SOCK_STREAM", SOCK_STREAM); equ("SOCK_DGRAM", SOCK_DGRAM); equ("AF_UNSPEC", AF_UNSPEC); equ("AF_INET6", AF_INET6); equ("SOL_SOCKET", SOL_SOCKET); equ("SO_REUSEADDR", SO_REUSEADDR); equ("IPPROTO_IPV6", IPPROTO_IPV6); equ("IPV6_V6ONLY", IPV6_V6ONLY); equ("INET6_ADDRSTRLEN", INET6_ADDRSTRLEN); equ("NI_MAXHOST", NI_MAXHOST); equ("NI_NAMEREQD", NI_NAMEREQD); equ("SOCKADDR_IN6", sizeof(addr)); equ("SIN6_FAMILY", (char*)&addr.sin6_family - (char*)&addr); equ("SIN6_PORT", (char*)&addr.sin6_port - (char*)&addr); equ("SIN6_ADDR", (char*)&addr.sin6_addr - (char*)&addr); equ("ADDRINFO", sizeof(ai)); equ("AI_FAMILY", (char*)&ai.ai_family - (char*)&ai); equ("AI_SOCKTYPE", (char*)&ai.ai_socktype - (char*)&ai); equ("AI_ADDRLEN", (char*)&ai.ai_addrlen - (char*)&ai); equ("AI_ADDR", (char*)&ai.ai_addr - (char*)&ai); equ("AI_NEXT", (char*)&ai.ai_next - (char*)&ai); } picolisp-3.1.5.2.orig/src64/tags0000644000000000000000000005633312265263724015004 0ustar rootroot ./defs.l,639 HEAP5,63 CELLS6,114 STACK7,187 ZERO8,263 ONE9,312 TOP10,361 DB111,407 I14,472 II15,482 III16,494 IV17,507 V18,519 VI19,530 VII20,542 VIII21,555 IX22,569 -I24,582 -II25,596 -III26,612 -IV27,629 -V28,645 -VI29,660 -VII30,676 -VIII31,693 CNT34,727 BIG35,754 DIG36,801 CDR37,846 SIGN38,887 SYM39,925 TAIL40,953 NIX43,1001 BEG44,1025 DOT45,1056 END46,1088 NUMBER47,1117 INTERN48,1144 TRANSIENT49,1180 EXTERN50,1217 BLK53,1263 BLKSIZE54,1302 BLKTAG55,1341 UDPMAX58,1390 CHAR_UPPERCASE61,1470 CHAR_LOWERCASE62,1493 CHAR_LETTER63,1516 CHAR_DIGIT64,1537 sys/x86-64.freeBsd.defs.l,1994 ENOENT5,56 EINTR6,71 EBADF7,85 EAGAIN8,99 EACCES9,115 EPIPE10,131 ECONNRESET11,146 O_RDONLY14,180 O_WRONLY15,197 O_RDWR16,214 O_CREAT17,229 O_EXCL18,247 O_TRUNC19,265 O_APPEND20,284 F_GETFD21,301 F_SETFD22,317 FD_CLOEXEC23,333 BUFSIZ26,361 PIPE_BUF27,379 MAXPATHLEN28,398 stdin29,417 stdout30,442 stderr31,468 RTLD_LAZY35,504 RTLD_GLOBAL36,522 FLOCK39,553 L_TYPE40,568 L_WHENCE41,584 L_START42,602 L_LEN43,618 L_PID44,632 SEEK_SET45,647 SEEK_CUR46,664 F_RDLCK47,681 F_WRLCK48,697 F_UNLCK49,713 F_GETFL50,729 F_SETFL51,745 F_GETLK52,761 F_SETLK53,778 F_SETLKW54,795 F_SETOWN55,813 O_NONBLOCK56,830 O_ASYNC57,849 STAT60,874 ST_MODE61,889 ST_SIZE62,905 ST_MTIME63,922 S_IFMT64,940 S_IFDIR65,959 TMS68,988 TMS_UTIME69,1001 TMS_STIME70,1019 TERMIOS73,1048 C_IFLAG74,1065 C_LFLAG75,1081 C_CC76,1098 ISIG77,1112 VMIN78,1127 VTIME79,1141 TCSADRAIN80,1156 SIGACTION83,1184 SIGSET_T84,1203 SA_HANDLER85,1221 SA_MASK86,1240 SA_FLAGS87,1257 SIG_DFL88,1274 SIG_IGN89,1290 SIG_UNBLOCK90,1306 SIGHUP91,1326 SIGINT92,1341 SIGUSR193,1356 SIGUSR294,1373 SIGPIPE95,1390 SIGALRM96,1407 SIGTERM97,1424 SIGCHLD98,1441 SIGCONT99,1458 SIGSTOP100,1475 SIGTSTP101,1492 SIGTTIN102,1509 SIGTTOU103,1526 SIGIO104,1543 SIGNALS105,1558 WNOHANG108,1583 WUNTRACED109,1599 FD_SET112,1627 TM_SEC115,1652 TM_MIN116,1667 TM_HOUR117,1682 TM_MDAY118,1698 TM_MON119,1715 TM_YEAR120,1731 D_NAME123,1755 SOCK_STREAM126,1781 SOCK_DGRAM127,1801 AF_UNSPEC128,1820 AF_INET6129,1838 SOL_SOCKET130,1856 SO_REUSEADDR131,1879 IPPROTO_IPV6132,1900 IPV6_V6ONLY133,1922 INET6_ADDRSTRLEN134,1943 NI_MAXHOST135,1969 NI_NAMEREQD136,1991 SOCKADDR_IN6137,2011 SIN6_FAMILY138,2033 SIN6_PORT139,2053 SIN6_ADDR140,2071 ADDRINFO141,2089 AI_FAMILY142,2107 AI_SOCKTYPE143,2125 AI_ADDRLEN144,2145 AI_ADDR145,2165 AI_NEXT146,2182 ./glob.l,4331 Data4,51 AV7,77 AV08,141 Home9,189 Heaps10,239 Avail11,284 Buf12,330 Stack015,412 Stack116,469 Stacks17,525 StkSize18,590 StkLimit19,654 Termio20,719 Tv21,776 Time23,854 USec24,915 TtyPid25,971 InFDs26,1026 InFiles27,1090 OutFDs28,1137 OutFiles29,1202 PutBinBZ30,1250 GetBinZ_FB31,1308 Seed32,1365 TickU34,1468 TickS35,1522 Slot36,1578 Spkr37,1625 Mic38,1676 SpMiPipe39,1726 Hear40,1785 Tell41,1833 TellBuf42,1884 Talking43,1930 Children44,1978 Child45,2039 ExtN46,2086 Extn47,2144 StrX48,2167 StrC49,2216 LineC50,2239 Break51,2263 GcCount52,2309 Sep053,2360 Sep354,2413 BufEnd55,2467 Penv57,2529 Pnl58,2582 Signal61,2618 DBs64,2665 DbFile65,2726 DbFiles66,2769 DbBlock67,2813 MaxBlkSize68,2861 BlkIndex69,2915 BlkLink70,2962 DbJnl71,3008 DbLog72,3056 GcMark75,3132 Transient76,3141 Alarm78,3254 Sigio79,3303 LineX80,3352 Lisp81,3400 LispEnd129,4925 GcMarkEnd130,4935 SymTab134,4964 Nil135,4981 Pico138,5138 pico143,5280 CPU144,5318 OS145,5357 DB146,5395 Meth147,5432 Quote148,5472 TSym149,5513 ISym152,5572 NSym153,5609 SSym154,5646 CSym155,5683 BSym156,5720 Solo157,5757 PPid158,5795 Pid159,5832 At160,5867 At2161,5904 At3162,5941 This163,5978 Prompt164,6015 Dbg165,6052 Zap166,6089 Ext167,6126 Scl168,6163 Class169,6201 Run170,6238 Hup171,6275 Sig1172,6312 Sig2173,6349 Up174,6386 Err175,6423 Msg176,6460 Uni177,6497 Led178,6534 Tsm179,6571 Adr180,6608 Fork181,6645 Bye182,6682 SymTabEnd564,21364 TgCPU567,21397 TgOS568,21439 Db1572,21530 Extern574,21557 GcSymEnd578,21628 Version581,21657 EnvCo592,21864 Chr593,21897 PutB594,21951 Get_A595,22012 InFile596,22072 OutFile597,22118 Catch598,22165 Env599,22213 EnvBind600,22246 EnvInFrames601,22319 EnvOutFrames602,22367 EnvErrFrames603,22416 EnvCtlFrames604,22464 EnvIntern605,22514 EnvArgs606,22587 EnvNext607,22636 EnvCls608,22683 EnvKey609,22731 EnvApply610,22777 EnvMake611,22825 EnvYoke612,22871 CLink613,22894 EnvParseX614,22951 EnvParseC615,23000 EnvParseEOF616,23023 EnvMid617,23047 EnvCo7618,23075 EnvTask619,23121 EnvProtect620,23166 EnvTrace621,23219 EnvEnd622,23266 OrgTermio624,23295 Flock625,23356 Tms626,23411 Addr627,23464 TBuf629,23524 CaseBlocks634,23661 CaseData764,39044 CaseUpper1101,78925 CaseLower1125,80751 Tio1150,82457 Repl1152,82506 PRepl1153,82551 Jam1154,82598 InBye1155,82643 Sync1156,82690 Month1157,82752 _r_1160,82818 _w_1161,82835 _a_1162,82852 _ap_1163,82869 _dot_1164,82888 Giveup1168,82941 ExecErr1169,82967 AllocErr1170,83003 PidSigMsg1171,83032 QuitMsg1172,83065 CbErr1173,83086 HashBlank1175,83130 Redefined1176,83153 SuperErr1177,83187 ExtraErr1178,83216 ThrowErr1179,83245 Trc11180,83278 Trc21181,83296 SetFD1183,83322 Delim1184,83347 DelimEnd1185,83388 Arrow1186,83399 RolbLog1188,83426 IgnLog1189,83487 CircFree1190,83541 BadChain1191,83579 BadCount1192,83608 ErrTok1194,83645 Dashes1195,83666 ProtErr1196,83688 SymNsErr1197,83723 StkErr1198,83763 ArgErr1199,83795 NumErr1200,83825 CntErr1201,83858 SymErr1202,83897 ExtErr1203,83930 PairErr1204,83972 AtomErr1205,84009 LstErr1206,84041 VarErr1207,84072 DivErr1208,84107 RenErr1209,84130 MakeErr1210,84160 ReentErr1211,84189 YieldErr1212,84228 MsgErr1213,84260 BrkErr1214,84289 OpenErr1215,84315 CloseErr1216,84348 PipeErr1217,84383 ForkErr1218,84416 WaitPidErr1219,84445 BadFdErr1220,84475 NoFdErr1221,84501 EofErr1222,84533 SuparErr1223,84562 BadInput1224,84608 BadDot1225,84642 SelectErr1226,84675 WrBytesErr1227,84712 WrChildErr1228,84749 WrSyncErr1229,84786 WrJnlErr1230,84821 WrLogErr1231,84858 TruncErr1232,84891 DbSyncErr1233,84933 TrSyncErr1234,84972 LockErr1235,85020 DbfErr1236,85052 JnlErr1237,85081 IdErr1238,85110 DbRdErr1239,85133 DbWrErr1240,85163 DbSizErr1241,85194 TellErr1242,85225 IpSocketErr1243,85257 IpGetsocknameErr1244,85299 IpV6onlyErr1245,85351 IpReuseaddrErr1246,85398 IpBindErr1247,85449 IpListenErr1248,85487 UdpOvflErr1249,85529 UndefErr1250,85563 DlErr1251,85592 ./main.l,2261 Code4,51 Ret8,106 Retc10,127 Retnc13,157 Retz16,188 Retnz19,218 RetNil22,249 RetT25,285 RetE_E28,320 main33,402 restart157,4141 loadAllX_E165,4303 giveupX183,4711 execErrS190,4824 iSignalCE195,4924 allocC_A205,5207 allocAE_A210,5316 NoMemory214,5430 heapAlloc220,5509 sighandler0241,6013 sighandlerX248,6090 sighandlerE255,6167 sig348,9499 sigTerm360,9723 sigChld371,9941 tcSetC392,10449 sigTermStop405,10716 setRaw421,11209 setCooked447,12008 doRaw455,12175 doAlarm477,12578 doSigio493,12862 doProtect513,13329 doHeap523,13489 doStack552,14113 doAdr597,15214 doEnv609,15432 doTrail708,18142 doUp776,19740 doSys856,21455 circE_YF884,22114 equalAE_F916,22854 compareAE_F1049,26063 binSizeX_A1211,29539 memberXY_FY1306,32149 doQuit1324,32500 evExprCE_E1342,32917 evListE_E1490,36551 sharedLibC_FA1543,37687 doErrno1614,39331 doNative1622,39495 natBufACZ_CZ1826,45300 natRetACE_CE1925,47785 doStruct2074,53185 fetchCharC_AC2117,54065 cbl2152,54934 cbl12185,55651 cbl22189,55767 cbl32193,55813 cbl42197,55865 cbl52201,55917 cbl62205,55969 cbl72209,56021 cbl82213,56073 cbl92217,56125 cbl102221,56177 cbl112225,56230 cbl122229,56284 cbl132233,56338 cbl142237,56392 cbl152241,56446 cbl162245,56500 cbl172249,56554 cbl182253,56608 cbl192257,56662 cbl202261,56716 cbl212265,56770 cbl222269,56824 cbl232273,56878 cbl242277,56932 doLisp2283,57015 lisp2327,58041 execE2373,59156 runE_E2385,59311 funqE_FE2397,59463 evSymX_E2459,60886 evSymY_E2462,60944 evSymE_E2464,60986 xSymE_E2466,61023 evCntXY_FE2487,61388 evCntEX_FE2489,61432 xCntEX_FE2491,61471 xCntCX_FC2500,61648 xCntAX_FA2509,61825 boxE_E2518,62002 putStringB2538,62459 begString2550,62673 endString_E2561,62899 msec_A2576,63247 doArgs2590,63556 doNext2597,63670 doArg2614,63986 doRest2643,64628 tmDateC_E2657,64875 dateXYZ_E2667,65052 doDate2728,66413 tmTimeY_E2844,70024 doTime2861,70357 doUsec2965,73335 doPwd2983,73752 doCd2994,74007 doCtty3019,74623 doInfo3056,75564 doFile3110,76822 doDir3163,78058 doCmd3233,79676 doArgv3251,80135 doOpt3354,82681 doVersion3368,83012 ./big.l,1078 zapZeroA_A6,106 twiceA_A47,1164 twiceBigA_A57,1393 halfA_A87,2066 tenfoldA_A157,3756 shluA_A201,4864 shruA_A247,5895 anduAE_A325,7804 oruAE_A394,9408 xoruAE_A465,11070 adduAE_A540,12941 subuAE_A682,16763 muluAE_A859,21543 divuAE_A1045,26266 divDone1255,31620 divUnder1261,31672 remuAE_A1266,31804 remDone1479,37197 remUnder1485,37249 incE_A1491,37390 decE_A1504,37650 addAE_A1517,37895 subAE_A1542,38407 cmpNumAE_F1567,38908 cmpuAE_F1587,39290 symToNumXA_FE1681,41108 fmtNum0AE_E1794,43990 fmtNumAE_E1797,44089 fmtWordACX_CX2046,51011 fmtScaleCX_CX2061,51371 doFormat2089,52049 doAdd2171,53693 doSub2209,54427 doInc2256,55443 doDec2323,57032 doMul2389,58600 doMulDiv2446,59818 doDiv2513,61363 doRem2572,62620 doShift2627,63761 doLt02682,65020 doLe02693,65221 doGe02707,65473 doGt02718,65675 doAbs2731,65908 doBitQ2748,66194 doBitAnd2807,67355 doBitOr2847,68167 doBitXor2887,68977 doSqrt2927,69800 initSeedE_E3058,73224 doSeed3092,73880 doHash3107,74222 doRand3134,74825 ./io.l,2983 closeAX5,75 unLockFileAC15,253 wrLockFileC23,487 rdLockFileC26,565 lockFileAC28,624 closeOnExecAX43,1010 nonblockingA_A51,1179 initInFileA_A63,1446 initInFileAC_A65,1494 initInFileCA_A67,1523 initOutFileA_A106,2476 closeInFileA142,3345 closeOutFileA164,3832 waitFileC185,4302 slowZ_F204,4702 slowNbC_FA226,5169 rdBytesCEX_F266,6117 rdBytesNbCEX_F287,6581 wrBytesCEX_F336,7875 clsChildY366,8675 wrChildCXY377,8927 flushA_F416,10032 flushAll436,10442 stdinByte_A450,10753 getBinaryZ_FB472,11109 byteNumBCX_CX488,11479 binReadZ_FE559,13489 prByteCEXY723,17795 prCntCE746,18321 prTellEZ765,18688 prE771,18843 binPrintEZ773,18912 putTellBZ1039,26668 tellBegZ_Z1047,26858 tellEndAZ1054,27010 unsync1101,28117 rdHear_FE1118,28538 symByteCX_FACX1131,28884 symCharCX_FACX1152,29323 bufStringE_SZ1185,30275 pathStringE_SZ1215,30929 doPath1288,32882 charSymACX_CX1300,33152 byteSymBCX_CX1335,34076 currFdX_C1377,35192 currFd_C1381,35304 rdOpenEXY1398,35677 wrOpenEXY1539,40083 erOpenEXY1672,44258 ctOpenEXY1714,45277 getStdin_A1768,46691 getParse_A1839,48531 pushInFilesY1862,49001 pushOutFilesY1886,49541 pushErrFilesY1897,49836 pushCtlFilesY1902,49940 popInFiles1907,50044 popOutFiles1944,50928 popErrFiles1970,51616 popCtlFiles1977,51819 getChar_A1991,52210 skipC_A2023,53081 comment_A2049,53596 skip_A2076,54114 testEscA_F2094,54458 anonymousX_FE2128,55211 rdAtomBY_E2161,56074 rdList_E2213,57501 readC_E2347,60929 readA_E2359,61166 tokenCE_E2542,65469 doRead2688,69006 inReadyC_F2726,69846 fdSetCL_X2738,70127 fdRdSetCZL2750,70361 fdWrSetCZL2757,70503 rdSetCL_F2764,70652 wrSetCL_F2769,70768 rdSetRdyCL_F2774,70891 waitFdCEX_A2796,71352 doWait3200,84803 doSync3238,85526 doHear3278,86466 doTell3310,87160 fdSetC_Y3359,88248 doPoll3370,88482 doKey3426,89853 doPeek3481,91292 doChar3497,91570 doSkip3551,92515 doEol3565,92862 doEof3574,93028 doFrom3593,93385 doTill3660,95054 eolA_F3734,97003 doLine3749,97307 doLines3902,101347 parseBCE_E3943,102248 doAny4015,103903 doSym4055,104841 doStr4069,105100 loadBEX_E4122,106226 doLoad4232,108949 doIn4255,109361 doOut4275,109691 doErr4295,110025 doCtl4315,110360 doPipe4336,110715 doOpen4399,112261 doClose4442,113241 doEcho4473,113832 putStdoutB4686,119356 newline4729,120338 space4733,120380 outNumE4738,120444 outWordA4745,120572 prExtNmX4757,120810 outOctA4765,121004 outAoA4778,121272 outStringS4790,121520 outStringC4792,121590 outNameE4802,121729 prNameX4810,121846 printE_E4820,122001 printE4829,122137 prinE_E5048,127950 prinE5057,128086 doPrin5112,129348 doPrinl5126,129618 doSpace5130,129686 doPrint5152,130085 doPrintsp5168,130380 doPrintln5183,130669 doFlush5188,130757 doRewind5196,130894 doExt5213,131284 doRd5230,131623 doPr5299,133492 doWr5316,133824 ./apply.l,445 applyXYZ_E4,51 applyVarXYZ_E358,10999 doApply713,22033 doPass754,22785 doMaps790,23436 doMap849,24621 doMapc891,25446 doMaplist933,26278 doMapcar987,27437 doMapcon1041,28598 doMapcan1101,29913 doFilter1161,31231 doExtract1218,32508 doSeek1275,33750 doFind1322,34688 doPick1369,35638 doCnt1413,36511 doSum1460,37455 doMaxi1511,38512 doMini1562,39596 doFish1613,40678 fishAXY1640,41196 doBy1669,41750 ./err.l,1928 dbgS5,73 errnoEXY24,572 errEXYZ33,734 unwindC_Z176,4453 needSymAX352,9449 needSymEX364,9648 needVarAX375,9837 needVarEX385,10014 checkVarAX394,10181 checkVarYX402,10317 checkVarEX410,10453 protErrEX415,10561 symNsErrEX419,10611 stkErr424,10686 stkErrE426,10711 stkErrX428,10737 stkErrEX430,10763 argErrAX435,10851 argErrEX437,10878 numErrAX441,10926 numErrEX443,10953 cntErrAX447,11001 cntErrCX449,11028 cntErrEX451,11055 symErrAX455,11103 symErrYX457,11130 symErrEX459,11157 extErrEX463,11205 pairErrAX467,11253 pairErrEX469,11281 atomErrAX473,11331 atomErrEX475,11359 lstErrAX479,11409 lstErrEX481,11436 varErrAX485,11484 varErrEX487,11511 divErrX491,11559 renErrEX496,11616 makeErrX500,11664 reentErrEX505,11723 yieldErrX509,11775 yieldErrEX511,11803 msgErrYX515,11855 msgErrAX517,11882 msgErrEX519,11909 brkErrX523,11957 openErrEX529,12027 closeErrX533,12078 closeErrEX535,12106 pipeErrX539,12159 forkErrX544,12219 waitPidErrX549,12278 badFdErrEX554,12344 noFdErrX558,12396 eofErr563,12455 suparErrE569,12521 badInputErrB574,12582 badDotErrE582,12673 selectErrX587,12733 wrBytesErr592,12797 wrChildErr598,12872 wrSyncErrX604,12947 wrJnlErr609,13011 wrLogErr615,13082 truncErrX621,13153 dbSyncErrX626,13215 trSyncErrX631,13279 lockErr636,13343 dbfErrX642,13412 jnlErrX647,13469 idErrXL652,13526 dbRdErr657,13600 dbWrErr663,13669 dbSizErr669,13738 tellErr675,13808 ipSocketErrX681,13876 ipGetsocknameErrX686,13944 ipV6onlyErrX691,14022 ipReuseaddrErrX696,14090 ipBindErrX701,14164 ipListenErrX706,14228 udpOvflErr711,14296 undefinedCE718,14395 undefinedCX720,14425 undefinedEX722,14455 dlErrX726,14508 ret734,14654 retc736,14675 retnc739,14705 retz742,14736 retnz745,14766 retNull748,14797 retNil751,14832 retT754,14868 retE_E757,14903 ./sym.l,1795 cmpLongAX_F5,78 isInternEXY_F37,682 internEXY_FE75,1602 findSymX_E257,6713 externX_E266,6898 uninternEXY356,9588 nameA_A469,12681 nameE_E477,12824 nameX_X485,12967 nameY_Y493,13110 doName502,13282 mkCharA_A573,14812 mkStrE_E623,16250 mkStrEZ_A650,16718 firstByteA_B673,17133 firstCharE_A688,17398 isBlankE_F704,17688 doSpQ727,18092 doPatQ736,18254 doFunQ750,18528 doGetd758,18689 doAll788,19388 consTreeXE_E832,20452 balanceXY892,21928 balanceCEY910,22261 doSymbols942,23062 doIntern1007,24783 doExtern1032,25198 doHide1099,26722 doBoxQ1131,27292 doStrQ1145,27553 doExtQ1166,27964 doTouch1181,28252 doZap1195,28502 doChop1228,29153 doPack1279,30512 packECX_CX1312,31077 doGlue1369,32380 doText1407,33146 preCEXY_F1479,35019 subStrAE_F1494,35349 doPreQ1545,36498 doSubQ1578,37119 doVal1597,37470 doSet1616,37817 doSetq1649,38449 doSwap1672,38849 doXchg1699,39320 doOn1744,40253 doOff1759,40512 doOnOff1774,40774 doZero1792,41122 doOne1807,41381 doDefault1822,41648 doPush1849,42154 doPush11885,42815 doPop1934,43745 doCut1958,44208 doDel2013,45436 doQueue2081,47021 doFifo2123,47773 doIdx2197,49373 idxGetXY_E2240,50250 idxPutXY_E2257,50596 idxDelXY_E2327,52632 doLup2386,54152 putACE2526,58454 getnECX_E2669,62452 getEC_E2710,63361 propEC_E2780,65190 doPut2870,67639 doGet2931,68873 doProp2962,69443 doSemicol3012,70424 doSetCol3041,70951 doCol3095,72094 doPropCol3119,72528 doPutl3162,73425 doGetl3244,75126 doWipe3302,76234 wipeE3324,76668 doMeta3347,77175 metaCX_E3389,77951 caseDataA_AC3415,78550 doLowQ3427,78853 doUppQ3442,79212 doLowc3457,79565 doUppc3509,81073 doFold3561,82588 isLetterOrDigitA_F3629,84621 ./db.l,1153 getAdrZ_A6,117 setAdrAZ22,350 setAdrAS36,545 dbfBuf_AF51,839 extNmCE_X64,1122 packExtNmX_E87,1655 packAoACX_CX108,2112 packOctACX_CX120,2392 chopExtNmX_E133,2698 oct3C_CA180,3817 fileObjX_AC211,4528 fileObjE_AC237,5186 dbFileBlkY_AC246,5356 rdLockDb255,5505 wrLockDb262,5711 rwUnlockDbA269,5918 tryLockCE_FA299,6718 jnlFileno_A344,8025 logFileno_A348,8085 lockJnl352,8145 unLockJnl357,8253 setBlockAC_Z364,8453 setBlkAC_Z366,8510 rdBlockLinkZ_Z375,8724 rdBlockIndexAZ_Z377,8779 rdBlockZ_Z380,8881 blkPeekCEZ392,9224 wrBlockZ398,9361 blkPokeCEZ403,9530 logBlock432,10490 newBlock_X449,11012 newIdEX_X492,12181 isLifeE_F525,13028 cleanUpY570,14123 getBlockZ_FB596,14825 putBlockBZ612,15133 doPool651,16232 ignLog924,25817 rewindLog928,25871 fsyncDB932,25955 truncLog947,26297 bufAoAC_C956,26502 doJournal971,26814 doId1028,28419 doSeq1084,29745 doLieu1157,31621 doLock1185,32219 dbFetchEX1224,33169 dbAEX1236,33396 dbTouchEX1350,36703 dbZapE1382,37291 doCommit1403,37726 doRollback1803,50573 doMark1880,52468 doFree1962,54514 doDbck2020,55980 ./gc.l,842 markE5,63 needC54,1336 gc65,1529 doGc450,11776 cons_A482,12474 cons_C494,12738 cons_E506,13002 cons_X518,13266 cons_Y530,13530 cons_Z542,13794 consA_A554,14058 consC_A570,14381 consE_A586,14690 consX_A602,14999 consA_C618,15308 consC_C634,15617 consE_C650,15940 consA_E666,16249 consC_E682,16558 consE_E698,16867 consX_E714,17190 consA_X730,17499 consE_X746,17808 consY_X762,18117 consA_Y778,18426 consA_Z794,18735 consAC_E810,19044 consSymX_E828,19397 boxNum_A848,19847 boxNum_C860,20132 boxNum_E872,20417 boxNum_X884,20702 boxNumA_A896,20987 boxNumE_E910,21316 consNumAC_A924,21645 consNumAE_A942,22021 consNumCA_C960,22397 consNumCE_A978,22773 consNumCE_C995,23140 consNumCE_E1013,23516 consNumEA_A1030,23866 consNumEA_E1047,24216 consNumEC_E1065,24592 ./flow.l,1630 redefMsgEC4,51 putSrcEC_E25,589 redefineCE109,3406 doQuote134,3997 doAs139,4084 doLit150,4297 doEval175,4821 doRun306,8448 doDef448,12312 doDe534,14412 doDm547,14693 evMethodACEXYZ_E647,17004 methodEY_FCYZ797,20981 doBox830,21828 doNew841,22048 doType922,23958 doIsa969,25126 isaCE_F1020,26178 doMethod1061,27283 doMeth1097,27888 doSend1136,28596 doTry1179,29371 doSuper1227,30210 doExtra1271,31140 extraXY_FCYZ1298,31683 doWith1334,32562 doBind1364,33243 doJob1431,34748 doLet1481,35965 doLetQ1542,37339 doUse1575,38053 doAnd1626,39172 doOr1642,39437 doNand1661,39744 doNor1682,40107 doXor1703,40473 doBool1726,40880 doNot1734,41015 doNil1744,41173 doT1753,41312 doProg1762,41453 doProg11770,41576 doProg21787,41859 doIf1807,42189 doIf21826,42544 doIfn1867,43401 doWhen1886,43726 doUnless1903,44011 doCond1921,44350 doNond1944,44770 doCase1967,45186 doCasq2011,46150 doState2051,47025 doWhile2103,48065 doUntil2127,48457 doAt2151,48853 doDo2183,49455 doLoop2215,50113 loopX2220,50184 doFor2272,51758 loopY_FE2459,57012 doCatch2509,58385 caught2525,58721 doThrow2535,58878 throwErrZX2560,59431 doFinally2566,59522 doCo2590,60062 resumeCoroutine2619,60974 doYield2795,67049 closeCoFilesC2949,71392 doBreak2963,71655 brkLoadE_E2971,71807 doE3026,73407 doTrace3065,74173 traceCY3137,76088 doCall3165,76576 doTick3252,78768 doIpid3284,79765 doOpid3300,80053 doKill3316,80348 doFork3339,80783 forkLispX_FE3352,81004 doBye3513,85564 byeE3525,85736 finishE3537,86047 ./subr.l,2147 doCar5,71 doCdr17,247 doCaar31,439 doCadr45,662 doCdar62,921 doCddr79,1180 doCaaar99,1475 doCaadr116,1765 doCadar136,2091 doCaddr156,2417 doCdaar179,2779 doCdadr199,3105 doCddar222,3467 doCdddr245,3829 doCaaaar271,4227 doCaaadr288,4518 doCaadar311,4911 doCaaddr334,5304 doCadaar360,5733 doCadadr383,6126 doCaddar409,6555 doCadddr435,6984 doCdaaar464,7449 doCdaadr487,7842 doCdadar513,8271 doCdaddr539,8700 doCddaar568,9165 doCddadr594,9594 doCdddar623,10059 doCddddr652,10524 doNth685,11053 doCon725,11768 doCons747,12119 doConc781,12790 doCirc817,13429 doRot849,14016 doList888,14758 doNeed920,15352 doRange998,17035 doFull1076,18687 doMake1089,18954 doMade1108,19331 doChain1142,20014 doLink1173,20604 doYoke1197,21063 doCopy1226,21613 doMix1261,22347 doAppend1339,24163 doDelete1402,25685 doDelq1453,26846 doReplace1500,27918 doStrip1577,29833 doSplit1593,30150 doReverse1679,32395 doFlip1700,32759 doTrim1760,34230 trimE_E1770,34369 doClip1800,35025 doHead1821,35375 doTail1912,37626 doStem1990,39465 doFin2034,40382 doLast2045,40565 doEq2060,40837 doNEq2088,41303 doEqual2116,41768 doNEqual2145,42275 doEq02174,42784 doEqT2182,42918 doNEq02190,43049 doNEqT2199,43194 doLt2208,43338 doLe2238,43910 doGt2268,44481 doGe2298,45053 doMax2328,45626 doMin2357,46167 doAtom2386,46704 doPair2395,46848 doCircQ2403,46983 doLstQ2416,47199 doNumQ2427,47388 doSymQ2435,47521 doFlgQ2446,47707 doMember2456,47888 doMemq2478,48241 doMmeq2506,48769 doSect2542,49511 doDiff2590,50551 doIndex2638,51597 doOffset2678,52351 doPrior2714,52994 doLength2742,53469 doSize2809,54974 sizeCE_C2929,58837 doBytes2973,59840 doAssoc2986,60061 doAsoq3021,60719 doRank3049,61237 doMatch3141,63526 matchCE_F3160,63852 doFill3256,66687 fillE_FE3274,66981 unifyCEYZ_F3377,69250 doProve3543,73614 lupCE_E3808,81284 lookupCE_E3865,82675 uniFillE_E3879,82928 doArrow3909,83561 doUnify3931,83971 doSort3958,84459 cmpDfltA_F4113,89640 cmpUserAX_F4118,89791 ./net.l,192 doPort5,96 tcpAcceptA_FE109,2796 doAccept148,4180 doListen160,4416 doHost193,5089 doConnect227,5972 serverCEY_FE276,7176 doUdp304,7940 getUdpZ_FB373,9872 putUdpBZ380,10017 sys/x86-64.freeBsd.code.l,94 errno_A5,64 errnoC10,158 wifstoppedS_F21,537 wifsignaledS_F27,688 wtermsigS_A36,897 picolisp-3.1.5.2.orig/src64/version.l0000644000000000000000000000013412265263724015751 0ustar rootroot# 04jan14abu # (c) Software Lab. Alexander Burger (de *Version 3 1 5 2) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/img/0000755000000000000000000000000012265263724013724 5ustar rootrootpicolisp-3.1.5.2.orig/img/7fach.eps0000644000000000000000000002160312265263724015427 0ustar rootroot%!PS-Adobe-3.0 EPSF-3.0 %%For: Josef Bartl %%CreationDate: Tue Feb 18 11:34:19 2003 %%Creator: Sketch 0.6.7 %%Pages: 1 %%BoundingBox: 35 63 232 148 %%Extensions: CMYK %%DocumentSuppliedResources: (atend) %%DocumentNeededResources: font NewCenturySchlbk-Italic %%EndComments %%BeginProlog %%BeginResource: procset Linux-Sketch-Procset 1.0 2 /SketchDict 100 dict def SketchDict begin /bd { bind def } bind def /x { exch } bd /xd { exch def } bd /PI 3.14159265358979323846264338327 def /radgrad { 180 mul PI div } bd /skstartmatrix matrix currentmatrix def /tmpmat matrix def /ISOLatin1Encoding dup where { pop pop } { [/.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /space /exclam /quotedbl /numbersign /dollar /percent /ampersand /quoteright /parenleft /parenright /asterisk /plus /comma /minus /period /slash /zero /one /two /three /four /five /six /seven /eight /nine /colon /semicolon /less /equal /greater /question /at /A /B /C /D /E /F /G /H /I /J /K /L /M /N /O /P /Q /R /S /T /U /V /W /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore /quoteleft /a /b /c /d /e /f /g /h /i /j /k /l /m /n /o /p /q /r /s /t /u /v /w /x /y /z /braceleft /bar /braceright /asciitilde /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /.notdef /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent /dieresis /.notdef /ring /cedilla /.notdef /hungarumlaut /ogonek /caron /space /exclamdown /cent /sterling /currency /yen /brokenbar /section /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen /registered /macron /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph /periodcentered /cedilla /onesuperior /ordmasculine /guillemotright /onequarter /onehalf /threequarters /questiondown /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex /Idieresis /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn /germandbls /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex /idieresis /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn /ydieresis] def } ifelse /arct dup where {pop pop} { /arct {arcto pop pop pop pop} bd } ifelse /size 0 def /fontname 0 def /newfont 0 def /sf { /size xd /fontname xd fontname findfont dup /Encoding get StandardEncoding eq { dup length dict /newfont xd { 1 index /FID ne { newfont 3 1 roll put } { pop pop } ifelse } forall newfont /Encoding ISOLatin1Encoding put fontname newfont definefont } if size scalefont setfont } bd /pusht {matrix currentmatrix} bd /popt {setmatrix} bd /pushc {gsave} bd /popc {grestore} bd /rgb {setrgbcolor} bd /w { setlinewidth } bd /j { setlinejoin } bd /J { setlinecap } bd /d { setdash } bd /F { eofill } bd /f { closepath F } bd /S { pusht skstartmatrix setmatrix stroke popt } bd /s { closepath S } bd /m { moveto } bd /l { lineto } bd /c { curveto } bd /txt { /tmpmat tmpmat currentmatrix def dup type /arraytype eq {concat} {translate} ifelse 0 0 m tmpmat } bd /T {txt x show popt} bd /P {txt x true charpath popt} bd /TP {txt x dup show 0 0 m true charpath popt} bd /C {newpath 0 360 arc} bd /R { 2 copy m x 2 index l x 2 index x l l closepath } bd /ellipse { dup type /arraytype eq { pusht x concat 0 0 1.0 C popt } { pusht 5 1 roll 4 -1 roll concat newpath dup 2 eq { 0 0 m } if 3 1 roll radgrad x radgrad x 0 0 1 5 -2 roll arc 0 ne { closepath } if popt } ifelse } bd /radius1 0 def /radius2 0 def /factor 0 def /rect { dup type /arraytype eq { pusht x concat 0 0 m 1 0 l 1 1 l 0 1 l closepath popt } { /radius2 xd /radius1 xd pusht x concat radius1 radius2 div 1 scale 0 radius2 m 0 1 radius2 1 radius2 arct radius2 radius1 div dup 1 1 index 0 radius2 arct 0 0 0 radius2 arct 0 0 0 1 radius2 arct closepath popt } ifelse } bd /buf 0 def /width 0 def /height 0 def /skcimg { /tmpmat tmpmat currentmatrix def { concat } if /height xd /width xd /buf width 3 mul string def width height scale width height 8 [width 0 0 height neg 0 height] { currentfile buf readhexstring pop } bind false 3 colorimage tmpmat setmatrix } bd /skgimg { /tmpmat tmpmat currentmatrix def { concat } if /height xd /width xd /buf width string def width height scale width height 8 [width 0 0 height neg 0 height] { currentfile buf readhexstring pop } bind image tmpmat setmatrix } bd /rclip { 4 2 roll m dup 0 x rlineto x 0 rlineto neg 0 x rlineto closepath clip } bd /skeps { 10 dict begin /sk_state save def concat 3 index neg 3 index neg translate rclip 0 setgray 0 setlinecap 1 setlinewidth 0 setlinejoin 10 setmiterlimit [ ] 0 setdash newpath /sk_dict_count countdictstack def /sk_count count 1 sub def userdict begin /showpage { } def /languagelevel where { pop languagelevel 1 ne { false setstrokeadjust false setoverprint } if } if } bd /skepsend { count sk_count sub { pop } repeat countdictstack sk_dict_count sub { end } repeat sk_state restore end } bd /gradidx 0 def /gradient { 3 mul array /gradidx 0 def } bd /$ { 3 index gradidx 5 -1 roll put 2 index gradidx 1 add 4 -1 roll put 1 index gradidx 2 add 3 -1 roll put /gradidx gradidx 3 add def } bd /! { 3 { dup dup gradidx dup 3 1 roll 3 sub get put /gradidx gradidx 1 add def } repeat } bd /gradcolor { 3 mul dup 2 add 1 exch % idx 1 idx+2 { 1 index exch % array array i get % array component exch % component array } for 4 1 roll } bd /x0 0 def /y0 0 def /x1 0 def /y1 0 def /left 0 def /right 0 def /top 0 def /bottom 0 def /numcolors 0 def /axial { /y1 xd /x1 xd /y0 xd /x0 xd dup length 3 idiv /numcolors xd pusht exch % ctm array x0 x1 ne y0 y1 ne or { x0 y0 translate [x1 x0 sub y1 y0 sub dup neg 2 index 0 0] concat clippath flattenpath pathbbox /top xd /right xd /bottom xd /left xd newpath 0 gradcolor rgb clippath f 0 1 numcolors 1 sub { dup numcolors div 3 1 roll gradcolor rgb exch bottom right top R f } for } if pop popt } bd /r0 0 def /r1 0 def /dr 0 def /radial { /r1 xd /r0 xd /y0 xd /x0 xd /dr r1 r0 sub def dup length 3 idiv /numcolors xd pusht exch % ctm array r0 r1 ne { x0 y0 translate clippath flattenpath pathbbox /top xd /right xd /bottom xd /left xd newpath dr 0 gt {numcolors 1 sub}{0} ifelse gradcolor rgb clippath f dr 0 gt {numcolors 1 sub -1 0} { 0 1 numcolors 1 sub} ifelse { dup numcolors div dr mul r0 add 3 1 roll gradcolor rgb exch 0 0 3 -1 roll C f } for } if pop popt } bd /max { 2 copy lt {exch} if pop } bd /conical { pusht 5 1 roll 3 1 roll /y0 xd /x0 xd x0 y0 translate radgrad rotate dup length 3 idiv /numcolors xd clippath flattenpath pathbbox newpath 4 { abs 4 1 roll} repeat 3 { max } repeat 2 mul dup scale 0 gradcolor rgb 0 0 1 0 360 arc f 1 1 numcolors 1 sub { dup numcolors div 180 mul 3 1 roll gradcolor rgb exch 0 0 moveto 0 0 1 4 -1 roll dup neg arc closepath f } for pop popt } bd /XStep 0 def /YStep 0 def /imagedata 0 def /components 0 def /tileimage2 { exch 4 2 roll /height xd /width xd mark /components 2 index /PatternType 1 /PaintType 1 /TilingType 1 /BBox [0 0 width height] /XStep width /YStep height /PaintProc { begin XStep YStep 8 matrix imagedata false components colorimage end } counttomark 2 div cvi dup dict begin { def } repeat pop currentdict end dup /imagedata 4 -1 roll width height mul mul string currentfile exch readhexstring pop put exch makepattern setpattern clippath eofill } bd /tileimage1 { concat /components xd /height xd /width xd /imagedata currentfile width height mul components mul string readhexstring pop def clippath flattenpath pathbbox /top xd /right xd /bottom xd /left xd left width div floor width mul bottom height div floor height mul translate top bottom sub height div ceiling cvi { gsave right left sub width div ceiling cvi { width height 8 matrix components 1 eq { { imagedata } image } { imagedata false components colorimage } ifelse width 0 translate } repeat grestore 0 height translate } repeat } bd /makepattern where { pop /tileimage /tileimage2 load def } { /tileimage /tileimage1 load def } ifelse end %%EndResource %%EndProlog %%BeginSetup %%IncludeResource: font NewCenturySchlbk-Italic 10.433 setmiterlimit %%EndSetup %%Page: 1 1 SketchDict begin /NewCenturySchlbk-Italic 72 sf (7) [1 0.0774195 0 1 38.5322 74.5729] 0 0.475 0 rgb T (f) [1 0.0774195 0 1 82.704 81.2248] 0.354 0.335 0.676 rgb T (a) [1 0.0774195 0 1 111.793 83.4768] 0.667 0 0 rgb T (c) [1 0.0774195 0 1 154.887 86.8132] 0.747 0.609 0.241 rgb T (h) [1 0.0774195 0 1 189.363 89.4823] 0.001 0 0.67 rgb T %%PageTrailer %%Trailer end %%DocumentSuppliedResources: procset Linux-Sketch-Procset 1.0 2 %%EOF picolisp-3.1.5.2.orig/img/7fach.gif0000644000000000000000000001510212265263724015402 0ustar rootrootGIF89an/msz }  ""&&**++44<F@KFNIOJRMVQYT]Y_Za]eakfmirnvryt~zEEHHTTVV]]eemmss|| $$))--22::<CâJǦSǨVȨVɫ[̯cϵnеoѷsҸvӺzōƏȄ֍ڑɖ˝ϖݟОߡФҪխױٶ۸ݼޤ⬬䳳濽༼ÎƓȕ̟ϣХӫֱشݽքڎܔݙ־ࢢ䫫岲縸鼼Ëǒɖ̜Οѥԫײٵݼ!!4 Image generated by GNU Ghostscript (device=pnmraw) ,n/9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3Μ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3_9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3_0@ gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s@gΜ9s̙3gΜ9s̙3gΜ9s(@ 3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9CO  (̙3gΜ9s̙3gΜ9s̙3gΜ9s3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9sA%9s 3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9sԛQ̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9{@9Μ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙e~СN (s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3g(P3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9sЙ3gΜ9s̙_"Y, 8s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3g( x̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3g9s̙3gΜ9sLʜAC8Μ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9sقV8S̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3g΄"hЎ-s̙3gΜ٩`3g:P3gΜ9s̙3gΜ9̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9sf@9s̙3gΜ9s̙3gΜ9s̙44pذa -X@XΜ9s̙3g6\̙3g̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ!P 2gΜ9s̙3gΜ9s̙3gΜ9s6K@@ Ù3gΜ9sY 8s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3g $™3gT!G3gΜ9s̙3gΜ9`@,̙3gΜ9s 9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙fF:̙3gΜ9s+q0̙3gΜ9s̙3g\  :v"9s̙3gΜp2gΜ9s̙3gΜ9k̙3gΚ9s̙3gΜ9s̙3gΜ9; -ZA̙3gΜ9sF@9 q̙3gΜ9s̙tZ̙3g:s(@gΜ9s̙3gXƙ3gΜ9s̙3gΜ9s,W1gΜ9s,fΜ9s̙3g>u"&]q̙3gΜ9;A` Q,R8s̙3gΜ9s Μ9s̙3g΄@˙3gΜ9[̙,\r̙3gΜ9sY3g"$ %gΠę3gΜ9s&,Y89s10Yv9s̙3g f_Μ9Μ9s̙3gΜ!Ù3gΜ9s̙9s̙3gΜ9sv |NǗ3gΜ9sL $fB~x䬙3gΜ9s)MΜ5s˖,9s̙@ x3gΜ:PgΜ9s̙3gf̙3gΜ9s,Q˜9s̙3eo@Ѐ "D̙3gΜ5kG)pQ"R Ap9s̙3g:a"3gΐy%(gΜ9sl r̙3g} (`ʙ3gΜ9s#=-s̙3gΜ `3gΜ9sl 0`>Z9s̙3gN~bə3gj )gΜ9s-[r̙f_d̙3Μ9s栀m)s̙3 (P̙3gΜ9sL"aΜ9s̙3gv̙3gΜ9s0`0X̙3gΜ9sY@LrY3gΒc3gΜ9š,g9s̙3]dr̙3g\(P2gΜ9s,A*9s̙3gΜ9s̙3gΜ9s̙b9s̙3gΜ9s X9S̙3gΜ9(Κ9s̙&?䬙3gΜڲe.gΜ9s̙3gΜ9s̙39 ̙3gΜ)P@ gΜ9s̙3gΜ9s@gΜ9s&,Μ9s̙3gΜ9sʜ9s̙3g͜ADH.gΜ9sْ@0s̙3g4ef3gΜ9s̙3gΜ9s (s̙3gN(@3gΜ9s̙3gΜ9s̙3gΜ"3gΜ9s̙3gΜ`a3gΜ9s̙\B⬙3gΜ9cVȏ&Μ9s̙30[dr̙3gΜ9s̙3gΜ9@6Μ9sp̙3gΜ9s̙3gΜ9s̙3Dr̙3gΜ9s̙3g0X̙3gΜ9k @r̙3gΜ$g͜9sW-X@9s̙3gΜ9s̙3gΜ!P@*gΜ9sL9s*gΜ9s̙3gΜ9s挖19s̙3gΜ9sY 0r̙3gΜ9s$Μ9s̙3g ˙3gΜ9۵e]Μ9s̙3gΜ9s̙3g) p̙3gΜ9;A@eΜ*™3gΜ9s̙3gΜ9 !gΜ9s̙3gΜ9sVʜ9s̙3gΘ C3gΜ9sٓ?8s̙3gvmٲe3gΜ9sЙ3g͜9s̙p̙3gΔ-(@3g ̙3gΜ9s̙3gC3gΜ9s̙3gΜ9cgΜ9s̙3g!Y3gΜ9s6T9kf3glٲ˙3gΜ9sLטcΖ9s@9s̙W Y ~9s̙3gΜ9sY0p̙3gΜ9s̙3g@\Ǚ3gΜ9sY% @Xr̙3gΜ=H-gjٱ.\r̙3gΜ3gΜ!P2gΜ9s U^9SA`3gΜ9̙3gΜ9slGf9s̙3gΜ9s̙V0`X嬙3gΜ9s Aj9s̙3g͐Q3gK0s٘-Z8s̙3gl̙3gF `™3gΜ9s@'X̙3gΜ9s̙3g˜1 @gΜ9s̙3gΜ9s挏 9s̙3gΚ9ZΜ9s٣@~alҏIΚ9s6*˖-9sӖ-9s̙/q̙3gΜ93Aw9s̙3gΜ9s̙3g4`2gΜ9s̙3gΜ9cgΜt̙3gΜ #g͜5s+ ?8ĉ3gΜ9s)K,cМbE /gΜ9s̎\9s̙3gΜk0gΜ9s̙3gΜ9s̙̙3gΜ9s̙3gΔuPa3gΜ9s̙3gΘRd3gj y"̙3gΜ9 %f +Ytb̙3gΜ9 2gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9K#89s̙3gΜ9s̙U0dh̙3gΜ9s欙ZA~!2ʒIM#9s̙3g:cK.b̜9[̙3gΜ9s̙3gΜ9s̙3gΜ)s̙3gΜ9s̙3gΜ @@BΜ9s̙3gΜ9sY @8s̙3gΜ9s̙ID~fΔE!r3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙e3 3gΜ9s̙3gΜ9Sႅ:Μ9s̙3gΜ9s0HQ<̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3g9s̙3gΜ9s̙3gΜ9s̙3gΜ*gΜ9s̙3gΜ9s̙3gΜ9k̙eΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9sv(v8[̙3gΜ9s̙3gq,``̙3gΜ9s̙3gΜ9[̙fΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3g˜1 YΜ9s̙3gΜ9sL,q̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜx1#3gΜ9s̙3gΜ9svB |9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜa/gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s@gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙eΜ9s̙3gΜ9s̙3g8`ƙ3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙ (q̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s 3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s "~9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜSʗ3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9sЙ3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙3gΜ9s̙;picolisp-3.1.5.2.orig/img/go.png0000644000000000000000000000024012265263724015033 0ustar rootrootPNG  IHDR |lbKGD̿ pHYs  DIDATmA07z ̻JBrV ܪع9ThAckƠ VIENDB`picolisp-3.1.5.2.orig/img/no.png0000644000000000000000000000015112265263724015043 0ustar rootrootPNG  IHDR |lbKGD̿ pHYs   IDATc`,K4IENDB`picolisp-3.1.5.2.orig/lib.css0000644000000000000000000001147712265263724014442 0ustar rootroot/* 10dec13abu * 17nov12jk * (c) Software Lab. Alexander Burger */ /* Lib */ .left {float: left} .right {float: right} .nofloat {float: none} .clr {clear: both} .norm {text-align: left} .align {text-align: right} .center {text-align: center} .black {color: black} .red {color: red} .green {color: green} .blue {color: blue} .yellow {color: yellow} .bold {font-weight: bold} .mono {font-family: monospace} .em1 {width: 1em} .em2 {width: 2em} .em3 {width: 3em} .em5 {width: 5em} .em7 {width: 7em} .em10 {width: 10em} .em15 {width: 15em} .em20 {width: 20em} .em25 {width: 25em} .em30 {width: 30em} .em40 {width: 40em} .em50 {width: 50em} .em60 {width: 60em} .em70 {width: 70em} /* Defaults */ body { font-family: Arial, Helvetica, sans-serif; background-color: #f0f0f0; font-size: small; margin: 0; } img { border: 0; } fieldset { border-style: none; } input, textarea, select { font-size: small; background-color: white; } caption { padding: 0 1em; text-align: left; margin-top: 2ex; background-color: #d0d0d0; } td { white-space: nowrap; } a { text-decoration: none; } .step a { border-radius: 6px; background-color: #d0d0d0; padding: 2px 3px; } a:hover { background-color: white; } /* Navigation */ .menu { padding-top: 2ex; background-color: #d0d0d0; } .menu ul { list-style: none; padding: 0; margin: 0; } .menu .cmd1, .act1, .cmd2, .act2, .cmd3, .act3, .cmd4, .act4 { list-style-position: inside; list-style-type: circle; padding: 0 0 0 2em; } .menu .act1, .act2, .act3, .act4 { list-style-type: disc; } .menu .sub1, .top1, .sub2, .top2, .sub3, .top3, .sub4, .top4 { list-style-position: inside; padding: 0 0 0 1em; } .bar { white-space: nowrap; } .bar ul { list-style: none; padding: 0; margin: 0; } .bar li { float: left; position: relative; background-color: #d0d0d0; } .bar li ul { position: absolute; } .bar li ul li { clear: both; width: 100%; border-left: 1px solid; border-right: 1px solid; border-bottom: 1px solid; } .bar .cmd, .act, .sub, .top { z-index: 9999; padding: 6px; } .bar .act { list-style-position: inside; list-style-type: disc; } #expires { position: absolute; top: 0; right: 3px; color: red; } /* Tabulators */ .tab { margin-bottom: 1ex; } .tab td { padding: 3px 1em; border-radius: 6px 6px 0 0; } .tab .top { font-weight: bold; border-top: 1px solid; border-left: 1px solid; border-right: 1px solid; } .tab .sub { background-color: #d0d0d0; border-bottom: 1px solid; } /* Main area */ .main { padding: 1ex 0 0 2ex; } /* Charts */ .chart { width: 100%; white-space: nowrap; } .chart td { background-color: #e0e0e0; } .chart td.T, th.T { background-color: #d0d0d0; } .chart td.nil, th.nil { background-color: white; } .chart td.body, th.body { background-color: #f0f0f0; } .btn { width: 1em; } /* Buttons */ .submit { font-weight: bold; background-color: #eee; background-image: -moz-linear-gradient(top, #eee, #ccc); background-image: -o-linear-gradient(top, #eee, #ccc); background-image: -webkit-linear-gradient(top, #eee, #ccc); background-image: linear-gradient(top, #eee, #ccc); border: 1px solid #707070; border-radius: 3px; box-shadow: 0 0 1px 1px rgba(255,255,255,.8) inset, 0 1px 0 rgba(0,0,0,.3); } .submit:hover { background-image: -moz-linear-gradient(top, #fafafa, #ddd); background-image: -o-linear-gradient(top, #fafafa, #ddd); background-image: -webkit-linear-gradient(top, #fafafa, #ddd); background-image: linear-gradient(top, #fafafa, #ddd); } .submit[disabled='disabled'] { background-image: -moz-linear-gradient(top, #eee, #ccc); background-image: -o-linear-gradient(top, #eee, #ccc); background-image: -webkit-linear-gradient(top, #eee, #ccc); background-image: linear-gradient(top, #eee, #ccc); } .edit { background-color: #66ff66; background-image: -moz-linear-gradient(top, #8f8, #6f6); background-image: -o-linear-gradient(top, #8f8, #6f6); background-image: -webkit-linear-gradient(top, #8f8, #6f6); background-image: linear-gradient(top, #8f8, #6f6); } /* Errors */ .error { color: red; background-color: yellow; } /* Fonts */ .tiny { font-size: smaller; padding: 0; } .note, .ask { font-weight: bold; } /* Alerts */ .alert { display: inline; padding: 1ex; margin: 1ex 0 1ex 5em; background-color: yellow; border: 1px solid #888; border-radius: 6px; } .alert input { margin-top: 1ex; } /* Dialogs */ .dialog { padding: 1ex; margin: 1ex 5em 1ex 1em; border: 1px solid #888; border-radius: 6px; } /* Hints */ .hint { font-size: small; background-color: #777; } .hints { font-size: small; color: black; padding-left: 3px; padding-top: 3px; border: 1px solid; background-color: white; } picolisp-3.1.5.2.orig/loc/0000755000000000000000000000000012265263724013725 5ustar rootrootpicolisp-3.1.5.2.orig/loc/AR.l0000644000000000000000000000044412265263724014406 0ustar rootroot(setq *Sep0 "," *Sep3 "." *CtryCode 54 *DateFmt '(@D "-" @M "-" @Y) *DayFmt '("Lunes" "Martes" "Miércoles" "Jueves" "Viernes" "Sábado" "Domingo") *MonFmt '("Enero" "Febrero" "Marzo" "Abril" "Mayo" "Junio" "Julio" "Agosto" "Septiembre" "Octubre" "Noviembre" "Diciembre") ) picolisp-3.1.5.2.orig/loc/CH.l0000644000000000000000000000044412265263724014376 0ustar rootroot(setq *Sep0 "." *Sep3 "'" *CtryCode 41 *DateFmt '(@D "." @M "." @Y) *DayFmt '("Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag") *MonFmt '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") ) picolisp-3.1.5.2.orig/loc/DE.l0000644000000000000000000000044412265263724014374 0ustar rootroot(setq *Sep0 "," *Sep3 "." *CtryCode 49 *DateFmt '(@D "." @M "." @Y) *DayFmt '("Montag" "Dienstag" "Mittwoch" "Donnerstag" "Freitag" "Samstag" "Sonntag") *MonFmt '("Januar" "Februar" "März" "April" "Mai" "Juni" "Juli" "August" "September" "Oktober" "November" "Dezember") ) picolisp-3.1.5.2.orig/loc/ES.l0000644000000000000000000000044312265263724014412 0ustar rootroot(setq *Sep0 "," *Sep3 "." *CtryCode 34 *DateFmt '(@D "/" @M "/" @Y) *DayFmt '("Lunes" "Martes" "Miércoles" "Jueves" "Viernes" "Sábado" "Domingo") *MonFmt '("Enero" "Febrero" "Marzo" "Abril" "Mayo" "Junio" "Julio" "Agosto" "Setiembre" "Octubre" "Noviembre" "Diciembre") ) picolisp-3.1.5.2.orig/loc/JP.l0000644000000000000000000000046412265263724014417 0ustar rootroot(setq *Sep0 "." *Sep3 "," *CtryCode 81 *DateFmt '(@Y "/" @M "/" @D) *DayFmt '("月曜日" "火曜日" "水曜日" "木曜日" "金曜日" "土曜日" "日曜日") *MonFmt '("一月" "二月" "三月" "四月" "五月" "六月" "七月" "八月" "九月" "十月" "十一月" "十二月") ) picolisp-3.1.5.2.orig/loc/NIL.l0000644000000000000000000000046612265263724014532 0ustar rootroot(setq # Default locale *Sep0 "." *Sep3 "," *CtryCode NIL *DateFmt '(@Y "-" @M "-" @D) *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) picolisp-3.1.5.2.orig/loc/NO.l0000644000000000000000000000043412265263724014417 0ustar rootroot(setq *Sep0 "," *Sep3 "." *CtryCode 47 *DateFmt '(@D "." @M "." @Y) *DayFmt '("mandag" "tirsdag" "onsdag" "torsdag" "fredag" "lørdag" "søndag") *MonFmt '("januar" "februar" "mars" "april" "mai" "juni" "juli" "august" "september" "oktober" "november" "desember") ) picolisp-3.1.5.2.orig/loc/RU.l0000644000000000000000000000063412265263724014433 0ustar rootroot(setq *Sep0 "," *Sep3 " " *CtryCode 7 *DateFmt '(@D "." @M "." @Y) *DayFmt '("Понедельник" "Вторник" "Среда" "Четверг" "Пятница" "Суббота" "Воскресенье") *MonFmt '("Январь" "Февраль" "Март" "Апрель" "Май" "Июнь" "Июль" "Август" "Сентябрь" "Октябрь" "Ноябрь" "Декабрь") ) picolisp-3.1.5.2.orig/loc/UK.l0000644000000000000000000000044312265263724014422 0ustar rootroot(setq *Sep0 "." *Sep3 "," *CtryCode 44 *DateFmt '(@D "/" @M "/" @Y) *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) picolisp-3.1.5.2.orig/loc/US.l0000644000000000000000000000044212265263724014431 0ustar rootroot(setq *Sep0 "." *Sep3 "," *CtryCode 1 *DateFmt '(@M "/" @D "/" @Y) *DayFmt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") *MonFmt '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December") ) picolisp-3.1.5.2.orig/loc/ar0000644000000000000000000000007712265263724014256 0ustar rootroot# 23may12abu # (c) Software Lab. Alexander Burger T "@loc/es" picolisp-3.1.5.2.orig/loc/ch0000644000000000000000000000007712265263724014246 0ustar rootroot# 10may08abu # (c) Software Lab. Alexander Burger T "@loc/de" picolisp-3.1.5.2.orig/loc/de0000644000000000000000000000512612265263724014244 0ustar rootroot# 22dec08abu # (c) Software Lab. Alexander Burger "Language" "Sprache" # lib/db.l "Boolean input expected" "Boolean-Type erwartet" "Numeric input expected" "Zahleneingabe erforderlich" "Symbolic type expected" "Symbol-Type erwartet" "String type expected" "String-Type erwartet" "Type error" "Typ-Fehler" "Not unique" "Nicht eindeutig" "Input required" "Eingabe erforderlich" # lib/form.l "Cancel" "Abbruch" "Yes" "Ja" "No" "Nein" "Select" "Auswahl" "Delete row?" "Zeile löschen?" "Show" "Anzeigen" "Bad date format" "Falsches Datums-Format" "Bad time format" "Falsches Uhrzeit-Format" "Bad phone number format" "Falsches Telefonnummern-Format" "male" "männlich" "female" "weiblich" "New" "Neu" "Edit" "Bearbeiten" "Save" "Speichern" "Done" "Fertig" "Currently edited by '@2' (@1)" "Zur Zeit von '@2' (@1) bearbeitet" "Search" "Suchen" "Reset" "Zurücksetzen" "New/Copy" "Neu/Muster" "Restore" "Wiederherstellen" "Restore @1?" "@1 wiederherstellen?" "Delete" "Löschen" "Delete @1?" "@1 löschen?" "Data not found" "Datensatz nicht gefunden" # General "login" "anmelden" "logout" "abmelden" "' logged in" "' ist angemeldet" "Name" "Name" "Password" "Passwort" "Permission denied" "Keine Berechtigung" "Permissions" "Berechtigungen" "Role" "Rolle" "Roles" "Rollen" "User" "Benutzer" "Users" "Benutzer" # Tooltips "Open submenu" "Untermenü öffnen" "Close submenu" "Untermenü schließen" "Next object of the same type" "Nächstes Objekt vom gleichen Typ" "Find or create an object of the same type" "Ein Objekt vom gleichen Typ suchen oder neu anlegen" "Choose a suitable value" "Einen passenden Wert auswählen" "Adopt this value" "Diesen Wert übernehmen" "Go to first line" "Zur ersten Zeile gehen" "Scroll up one page" "Eine Seite nach oben scrollen" "Scroll up one line" "Eine Zeile nach oben scrollen" "Scroll down one line" "Eine Zeile nach unten scrollen" "Scroll down one page" "Eine Seite nach unten scrollen" "Go to last line" "Zur letzten Zeile gehen" "Delete row" "Zeile löschen" "Shift row up" "Zeile nach oben schieben" "Clear all input fields" "Alle Eingabefelder löschen" "Release exclusive write access for this object" "Exklusiven Schreibzugriff auf dieses Objekt freigeben" "Gain exclusive write access for this object" "Exklusiven Schreibzugriff auf dieses Objekt erhalten" "Start search" "Suche starten" "Create new object" "Neues Objekt anlegen" "Create a new copy of this object" "Eine neue Kopie dieses Objektes anlegen" "Mark this object as \"not deleted\"" "Dieses Objekt als \"nicht gelöscht\" markieren" "Mark this object as \"deleted\"" "Dieses Objekt als \"gelöscht\" markieren" "Update" "Aktualisieren" picolisp-3.1.5.2.orig/loc/es0000644000000000000000000000261312265263724014261 0ustar rootroot# 26aug09art # Armadillo "Language" "Idioma" # lib/db.l "Boolean input expected" "Se espera el ingreso de datos tipo buliano" "Numeric input expected" "Se espera el ingreso de datos tipo numérico" "Symbolic type expected" "Se esperan datos del tipo simbólico" "String type expected" "Se esperan datos del tipo String" "Type error" "Error de tipado" "Not unique" "No único" "Input required" "Se require ingreso de datos" # lib/form.l "Cancel" "Cancelar" "Yes" "Sí" "No" "No" "Select" "Seleccionar" "Delete row?" "¿Borrar fila?" "Show" "Mostrar" "Bad date format" "El formato de la fecha no es válido" "Bad time format" "El formato de la hora no es válido" "Bad phone number format" "El formato del número telefónico no es válido" "male" "hombre" "female" "mujer" "New" "Nuevo" "Edit" "Editar" "Save" "Guardar" "Done" "Terminar" "Currently edited by '@2' (@1)" "Actualmente editado por '@2' (@1)" "Search" "Buscar" "Reset" "Vaciar/Limpiar" "New/Copy" "Nuevo/Copiar" "Restore" "Restaurar" "Restore @1?" "¿Restaurar @1?" "Delete" "Borrar" "Delete @1?" "¿Borrar @1?" "Data not found" "No se encontraron datos" # General "login" "Ingresar al Sistema" "logout" "Salir del Sistema" "' logged in" "' ingresó al sistema" "Name" "Nombre" "Password" "Contraseña" "Permission denied" "Permiso denegado" "Permissions" "Permisos" "Role" "Rol" "Roles" "Roles" "User" "Usuario" "Users" "Usuarios" picolisp-3.1.5.2.orig/loc/jp0000644000000000000000000000526612265263724014272 0ustar rootroot# 22dec08abu # (c) Software Lab. Alexander Burger "Language" "言語" # lib/db.l "Boolean input expected" "Booleanタイプが必要" "Numeric input expected" "数値入力が必要" "Symbolic type expected" "Symbolicタイプが必要" "String type expected" "Stringタイプが必要" "Type error" "タイプエラー" "Not unique" "重複" "Input required" "入力が必要" # lib/form.l "Cancel" "キャンセル" "Yes" "はい" "No" "いいえ" "Select" "選択" "Delete row?" "行を消しますか?" "Show" "表示" "Bad date format" "日付が違います" "Bad time format" "時刻が違います" "Bad phone number format" "電話番号が違います" "male" "男性" "female" "女性" "New" "作成" "Edit" "編集" "Save" "保存" "Done" "終了" "Currently edited by '@2' (@1)" "現在'@2'(@1)が編集中です" "Search" "検索" "Reset" "リセット" "New/Copy" "作成/コピー" "Restore" "もとへ戻す" "Restore @1?" "@1もとへ戻しますか?" "Delete" "消去" "Delete @1?" "@1を消しますか?" "Data not found" "データが見つかりません" # General "login" "ログイン" "logout" "ログアウト" "' logged in" "' ログインしました" "Name" "名前" "Password" "パスワード" "Permission denied" "認証できません" "Permissions" "許可" "Role" "役割" "Roles" "役割" "User" "ユーザー" "Users" "ユーザー" # Tooltips "Open submenu" "サブメニューを開く" "Close submenu" "サブメニューを閉じる" "Next object of the same type" "次の同じタイプへ" "Find or create an object of the same type" "同じタイプを探す/新規" "Choose a suitable value" "適したバリューを選ぶ" "Adopt this value" "このバリューを採用する" "Go to first line" "最初の列にいく" "Scroll up one page" "一ページ上へスクロール" "Scroll up one line" "一行上へスクロール" "Scroll down one line" "一行下へスクロール" "Scroll down one page" "一ページ下へスクロール" "Go to last line" "最後の列にいく" "Delete row" "行を消す" "Shift row up" "行を上へ移す" "Clear all input fields" "全ての入力フィールドを消す" "Release exclusive write access for this object" "Release exclusive write access for this object" "Gain exclusive write access for this object" "Gain exclusive write access for this object" "Start search" "検索スタート" "Create new object" "オブジェクトを新規" "Create a new copy of this object" "このオブジェクトを新しくコピーする" "Mark this object as \"not deleted\"" "このオブジェクトを消さない状態にする" "Mark this object as \"deleted\"" "このオブジェクトを消された状態にする" "Update" "更新" picolisp-3.1.5.2.orig/loc/no0000644000000000000000000000460012265263724014264 0ustar rootroot# 13jan10jk # Jon Kleiser, jon.kleiser@usit.uio.no "Language" "Språk" # lib/db.l "Boolean input expected" "Boolsk verdi forventet" "Numeric input expected" "Numerisk verdi forventet" "Symbolic type expected" "Symbol-type forventet" "String type expected" "Tekststreng forventet" "Type error" "Type-feil" "Not unique" "Ikke unik" "Input required" "Input-data påkrevet" # lib/form.l "Cancel" "Avbryt" "Yes" "Ja" "No" "Nei" "Select" "Velg" "Delete row?" "Slett rad?" "Show" "Vis" "Bad date format" "Ugyldig datoformat" "Bad time format" "Ugyldig tidsformat" "Bad phone number format" "Ugyldig telefonnummer-format" "male" "mannlig" "female" "kvinnelig" "New" "Ny" "Edit" "Rediger" "Save" "Lagre" "Done" "Ferdig" "Currently edited by '@2' (@1)" "Redigeres nå av '@2' (@1)" "Search" "Søk" "Reset" "Tilbakestill" "New/Copy" "Ny/Kopi" "Restore" "Gjenopprett" "Restore @1?" "Gjenopprette @1?" "Delete" "Slett" "Delete @1?" "Slett @1?" "Data not found" "Data ble ikke funnet" # General "login" "logg inn" "logout" "logg ut" "' logged in" "' er innlogget" "Name" "Navn" "Password" "Passord" "Permission denied" "Ingen adgangsrett" "Permissions" "Adgangsrettigheter" "Role" "Rolle" "Roles" "Roller" "User" "Bruker" "Users" "Brukere" # Tooltips "Open submenu" "Åpne undermeny" "Close submenu" "Lukk undermeny" "Next object of the same type" "Neste objekt av samme type" "Find or create an object of the same type" "Finn eller opprett et objekt av samme type" "Choose a suitable value" "Velg en passende verdi" "Adopt this value" "Overta denne verdien" "Go to first line" "Gå til første linje" "Scroll up one page" "Scroll opp en side" "Scroll up one line" "Scroll opp en linje" "Scroll down one line" "Scroll ned en linje" "Scroll down one page" "Scroll ned en side" "Go to last line" "Gå til siste linje" "Delete row" "Slett rad" "Shift row up" "Forskyv en rad opp" "Clear all input fields" "Slett alle input-felter" "Release exclusive write access for this object" "Frigi eksklusiv skrivetilgang til dette objektet" "Gain exclusive write access for this object" "Innhent eksklusiv skrivetilgang til dette objektet" "Start search" "Start søk" "Create new object" "Opprett nytt objekt" "Create a new copy of this object" "Opprett ny kopi av dette objektet" "Mark this object as \"not deleted\"" "Merk dette objektet som \"ikke slettet\"" "Mark this object as \"deleted\"" "Merk dette objektet som \"slettet\"" "Update" "Oppdater" picolisp-3.1.5.2.orig/loc/ru0000644000000000000000000000666312265263724014311 0ustar rootroot# 11aug08 # Mansur Mamkin "Language" "Язык" # lib/db.l "Boolean input expected" "Ожидается тип Boolean" "Numeric input expected" "Ожидается числовой тип" "Symbolic type expected" "Ожидается тип Symbol" "String type expected" "Ожидается тип String" "Type error" "Ошибка типа" "Not unique" "Не уникальный" "Input required" "Требуется ввод" # lib/form.l "Cancel" "Отмена" "Yes" "Да" "No" "Нет" "Select" "Выбрать" "Delete row?" "Удалить строку?" "Show" "Показать" "Bad date format" "Неверный формат даты" "Bad time format" "Неверный формат времени" "Bad phone number format" "Неверный формат телефонного номера" "male" "муж." "female" "жен." "New" "Новый" "Edit" "Редактировать" "Save" "Сохранить" "Done" "Готово" "Currently edited by '@2' (@1)" "Редактируется '@2' (@1)" "Search" "Искать" "Reset" "Сброс" "New/Copy" "Новый/Копировать" "Restore" "Восстановить" "Restore @1?" "Восстановить @1?" "Delete" "Удалить" "Delete @1?" "Удалить @1?" "Data not found" "Данные не найдены" # General "login" "Войти" "logout" "Выйти" "' logged in" "' вошел" "Name" "Имя" "Password" "Пароль" "Permission denied" "Доступ запрещен" "Permissions" "Разрешения" "Role" "Роль" "Roles" "Роли" "User" "Пользователь" "Users" "Пользователи" # Tooltips "Open submenu" "Открыть подменю" "Close submenu" "Закрыть подменю" "Next object of the same type" "Следующий объект такого же типа" "Find or create an object of the same type" "Найти или создать объект такого же типа" "Choose a suitable value" "Выберите подходящее значение" "Adopt this value" "Принять это значение" "Go to first line" "Перейти к первой строке" "Scroll up one page" "Прокрутить вверх на одну страницу" "Scroll up one line" "Прокрутить вверх на одну строку" "Scroll down one line" "Прокрутить вниз на одну строку" "Scroll down one page" "Прокрутить вниз на одну страницу" "Go to last line" "Перейти к последней строке" "Delete row" "Удалить строку" "Shift row up" "Переместить строку вверх" "Clear all input fields" "Очистить все поля ввода" "Release exclusive write access for this object" "Закрыть эксклюзивный доступ для записи этого объекта" "Gain exclusive write access for this object" "Получить эксклюзивный доступ для записи этого объекта" "Start search" "Начать поиск" "Create new object" "Создать новый объект" "Create a new copy of this object" "Создать новую копию этого объекта" "Mark this object as \"not deleted\"" "Отметить этот объект как \"не удалённый\"" "Mark this object as \"deleted\"" "Отметить этот объект как \"удалённый\"" "Update" "Обновить" picolisp-3.1.5.2.orig/lib.l0000644000000000000000000002604012265263724014075 0ustar rootroot# 29nov13abu # (c) Software Lab. Alexander Burger (de task (Key . Prg) (nond (Prg (del (assoc Key *Run) '*Run)) ((num? Key) (quit "Bad Key" Key)) ((assoc Key *Run) (push '*Run (conc (make (when (lt0 (link Key)) (link (+ (eval (pop 'Prg) 1))) ) ) (ifn (sym? (car Prg)) Prg (cons (cons 'job (cons (lit (make (while (atom (car Prg)) (link (cons (pop 'Prg) (eval (pop 'Prg) 1)) ) ) ) ) Prg ) ) ) ) ) ) ) (NIL (quit "Key conflict" Key)) ) ) (de forked () (let N (caar *Run) (when (gt0 N) (push '*Fork (list 'close N)) ) (push '*Fork (list 'task N)) ) ) (de timeout (N) (if2 N (assoc -1 *Run) (set (cdr @) (+ N)) (push '*Run (list -1 (+ N) '(bye))) (del @ '*Run) ) ) (de abort ("N" . "Prg") (catch 'abort (alarm "N" (throw 'abort)) (finally (alarm 0) (run "Prg")) ) ) (de macro "Prg" (run (fill "Prg")) ) (de later ("@Var" . "@Prg") (macro (task (pipe (pr (prog . "@Prg"))) (setq "@Var" (in @ (rd))) (task (close @)) ) ) "@Var" ) (de recur recurse (run (cdr recurse)) ) (de curry "Z" (let ("X" (pop '"Z") "Y" (pop '"Z") "P" (filter pat? "X")) (if2 "P" (diff "X" "P") (list "Y" (cons 'job (lit (env @)) (fill "Z" "P"))) (cons "Y" (fill "Z" "P")) (list "Y" (cons 'job (lit (env @)) "Z")) (cons "Y" "Z") ) ) ) (====) ### Definitions ### (de expr ("F") (set "F" (list '@ (list 'pass (box (getd "F")))) ) ) (de subr ("F") (set "F" (getd (cadr (cadr (getd "F")))) ) ) (de undef ("X" "C") (when (pair "X") (setq "C" (cdr "X") "X" (car "X")) ) (ifn "C" (prog1 (val "X") (set "X")) (prog1 (cdr (asoq "X" (val "C"))) (set "C" (delq (asoq "X" (val "C")) (val "C")) ) ) ) ) (de redef "Lst" (let ("Old" (car "Lst") "New" (name "Old")) (set "New" (getd "Old") "Old" "New" "Old" (fill (cdr "Lst") "Old") ) "New" ) ) (de daemon ("X" . Prg) (prog1 (nond ((pair "X") (or (pair (getd "X")) (expr "X")) ) ((pair (cdr "X")) (method (car "X") (cdr "X")) ) (NIL (method (car "X") (get (or (cddr "X") *Class) (cadr "X"))) ) ) (con @ (append Prg (cdr @))) ) ) (de patch ("Lst" "Pat" . "Prg") (bind (fish pat? "Pat") (recur ("Lst") (loop (cond ((match "Pat" (car "Lst")) (set "Lst" (run "Prg")) ) ((pair (car "Lst")) (recurse @) ) ) (NIL (cdr "Lst")) (T (atom (cdr "Lst")) (when (match "Pat" (cdr "Lst")) (con "Lst" (run "Prg")) ) ) (setq "Lst" (cdr "Lst")) ) ) ) ) (====) (de cache ("Var" "Str" . Prg) (nond ((setq "Var" (car (idx "Var" "Str" T))) (set "Str" "Str" "Str" (run Prg 1)) ) ((n== "Var" (val "Var")) (set "Var" (run Prg 1)) ) (NIL (val "Var")) ) ) (====) ### I/O ### (de tab (Lst . @) (for N Lst (let V (next) (and (gt0 N) (space (- N (length V)))) (prin V) (and (lt0 N) (args) (space (- 0 N (length V)))) ) ) (prinl) ) (de beep () (prin "^G") ) (de msg (X . @) (out 2 (print X) (pass prinl) (flush) ) X ) (de script (File . @) (load File) ) (de once Prg (unless (idx '*Once (file) T) (run Prg 1) ) ) (de pil @ (when (== "Pil" '"Pil") (call 'mkdir "-p" (setq "Pil" `(pack (sys "HOME") "/.pil/"))) ) (pass pack "Pil") ) (de rc (File Key . @) (ctl File (let Lst (in File (read)) (ifn (args) (cdr (assoc Key Lst)) (let Val (next) (if (assoc Key Lst) (con @ Val) (push 'Lst (cons Key Val)) ) (protect (out File (println Lst)) ) Val ) ) ) ) ) (de acquire (File) (ctl File (let P (in File (rd)) (or (= P *Pid) (unless (and P (kill P 0)) (out File (pr *Pid)) ) ) ) ) ) (de release (File) (ctl File (out File)) ) # Temporary Files (de tmp @ (unless *Tmp (push '*Bye '(call 'rm "-r" *Tmp)) (push '*Fork '(off *Tmp) '(del '(call 'rm "-r" *Tmp) '*Bye)) (call 'mkdir "-p" (setq *Tmp (pil "tmp/" *Pid "/"))) ) (pass pack *Tmp) ) ### List ### (de insert (N Lst X) (conc (cut (dec N) 'Lst) (cons X) Lst ) ) (de remove (N Lst) (conc (cut (dec N) 'Lst) (cdr Lst) ) ) (de place (N Lst X) (conc (cut (dec N) 'Lst) (cons X) (cdr Lst) ) ) (de uniq (Lst) (let R NIL (filter '((X) (not (idx 'R X T))) Lst ) ) ) (de group (Lst) (make (for X Lst (if (assoc (car X) (made)) (conc @ (cons (cdr X))) (link (list (car X) (cdr X))) ) ) ) ) ### Symbol ### (de qsym "Sym" (cons (val "Sym") (getl "Sym")) ) (de loc (S X) (if (and (str? X) (= S X)) X (and (pair X) (or (loc S (car X)) (loc S (cdr X)) ) ) ) ) (de local Lst (mapc zap Lst) ) (de import Lst (for Sym Lst (unless (== Sym (intern Sym)) (quit "Import conflict" Sym) ) ) ) ### OOP ### (de class Lst (let L (val (setq *Class (car Lst))) (def *Class (recur (L) (if (atom (car L)) (cdr Lst) (cons (car L) (recurse (cdr L))) ) ) ) ) ) (de object ("Sym" "Val" . @) (putl "Sym") (def "Sym" "Val") (while (args) (put "Sym" (next) (next)) ) "Sym" ) (de extend X (setq *Class (car X)) ) # Class variables (de var X (if (pair (car X)) (put (cdar X) (caar X) (cdr X)) (put *Class (car X) (cdr X)) ) ) (de var: X (apply meta X This) ) ### Math ### (de scl ("N" . "Prg") (if "Prg" (let *Scl "N" (run "Prg")) (setq *Scl "N") ) ) # (Knuth Vol.2, p.442) (de ** (X N) # N th power of X (if (ge0 N) (let Y 1 (loop (when (bit? 1 N) (setq Y (* Y X)) ) (T (=0 (setq N (>> 1 N))) Y ) (setq X (* X X)) ) ) 0 ) ) (de accu (Var Key Val) (when Val (if (assoc Key (val Var)) (con @ (+ Val (cdr @))) (push Var (cons Key Val)) ) ) ) ### Pretty Printing ### (de *PP T NIL if ifn when unless while until do case casq state for with catch finally co ! setq default push bind job use let let? prog1 later recur redef =: in out ctl tab new ) (de *PP1 let let? for redef) (de *PP2 setq default) (de *PP3 if2) (de pretty (X N . @) (setq N (abs (space (or N 0)))) (while (args) (printsp (next)) ) (if (or (atom X) (>= 12 (size X))) (print X) (while (== 'quote (car X)) (prin "'") (pop 'X) ) (let Z X (prin "(") (cond ((and (pair (car X)) (> (size @) 12)) (pretty (pop 'X) (- -3 N)) ) ((memq (print (pop 'X)) *PP) (cond ((memq (car Z) *PP1) (if (and (pair (car X)) (pair (cdar X))) (when (>= 12 (size (car X))) (space) (print (pop 'X)) ) (space) (print (pop 'X)) (when (or (atom (car X)) (>= 12 (size (car X)))) (space) (print (pop 'X)) ) ) ) ((memq (car Z) *PP2) (inc 'N 3) (loop (prinl) (pretty (cadr X) N (car X)) (NIL (setq X (cddr X)) (space)) ) ) ((or (atom (car X)) (>= 12 (size (car X)))) (space) (print (pop 'X)) ) ) ) ((and (memq (car Z) *PP3) (>= 12 (size (head 2 X)))) (space) (print (pop 'X) (pop 'X)) ) ) (when X (loop (T (== Z X) (prin " .")) (T (atom X) (prin " . ") (print X)) (prinl) (pretty (pop 'X) (+ 3 N)) (NIL X) ) (space) ) (prin ")") ) ) ) (de pp ("X" C) (let *Dbg NIL (and (pair "X") (setq C (cdr "X"))) (prin "(") (printsp (if C 'dm 'de)) (prog1 (printsp "X") (setq "X" (if C (method (if (pair "X") (car "X") "X") C) (val "X") ) ) (cond ((atom "X") (prin ". ") (print "X")) ((atom (cdr "X")) (ifn (cdr "X") (print (car "X")) (print (car "X")) (prin " . ") (print @) ) ) (T (let Z "X" (print (pop '"X")) (loop (T (== Z "X") (prin " .")) (NIL "X") (T (atom "X") (prin " . ") (print "X") ) (prinl) (pretty (pop '"X") 3) ) (space) ) ) ) (prinl ")") ) ) ) (de show ("X" . @) (let *Dbg NIL (setq "X" (pass get "X")) (when (sym? "X") (print "X" (val "X")) (prinl) (maps '((X) (space 3) (if (atom X) (println X) (println (cdr X) (car X)) ) ) "X" ) ) "X" ) ) (de view (X Y) (let *Dbg NIL (if (=T Y) (let N 0 (recur (N X) (when X (recurse (+ 3 N) (cddr X)) (space N) (println (car X)) (recurse (+ 3 N) (cadr X)) ) ) ) (let Z X (loop (T (atom X) (println X)) (if (atom (car X)) (println '+-- (pop 'X)) (print '+---) (view (pop 'X) (append Y (cons (if X "| " " "))) ) ) (NIL X) (mapc prin Y) (T (== Z X) (println '*)) (println '|) (mapc prin Y) ) ) ) ) ) ### Check ### # Assertions (de assert Prg (when *Dbg (cons (list 'unless (if (cdr Prg) (cons 'and Prg) (car Prg)) (list 'quit "'assert' failed" (lit (car Prg))) ) ) ) ) # Unit tests (de test (Pat . Prg) (bind (fish pat? Pat) (unless (match Pat (run Prg 1)) (msg Prg) (quit "'test' failed" Pat) ) ) ) ### Debug ### `*Dbg (if (info (pil "editor")) (load (pil "editor")) (load "@lib/led.l" "@lib/edit.l") ) (load "@lib/debug.l" "@lib/lint.l") (noLint 'later (loc "@Prg" later)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/man/0000755000000000000000000000000012265263724013723 5ustar rootrootpicolisp-3.1.5.2.orig/man/man1/0000755000000000000000000000000012265263724014557 5ustar rootrootpicolisp-3.1.5.2.orig/man/man1/picolisp.10000644000000000000000000000560212265263724016466 0ustar rootroot.\" 05nov11abu .\" .TH PICOLISP 1 "" "" "User Commands" .SH NAME pil, picolisp \- a fast, lightweight Lisp interpreter .SH SYNOPSIS .B pil [arguments ...] [-] [arguments ...] [+] .br .B /installpath/bin/picolisp [arguments ...] [-] [arguments ...] [+] .SH DESCRIPTION .B PicoLisp is a Lisp interpreter with a small memory footprint, yet relatively high execution speed. It combines an elegant and powerful language with built-in database functionality. .P .B pil is the startup front-end for the interpreter. It takes care of starting the binary base system and loading a useful runtime environment. .P .B picolisp is just the bare interpreter binary. It is usually called in stand-alone scripts, using the she-bang notation in the first line, passing the minimal environment in .I lib.l and loading additional files as needed: .P .RS #!/usr/bin/picolisp /usr/lib/picolisp/lib.l .RE .RS (load "@ext.l" "myfiles/lib.l" "myfiles/foo.l") .RE .RS (do ... something ...) .RE .RS (bye) .RE .SH INVOCATION .B PicoLisp has no pre-defined command line flags; applications are free to define their own. Any built-in or user-level Lisp function can be invoked from the command line by prefixing it with a hyphen. Examples for built-in functions useful in this context are .B version (print the version number) or .B bye (exit the interpreter). Therefore, a minimal call to print the version number and then immediately exit the interpreter would be: .P .RS $ pil -version -bye .RE .P Any other argument (not starting with a hyphen) should be the name of a file to be loaded. If the first character of a path or file name is an at-mark, it will be substituted with the path to the installation directory. .P All arguments are evaluated from left to right, then an interactive .I read-eval-print loop is entered (with a colon as prompt). .P A single hyphen stops the evaluation of the rest of the command line, so that the remaining arguments may be processed under program control. .P If the very last command line argument is a single plus character, debugging mode is switched on at interpreter startup, before evaluating any of the command line arguments. A minimal interactive session is started with: .P .RS $ pil + .RE .P Here you can access the reference manual .P .RS : (doc) .RE .P and the online documentation for most functions, .P .RS : (doc 'vi) .RE .P or directly inspect their sources: .P .RS : (vi 'doc) .RE .P The interpreter can be terminated with .P .RS : (bye) .RE .P or by typing Ctrl-D. .SH FILES Runtime files are maintained in the ~/.pil directory: .IP ~/.pil/tmp// Process-local temporary directories .IP ~/.pil/history The line editor's history file .SH BUGS .B PicoLisp doesn't try to protect you from every possible programming error ("You asked for it, you got it"). .SH AUTHOR Alexander Burger .SH RESOURCES .B Home page: http://home.picolisp.com .br .B Download: http://www.software-lab.de/down.html picolisp-3.1.5.2.orig/man/man1/pil.10000644000000000000000000000002412265263724015421 0ustar rootroot.so man1/picolisp.1 picolisp-3.1.5.2.orig/misc/0000755000000000000000000000000012265263724014103 5ustar rootrootpicolisp-3.1.5.2.orig/misc/bigtest0000755000000000000000000000503112265263724015471 0ustar rootroot#!bin/picolisp lib.l # 25apr11abu # misc/bigtest (load "@lib/misc.l") (seed (car (argv))) # Random patterns: # cnt # xxx0000000000000000000000000xxxx0000000000000000000000000xxx # (| 7 (>> -28 15) (>> -57 7)) # # xxx1111111111111111111111111xxxx1111111111111111111111111xxx # 1FFFFFF0FFFFFF8 # # # dig # xxx000000000000000000000000000xxxx000000000000000000000000000xxx # (| 7 (>> -30 15) (>> -61 7)) # # xxx111111111111111111111111111xxxx111111111111111111111111111xxx # 1FFFFFFC3FFFFFF8 (de rnd () (let (Big (| (rand 0 7) (>> -28 (rand 0 15)) (>> -57 (rand 0 7))) N -60) (when (rand T) (setq Big (| Big `(hex "1FFFFFF0FFFFFF8"))) ) (do (rand 0 2) (let Dig (| (rand 0 7) (>> -30 (rand 0 15)) (>> -61 (rand 0 7))) (when (rand T) (setq Dig (| Dig `(hex "1FFFFFFC3FFFFFF8"))) ) (setq Big (| Big (>> N Dig))) (dec 'N 64) ) ) (if (rand T) Big (- Big)) ) ) (de test1 (S N1) (let (N (read) X (eval (list S N1))) (unless (= N X) (prinl "^J" N ": (" S " " N1 ") -> " X) (bye) ) ) ) (de test2 (S N1 N2) (let (N (read) X (eval (list S N1 N2))) (unless (= N X) (prinl "^J" N ": (" S " " N1 " " N2 ") -> " X) (bye) ) ) ) (de cmp2 (S N1 N2) (let (N (n0 (read)) X (eval (list S N1 N2))) (unless (== N X) (prinl "^J" N ": (" S " " N1 " " N2 ") -> " X) (bye) ) ) ) (sys "BC_LINE_LENGTH" "200") (pipe (out '("/usr/bin/bc") (do 10000000 (setq N1 (rnd)) (while (=0 (setq N2 (rnd)))) (prinl N1) (prinl N2) (prinl N1 " + " N2) (prinl N1 " + 1") (prinl N1 " + 1") (prinl N1 " - " N2) (prinl N1 " - 1") (prinl N1 " - 1") (prinl N1 " * " N2) (prinl N1 " * 2") (prinl N1 " % " N2) (prinl N1 " / " N2) (prinl N1 " / 2") (prinl N1 " >= " N2) (prinl N1 " > " N2) (prinl "sqrt(" (abs N1) ")") ) ) (do 100 (do 100000 (setq N1 (read) N2 (read) ) (test2 '+ N1 N2) (test2 '+ N1 1) (test1 'inc N1) (test2 '- N1 N2) (test2 '- N1 1) (test1 'dec N1) (test2 '* N1 N2) (test2 '* N1 2) (test2 '% N1 N2) (test2 '/ N1 N2) (test2 '/ N1 2) (cmp2 '>= N1 N2) (cmp2 '> N1 N2) (test1 'sqrt (abs N1)) ) (prin ".") (flush) ) (prinl) ) (bye) picolisp-3.1.5.2.orig/misc/calc0000755000000000000000000000030712265263724014733 0ustar rootroot#!/usr/bin/picolisp /usr/lib/picolisp/lib.l # 10may11abu # (c) Software Lab. Alexander Burger (load "@lib/misc.l" "/usr/share/picolisp/misc/calc.l") # Initialize (main) # Start server (go) (wait) picolisp-3.1.5.2.orig/misc/calc.l0000644000000000000000000000415112265263724015163 0ustar rootroot# 14may11abu # (c) Software Lab. Alexander Burger # *Init *Accu *Stack (allowed NIL "!calculator" "@lib.css") (load "@lib/http.l" "@lib/xhtml.l" "@lib/form.l") # Calculator logic (de digit (N) (when *Init (zero *Accu) (off *Init)) (setq *Accu (+ N (* 10 *Accu))) ) (de calc () (let (Fun (caar *Stack) Val (cddr (pop '*Stack))) (setq *Accu (if (and (== '/ Fun) (=0 *Accu)) (alert "Div / 0") (Fun Val *Accu) ) ) ) ) (de operand (Fun Prio) (when (>= (cadar *Stack) Prio) (calc)) (push '*Stack (cons Fun Prio *Accu)) (on *Init) ) (de finish () (while *Stack (calc)) (on *Init) ) # Calculator GUI (de calculator () (app) (action (html 0 "Bignum Calculator" "@lib.css" NIL (

NIL "Bignum Calculator") (form NIL (
(gui '(+Var +NumField) '*Accu 60)) ( 4 (gui '(+JS +Button) "±" '(setq *Accu (- *Accu))) (gui '(+Able +JS +Button) '(ge0 *Accu) (char 8730) '(setq *Accu (sqrt *Accu)) ) (gui '(+JS +Button) "\^" '(operand '** 3)) (gui '(+JS +Button) "/" '(operand '/ 2)) (gui '(+JS +Button) "7" '(digit 7)) (gui '(+JS +Button) "8" '(digit 8)) (gui '(+JS +Button) "9" '(digit 9)) (gui '(+JS +Button) "*" '(operand '* 2)) (gui '(+JS +Button) "4" '(digit 4)) (gui '(+JS +Button) "5" '(digit 5)) (gui '(+JS +Button) "6" '(digit 6)) (gui '(+JS +Button) "-" '(operand '- 1)) (gui '(+JS +Button) "1" '(digit 1)) (gui '(+JS +Button) "2" '(digit 2)) (gui '(+JS +Button) "3" '(digit 3)) (gui '(+JS +Button) "+" '(operand '+ 1)) (gui '(+JS +Button) "0" '(digit 0)) (gui '(+JS +Button) "C" '(zero *Accu)) (gui '(+JS +Button) "A" '(main)) (gui '(+JS +Button) "=" '(finish)) ) ) ) ) ) # Initialize (de main () (on *Init) (zero *Accu) (off *Stack) ) # Start server (de go () (server 8080 "!calculator") ) picolisp-3.1.5.2.orig/misc/chat0000755000000000000000000000102212265263724014743 0ustar rootroot#!bin/picolisp lib.l # 21dec05abu # *Port *Sock *Name (de chat Lst (out *Sock (mapc prin Lst) (prinl) ) ) (setq *Port (port 4004)) (loop (setq *Sock (listen *Port)) (NIL (fork) (close *Port)) (close *Sock) ) (out *Sock (prin "Please enter your name: ") (flush) ) (in *Sock (setq *Name (line T))) (tell 'chat "+++ " *Name " arrived +++") (task *Sock (in @ (ifn (eof) (tell 'chat *Name "> " (line T)) (tell 'chat "--- " *Name " left ---") (bye) ) ) ) (wait) picolisp-3.1.5.2.orig/misc/crc.l0000644000000000000000000000170012265263724015025 0ustar rootroot# 25may11abu # (c) Software Lab. Alexander Burger (if (== 64 64) (load "@lib/native.l") (from "/**/")) (gcc "util" NIL (crc (Len Lst) "crc" 'I Len (cons NIL (cons Len) Lst)) ) int crc(int len, char *p) { int res, c, i; for (res = 0; --len >=0;) { c = *p++; for (i = 0; i < 8; ++i) { if ((c ^ res) & 1) res ^= 0x14002; /* Polynom x**16 + x**15 + x**2 + 1 */ c >>= 1, res >>= 1; } } return res; } /**/ (ifn (== 64 64) (load "@lib/gcc.l") (from "/**/")) (gcc "crc" NIL 'crc) any crc(any ex) { any x; int len, res, c, i; len = evCnt(ex, x = cdr(ex)); x = cdr(x), x = EVAL(car(x)); for (res = 0; --len >=0; x = cdr(x)) { c = (int)xCnt(ex,car(x)); for (i = 0; i < 8; ++i) { if ((c ^ res) & 1) res ^= 0x14002; /* Polynom x**16 + x**15 + x**2 + 1 */ c >>= 1, res >>= 1; } } return boxCnt(res); } /**/ # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/dining.l0000644000000000000000000000346512265263724015540 0ustar rootroot# 18mar10abu # (c) Software Lab. Alexander Burger # Dining Philosophers (de dining (Name State) (loop (prinl Name ": " State) (state 'State # Dispatch according to state (thinking 'hungry) # If thinking, get hungry (hungry # If hungry, grab random fork (if (rand T) (and (acquire leftFork) 'leftFork) (and (acquire rightFork) 'rightFork) ) ) (hungry 'hungry # Failed, stay hungry for a while (wait (rand 1000 3000)) ) (leftFork # If holding left fork, try right one (and (acquire rightFork) 'eating) (wait 2000) ) # then eat for 2 seconds (rightFork # If holding right fork, try left one (and (acquire leftFork) 'eating) (wait 2000) ) # then eat for 2 seconds ((leftFork rightFork) 'hungry # Otherwise, go back to hungry, (release (val State)) # release left or right fork (wait (rand 1000 3000)) ) # and stay hungry (eating 'thinking # After eating, resume thinking (release leftFork) (release rightFork) (wait 6000) ) ) ) ) # for 6 seconds (setq *Philosophers (maplist '((Phils Forks) (let (leftFork (tmp (car Forks)) rightFork (tmp (cadr Forks))) (or (fork) # Parent: Collect child process IDs (dining (car Phils) 'hungry) ) ) ) # Initially hungry '("Aristotle" "Kant" "Spinoza" "Marx" "Russell") '("ForkA" "ForkB" "ForkC" "ForkD" "ForkE" .) ) ) (push '*Bye '(mapc kill *Philosophers)) # Terminate all upon exit # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/dirTree.l0000644000000000000000000000074712265263724015666 0ustar rootroot# 06may11abu # (c) Software Lab. Alexander Burger (load "@lib/http.l" "@lib/xhtml.l") (de subDirs (Dir) (cache '*DirCache (or (pack (flip (chop Dir))) ".") (extract '((F) (when (=T (car (info (setq F (pack Dir F))))) (pack F '/) ) ) (dir Dir) ) ) ) (de dir.html (Path) (and (app) (setq *DirTree (subDirs))) (html NIL "Test" NIL NIL ( "!dir.html" Path *DirTree subDirs nil subDirs) ) ) (server 8080 "!dir.html") picolisp-3.1.5.2.orig/misc/fannkuch.l0000644000000000000000000000221312265263724016053 0ustar rootroot# 07nov09abu # (c) Software Lab. Alexander Burger # Fannkuch benchmark (http://shootout.alioth.debian.org) (de fannkuch (N) (let (Lst (range 1 N) L Lst Max) (recur (L) # Permute (if (cdr L) (do (length L) (recurse (cdr L)) (rot L) ) (zero N) # For each permutation (for (P (copy Lst) (> (car P) 1) (flip P (car P))) (inc 'N) ) (setq Max (max N Max)) ) ) Max ) ) # Parallelized version (de fannkuch+ (N) (let (Res (need N) Lst (range 1 N) L Lst Max) (for (R Res R (cdr R)) (later R (let L (cdr Lst) (recur (L) # Permute (if (cdr L) (do (length L) (recurse (cdr L)) (rot L) ) (zero N) # For each permutation (for (P (copy Lst) (> (car P) 1) (flip P (car P))) (inc 'N) ) (setq Max (max N Max)) ) ) Max ) ) (rot Lst) ) (wait NIL (full Res)) (apply max Res) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/fibo.l0000644000000000000000000000164612265263724015206 0ustar rootroot# 27oct12abu # (c) Software Lab. Alexander Burger # Standard version (de fibo (N) (if (>= 2 N) 1 (+ (fibo (dec N)) (fibo (- N 2))) ) ) # Parallelized version (de fibo+ (D N) # Uses 2**D processes (cond ((>= 1 (dec 'N)) 1) ((ge0 (dec 'D)) (let (A NIL B NIL) (later 'A (fibo+ D N)) (later 'B (fibo+ D (dec N))) (wait NIL (and A B)) (+ A B) ) ) (T (+ (fibo+ D N) (fibo+ D (dec N)) ) ) ) ) # Using a cache (fastest) (de cachedFibo (N) (cache '(NIL) (pack (char (hash N)) N) (if (>= 2 N) 1 (+ (cachedFibo (dec N)) (cachedFibo (- N 2))) ) ) ) # Coded in 'C' `(== 64 64) # Only in the 64-bit version (load "@lib/native.l") (gcc "fibo" NIL (cFibo (N) "Fibo" 'I N) ) int Fibo(int n) { if (n <= 2) return 1; return Fibo(n-1) + Fibo(n-2); } /**/ # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/hanoi.l0000644000000000000000000000077412265263724015366 0ustar rootroot# 19jul13abu # (c) Software Lab. Alexander Burger # Lisp (de hanoi (N) (move N 'left 'center 'right) ) (de move (N A B C) (unless (=0 N) (move (dec N) A C B) (println 'Move 'disk 'from 'the A 'to 'the B 'pole) (move (dec N) C B A) ) ) # Pilog (be hanoi (@N) (move @N left center right) ) (be move (0 @ @ @) T) (be move (@N @A @B @C) (^ @M (dec (-> @N))) (move @M @A @C @B) (^ @ (println 'Move 'disk 'from 'the (-> @A) 'to 'the (-> @B) 'pole)) (move @M @C @B @A) ) picolisp-3.1.5.2.orig/misc/life.l0000644000000000000000000000166512265263724015207 0ustar rootroot# 31dec13abu # (c) Software Lab. Alexander Burger (load "@lib/simul.l") (seed (in "/dev/urandom" (rd 8))) (let Grid (grid 26 26) (for Col Grid (for This Col (=: life (rand T)) ) ) (loop (disp Grid NIL '((This) (if (: life) "X " " ")) ) (wait 1000) (for Col Grid (for This Col (let N # Count neighbors (cnt '((Dir) (get (Dir This) 'life)) (quote west east south north ((X) (south (west X))) ((X) (north (west X))) ((X) (south (east X))) ((X) (north (east X))) ) ) (=: next # Next generation (if (: life) (>= 3 N 2) (= N 3) ) ) ) ) ) (for Col Grid # Update (for This Col (=: life (: next)) ) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/mailing0000755000000000000000000001121612265263724015452 0ustar rootroot#!bin/picolisp lib.l # 20may11abu # (c) Software Lab. Alexander Burger # Configuration (setq *MailingList "picolisp@software-lab.de" *SpoolFile "/var/mail/picolisp" *MailingDomain "software-lab.de" *Mailings (make (in "Mailings" (while (line T) (link @)))) *SmtpHost "localhost" *SmtpPort 25 ) # Process mails (loop (when (gt0 (car (info *SpoolFile))) (protect (in *SpoolFile (unless (= "From" (till " " T)) (quit "Bad mbox file") ) (char) (while (setq *From (lowc (till " " T))) (off *Name *Subject *Date *MessageID *InReplyTo *MimeVersion *ContentType *ContentTransferEncoding *ContentDisposition *UserAgent ) (while (split (line) " ") (setq *Line (glue " " (cdr @))) (case (pack (car @)) ("From:" (setq *Name *Line)) ("Subject:" (setq *Subject *Line)) ("Date:" (setq *Date *Line)) ("Message-ID:" (setq *MessageID *Line)) ("In-Reply-To:" (setq *InReplyTo *Line)) ("MIME-Version:" (setq *MimeVersion *Line)) ("Content-Type:" (setq *ContentType *Line)) ("Content-Transfer-Encoding:" (setq *ContentTransferEncoding *Line)) ("Content-Disposition:" (setq *ContentDisposition *Line)) ("User-Agent:" (setq *UserAgent *Line)) ) ) (if (nor (member *From *Mailings) (= "subscribe" (lowc *Subject))) (out "/dev/null" (echo "^JFrom ") (msg *From " discarded")) (unless (setq *Sock (connect *SmtpHost *SmtpPort)) (quit "Can't connect to SMTP server") ) (unless (and (pre? "220 " (in *Sock (line T))) (out *Sock (prinl "HELO " *MailingDomain "^M")) (pre? "250 " (in *Sock (line T))) (out *Sock (prinl "MAIL FROM:" *MailingList "^M")) (pre? "250 " (in *Sock (line T))) ) (quit "Can't HELO") ) (when (= "subscribe" (lowc *Subject)) (push1 '*Mailings *From) (out "Mailings" (mapc prinl *Mailings)) ) (for To *Mailings (out *Sock (prinl "RCPT TO:" To "^M")) (unless (pre? "250 " (in *Sock (line T))) (msg T " can't mail") ) ) (when (and (out *Sock (prinl "DATA^M")) (pre? "354 " (in *Sock (line T)))) (out *Sock (prinl "From: " (or *Name *From) "^M") (prinl "Sender: " *MailingList "^M") (prinl "Reply-To: " *MailingList "^M") (prinl "To: " *MailingList "^M") (prinl "Subject: " *Subject "^M") (and *Date (prinl "Date: " @ "^M")) (and *MessageID (prinl "Message-ID: " @ "^M")) (and *InReplyTo (prinl "In-Reply-To: " @ "^M")) (and *MimeVersion (prinl "MIME-Version: " @ "^M")) (and *ContentType (prinl "Content-Type: " @ "^M")) (and *ContentTransferEncoding (prinl "Content-Transfer-Encoding: " @ "^M")) (and *ContentDisposition (prinl "Content-Disposition: " @ "^M")) (and *UserAgent (prinl "User-Agent: " @ "^M")) (prinl "^M") (cond ((= "subscribe" (lowc *Subject)) (prinl "Hello " (or *Name *From) " :-)^M") (prinl "You are now subscribed^M") (prinl "****^M^J^M") ) ((= "unsubscribe" (lowc *Subject)) (out "Mailings" (mapc prinl (del *From '*Mailings)) ) (prinl "Good bye " (or *Name *From) " :-(^M") (prinl "You are now unsubscribed^M") (prinl "****^M^J^M") ) ) (echo "^JFrom ") (prinl "-- ^M") (prinl "UNSUBSCRIBE: mailto:" *MailingList "?subject=Unsubscribe^M") (prinl ".^M") (prinl "QUIT^M") ) ) (close *Sock) ) ) ) (out *SpoolFile (rewind)) ) ) (call "fetchmail" "-as") (wait `(* 4 60 1000)) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/maze.l0000644000000000000000000000213012265263724015210 0ustar rootroot# 27feb13abu # (c) Software Lab. Alexander Burger # ./pil misc/maze.l -"setq M (maze 16 12)" -"display M" -bye (load "@lib/simul.l") (de maze (DX DY) (let Maze (grid DX DY) (let Fld (get Maze (rand 1 DX) (rand 1 DY)) (recur (Fld) (for Dir (shuffle '((west . east) (east . west) (south . north) (north . south))) (with ((car Dir) Fld) (unless (or (: west) (: east) (: south) (: north)) (put Fld (car Dir) This) (put This (cdr Dir) Fld) (recurse This) ) ) ) ) ) (for (X . Col) Maze (for (Y . This) Col (set This (cons (cons (: west) (or (: east) (and (= Y 1) (= X DX)) ) ) (cons (: south) (or (: north) (and (= X 1) (= Y DY)) ) ) ) ) ) ) Maze ) ) (de display (Maze) (disp Maze 0 '((This) " ")) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/pi.l0000644000000000000000000000101212265263724014662 0ustar rootroot# 16jun11abu # (c) Software Lab. Alexander Burger ############################## # Iterative calculation of PI: # S = 0 # P = 2 # Loop # S = sqrt(S+2) # P = 2*P/S ############################## (de pi (N Eps) (default N *Scl Eps 100) (let (Scl (** 10 N) S 0 N2 (* 2 Scl) P N2 P2 0) (while (> (- P P2) Eps) (setq P2 P S (sqrt (* Scl (+ S N2))) P (*/ N2 P S) ) ) ) ) (test 3141592653589793238462643383279502884197169399375105820975043 (pi 60) ) picolisp-3.1.5.2.orig/misc/piDigits.l0000644000000000000000000000133612265263724016037 0ustar rootroot# 16jun11abu # (c) Software Lab. Alexander Burger # Spigot algorithm (Jeremy Gibbons) # Print next digit of PI (unbounded) (de piDigit () (job '((Q . 1) (R . 0) (S . 1) (K . 1) (N . 3) (L . 3)) (while (>= (- (+ R (* 4 Q)) S) (* N S)) (mapc set '(Q R S K N L) (list (* Q K) (* L (+ R (* 2 Q))) (* S L) (inc K) (/ (+ (* Q (+ 2 (* 7 K))) (* R L)) (* S L)) (+ 2 L) ) ) ) (prog1 N (let M (- (/ (* 10 (+ R (* 3 Q))) S) (* 10 N)) (setq Q (* 10 Q) R (* 10 (- R (* N S))) N M) ) ) ) ) # Print _all_ digits of PI (prin (piDigit) ".") (loop (prin (piDigit)) (flush) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/rcsim.l0000644000000000000000000004667112265263724015413 0ustar rootroot# 15apr13abu # (c) Software Lab. Alexander Burger ### RC Flight Simulator for 64-bit PicoLisp ### # *FocLen *Scene *Model # *DT *Throttle *Speed *Altitude (scl 6) # Keep in sync with `SCL' in C lib (load "@lib/z3d.l" "@lib/term.l") # Color Constant Definitions from "/usr/lib/X11/rgb.txt" (def 'Black (hex "000000")) (def 'Blue (hex "0000FF")) (def 'Brown (hex "A52A2A")) (def 'DarkGreen (hex "006400")) (def 'DarkGrey (hex "A9A9A9")) (def 'Grey (hex "BEBEBE")) (def 'LightBlue (hex "ADD8E6")) (def 'Red (hex "FF0000")) (def 'Yellow (hex "FFFF00")) (def 'White (hex "FFFFFF")) # Create model (de model (Obj Lst Pos) (default Pos `(* 8 12)) (apply struct (conc (extract # Faces '((M) (unless (and (car M) (sym? @)) (inc 'Pos 8) (cons (struct (native "@" "malloc" 'N (+ `(* 4 4) (* 8 (length (cddr M)))) ) 'N (cons (or (num? (car M)) `(hex "1000000")) 4) (cons (or (num? (cadr M)) (if (cadr M) `(hex "2000000") `(hex "1000000") ) ) 4 ) (- (/ (length (cddr M)) 3)) -42 (cons 1.0 (cddr M)) ) 8 ) ) ) (cddddr Lst) ) (cons (0 . 8)) (extract # Submodels '((M) (when (and (car M) (sym? @)) (inc 'Pos 8) (cons (if (cdr M) (model Obj M Pos) (put Obj (car M) Pos) 0 ) 8 ) ) ) (cddddr Lst) ) '((0 . 8)) ) (put Obj (pop 'Lst) (native "@" "malloc" 'N (+ `(* 8 12) (* 8 (length (cdr Lst)))) ) ) # (+ 2 CDDDR) 'N # Return structure pointer (cons 1.0 (head 3 Lst)) # pos (1.0 1.0 0.0 0.0 0.0 1.0 0.0 0.0 0.0 1.0) ) ) # rot # Simulation (de *DT . 0.020) (de *Tower . 12.0) (de MUL Args (let D 1.0 (make (link '*/ (pop 'Args) (pop 'Args)) (while Args (setq D (* D 1.0)) (link (pop 'Args)) ) (link D) ) ) ) (de damp ("Var" Val) (set "Var" (>> 1 (+ Val (val "Var")))) ) (class +Model) # mass power rc lc tx tz pitch torq stab # body leftAileron rightAileron rudder elevator propeller blade disk # ele ail rud thr thrust vx vy vz fx fy fz dx dy dz (dm T () (=: mass 910.0) # kg (=: power 3924.0) # N (=: rc -1.4) # kg/m (=: lc -250.0) # kg/m (=: trim 30) # Trimmung (=: lim1 0.8) # tan(a) (=: lim2 0.24) (=: tx 1.2) # Touchdown (=: tz -1.9) (=: pitch 0.26) (=: torq -10000.0) # Drehmoment (=: stab (0.01 0.01 0.02)) # Stabilitaet (model This '(body 0.0 0.0 1.50 # Flaeche oben (`Blue `Blue -0.15 +0.30 +1.05 +1.20 0.00 +1.05 +1.20 +3.90 +1.05 +0.90 +4.20 +1.05 -0.20 +3.90 +1.05 -0.60 +2.20 +1.05 -0.60 +0.60 +1.05) (`Blue `Blue -0.60 -0.60 +1.05 -0.60 -2.20 +1.05 -0.20 -3.90 +1.05 +0.90 -4.20 +1.05 +1.20 -3.90 +1.05 +1.20 0.00 +1.05 -0.15 -0.30 +1.05) (`Blue `Blue +1.20 0.00 +1.05 -0.15 -0.30 +1.05 -0.15 +0.30 +1.05) # Querruder (rightAileron -0.60 +2.20 +1.05 (`Red `Red +0.40 +1.70 0.00 +0.72 +1.78 0.00 +0.72 +1.90 0.00 +0.40 +2.10 0.00 0.00 +1.80 0.00 0.00 +1.70 0.00) (`Red `Red +0.40 +1.70 0.00 0.00 +1.70 0.00 0.00 0.00 0.00) ) (leftAileron -0.60 -2.20 +1.05 (`Red `Red +0.40 -1.70 0.00 +0.72 -1.78 0.00 +0.72 -1.90 0.00 +0.40 -2.10 0.00 0.00 -1.80 0.00 0.00 -1.70 0.00) (`Red `Red +0.40 -1.70 0.00 0.00 -1.70 0.00 0.00 0.00 0.00) ) # Flaeche rechts unten (`Blue `Blue +0.90 +0.20 -0.60 +0.90 +3.90 -0.30 +0.60 +4.20 -0.30 -0.90 +3.90 -0.30 -0.90 +0.20 -0.60) # Flaeche links unten (`Blue `Blue -0.90 -0.20 -0.60 -0.90 -3.90 -0.30 +0.60 -4.20 -0.30 +0.90 -3.90 -0.30 +0.90 -0.20 -0.60) # Streben links (`Brown `Brown -0.20 -2.55 +1.05 -0.50 -2.55 -0.37 -0.60 -2.55 -0.37 -0.30 -2.55 +1.05) (`Brown `Brown -0.50 -2.55 -0.37 -0.50 -2.55 -0.37 +0.80 -2.55 +0.90 +0.80 -2.55 +1.05) (`Brown `Brown +0.90 -2.55 +1.05 +0.60 -2.55 -0.37 +0.50 -2.55 -0.37 +0.80 -2.55 +1.05) # Streben rechts (`Brown `Brown -0.20 +2.55 +1.05 -0.50 +2.55 -0.37 -0.60 +2.55 -0.37 -0.30 +2.55 +1.05) (`Brown `Brown -0.50 +2.55 -0.37 -0.50 +2.55 -0.37 +0.80 +2.55 +0.90 +0.80 +2.55 +1.05) (`Brown `Brown +0.90 +2.55 +1.05 +0.60 +2.55 -0.37 +0.50 +2.55 -0.37 +0.80 +2.55 +1.05) # Motorlager (`Grey NIL +1.80 +0.30 +0.30 +1.80 -0.30 +0.30 +1.80 -0.30 -0.30 +1.80 +0.30 -0.30) # Rumpfnase (`Blue NIL +1.20 0.00 +0.60 +1.80 -0.30 +0.30 +1.80 +0.30 +0.30) (`Blue NIL +1.20 0.00 +0.60 +1.20 -0.45 +0.30 +1.80 -0.30 +0.30) (`Blue NIL +1.80 +0.30 +0.30 +1.20 +0.45 +0.30 +1.20 0.00 +0.60) (`Blue NIL +1.20 -0.45 +0.30 +1.20 -0.45 -0.30 +1.80 -0.30 -0.30 +1.80 -0.30 +0.30) (`Blue NIL +1.80 +0.30 +0.30 +1.80 +0.30 -0.30 +1.20 +0.45 -0.30 +1.20 +0.45 +0.30) (`Blue NIL +1.20 -0.45 -0.30 +1.20 -0.30 -0.60 +1.80 -0.30 -0.30) (`Blue NIL +1.80 +0.30 -0.30 +1.20 +0.30 -0.60 +1.20 +0.45 -0.30) (`Blue NIL +1.20 -0.30 -0.60 +1.20 +0.30 -0.60 +1.80 +0.30 -0.30 +1.80 -0.30 -0.30) # Rumpfseite rechts (`Red NIL +1.20 +0.45 +0.30 +1.20 +0.45 -0.30 -1.50 +0.45 -0.30 -1.50 +0.45 +0.30 -1.20 +0.45 +0.45 -0.90 +0.45 +0.45) (`Red NIL -1.50 +0.45 +0.30 -1.50 +0.45 -0.30 -4.80 0.00 -0.30 -4.80 0.00 0.00) # Rumpfseite links (`Red NIL -0.90 -0.45 +0.45 -1.20 -0.45 +0.45 -1.50 -0.45 +0.30 -1.50 -0.45 -0.30 +1.20 -0.45 -0.30 +1.20 -0.45 +0.30) (`Red NIL -4.80 0.00 0.00 -4.80 0.00 -0.30 -1.50 -0.45 -0.30 -1.50 -0.45 +0.30) # Rumpfoberteil vorne (`Red NIL +1.20 0.00 +0.60 +1.20 +0.45 +0.30 -0.90 +0.45 +0.45 -0.60 0.00 +0.60) (`Red NIL -0.60 0.00 +0.60 -0.90 -0.45 +0.45 +1.20 -0.45 +0.30 +1.20 0.00 +0.60) # Cockpit (`Brown NIL -0.60 0.00 +0.60 -0.90 +0.45 +0.45 -0.90 -0.45 +0.45) (`Black NIL -0.90 +0.45 +0.45 -1.20 +0.45 +0.45 -1.20 -0.45 +0.45 -0.90 -0.45 +0.45) (`Black NIL -1.20 +0.45 +0.45 -1.35 0.00 +0.54 -1.20 -0.45 +0.45) # Rumpfoberteil hinten (`Red NIL -1.35 0.00 +0.54 -1.20 +0.45 +0.45 -4.80 0.00 0.00) (`Red NIL -1.20 +0.45 +0.45 -1.50 +0.45 +0.30 -4.80 0.00 0.00) (`Red NIL -4.80 0.00 0.00 -1.20 -0.45 +0.45 -1.35 0.00 +0.54) (`Red NIL -4.80 0.00 0.00 -1.50 -0.45 +0.30 -1.20 -0.45 +0.45) # Rumpfboden (`Red NIL +1.20 +0.45 -0.30 +1.20 +0.30 -0.60 -1.50 +0.30 -0.60 -1.50 +0.45 -0.30) (`Red NIL +1.20 +0.30 -0.60 +1.20 -0.30 -0.60 -1.50 -0.30 -0.60 -1.50 +0.30 -0.60) (`Red NIL -1.50 -0.45 -0.30 -1.50 -0.30 -0.60 +1.20 -0.30 -0.60 +1.20 -0.45 -0.30) (`Red NIL -4.80 0.00 -0.30 -1.50 -0.30 -0.60 -1.50 -0.45 -0.30) (`Red NIL -4.80 0.00 -0.30 -1.50 +0.30 -0.60 -1.50 -0.30 -0.60) (`Red NIL -1.50 +0.45 -0.30 -1.50 +0.30 -0.60 -4.80 0.00 -0.30) # Hoehenleitwerk (`Red `Red -3.60 +0.15 0.00 -4.20 +1.80 0.00 -4.50 +1.80 0.00 -4.50 +0.06 0.00) (`Red `Red -4.50 -0.06 0.00 -4.50 -1.80 0.00 -4.20 -1.80 0.00 -3.60 -0.15 0.00) # Hoehenruder (elevator -4.50 0.00 0.00 (`Blue `Blue 0.00 +1.80 0.00 -0.60 +1.50 0.00 -0.60 +0.60 0.00 0.00 +0.06 0.00) (`Blue `Blue 0.00 -0.06 0.00 -0.60 -0.60 0.00 -0.60 -1.50 0.00 0.00 -1.80 0.00) ) # Seitenleitwerk (`Red `Red -4.80 0.00 0.00 -3.60 0.00 +0.15 -4.20 0.00 +0.90 -4.80 0.00 +1.05) # Seitenruder (rudder -4.80 0.00 0.00 (`Blue `Blue 0.00 0.00 +1.05 0.00 0.00 -0.30 -0.45 0.00 +0.30 -0.45 0.00 +0.90) ) # Schatten Nase (NIL T +0.90 -0.30 -0.20 +1.70 0.00 -0.20 +0.90 +0.30 -0.20) # Schatten Flaechen (NIL T +0.90 -3.00 -0.20 +0.90 +3.00 -0.20 -0.90 +3.00 -0.20 -0.90 -3.00 -0.20) # Schatten Rumpf (NIL T -0.90 -0.40 -0.20 -0.90 +0.40 -0.20 -4.70 0.00 -0.20) # Schatten Leitwerk (NIL T -3.60 0.00 -0.20 -4.20 +1.80 -0.20 -4.50 +1.80 -0.20 -4.50 -1.80 -0.20 -4.20 -1.80 -0.20) # Spinner (`Blue NIL +1.80 +0.15 -0.15 +1.80 +0.15 +0.15 +2.10 0.00 0.00) (`Blue NIL +1.80 -0.15 -0.15 +1.80 +0.15 -0.15 +2.10 0.00 0.00) (`Blue NIL +1.80 -0.15 +0.15 +1.80 -0.15 -0.15 +2.10 0.00 0.00) (`Blue NIL +1.80 +0.15 +0.15 +1.80 -0.15 +0.15 +2.10 0.00 0.00) # Fahrwerk (`Grey `Grey +1.20 +0.30 -0.60 +1.20 +0.90 -1.47 +1.20 +1.00 -1.47 +1.20 +0.40 -0.60) (`Grey `Grey +1.20 -0.30 -0.60 +1.20 -0.90 -1.47 +1.20 -1.00 -1.47 +1.20 -0.40 -0.60) (`Grey `Grey +1.20 -1.20 -1.47 +1.20 -1.20 -1.53 +1.20 +1.20 -1.53 +1.20 +1.20 -1.47) (`Grey `Grey +1.20 +0.90 -1.53 +1.20 +0.90 -1.47 +0.30 +0.30 -0.60 +0.18 +0.30 -0.60) (`Grey `Grey +1.20 -0.90 -1.53 +1.20 -0.90 -1.47 +0.30 -0.30 -0.60 +0.18 -0.30 -0.60) # Rad rechts (`Yellow `Yellow +1.20 +1.20 -1.20 +1.38 +1.20 -1.25 +1.50 +1.20 -1.37 +1.55 +1.20 -1.55 +1.50 +1.20 -1.73 +1.38 +1.20 -1.85 +1.20 +1.20 -1.90 +1.02 +1.20 -1.85 +0.90 +1.20 -1.72 +0.85 +1.20 -1.55 +0.90 +1.20 -1.37 +1.02 +1.20 -1.25) # Schatten Rad rechts (NIL T +1.60 +1.00 -1.55 +1.60 +1.40 -1.55 +0.80 +1.40 -1.55 +0.80 +1.00 -1.55) # Rad links (`Yellow `Yellow +1.20 -1.20 -1.20 +1.38 -1.20 -1.25 +1.50 -1.20 -1.37 +1.55 -1.20 -1.55 +1.50 -1.20 -1.73 +1.38 -1.20 -1.85 +1.20 -1.20 -1.90 +1.02 -1.20 -1.85 +0.90 -1.20 -1.72 +0.85 -1.20 -1.55 +0.90 -1.20 -1.37 +1.02 -1.20 -1.25) # Schatten Rad links (NIL T +1.60 -1.00 -1.55 +1.60 -1.40 -1.55 +0.80 -1.40 -1.55 +0.80 -1.00 -1.55) # Platzhalter (propeller) ) ) (model This '(blade +1.95 0.00 0.00 (`Black `Black -0.05 0.00 0.00 +0.05 0.00 0.00 +0.02 +0.40 -0.50 +0.00 +0.90 -0.90 -0.02 +0.50 -0.40 -0.05 0.00 0.00 -0.02 -0.50 +0.40 +0.00 -0.90 +0.90 +0.02 -0.40 +0.50 +0.05 0.00 0.00) ) ) (model This '(disk +1.95 0.00 0.00 (NIL NIL +0.00 -0.30 +1.20 +0.00 -0.90 +0.90 +0.00 -1.20 +0.30 +0.00 -1.20 -0.30 +0.00 -0.90 -0.90 +0.00 -0.30 -1.20 +0.00 +0.30 -1.20 +0.00 +0.90 -0.90 +0.00 +1.20 -0.30 +0.00 +1.20 +0.30 +0.00 +0.90 +0.90 +0.00 +0.30 +1.20) ) ) (=: ele (=: ail (=: rud (=: thr (=: thrust 0))))) (=: vx (=: vy (=: vz 0))) (=: fx (=: fy (=: fz 0))) (=: dx (=: dy (=: dz 0))) (z3dDX (: body) -100.0) (z3dDY (: body) -200.0) (z3dYrot (: body) 0.26) (inc (:: propeller) (: body)) (=: blade (cons (: blade) 8)) (=: disk (cons (: disk) 8)) (struct (: propeller) NIL (: blade)) ) (dm dir> (VarX VarY) (let B (struct (: body) (1.0 . 3)) (z3dSpot VarX VarY (+ (car B) (>> 3 (: vx)) (>> 2 (: vz))) (+ (cadr B) (>> 3 (: vy)) (>> 2 (: vz))) (- (+ (caddr B) (>> 3 (: vz)) (>> 2 (: vz))) *Tower ) ) ) ) (dm down> () (when (> (: ele) -100) (dec (:: ele) 20) (z3dArot (: elevator) +0.2) ) ) (dm up> () (when (> 100 (: ele)) (inc (:: ele) 20) (z3dArot (: elevator) -0.2) ) ) (dm left> () (when (> (: ail) -100) (dec (:: ail) 20) (dec (:: rud) 20) (z3dArot (: leftAileron) +0.2) (z3dArot (: rightAileron) +0.2) (z3dArot (: rudder) +0.2) ) ) (dm right> () (when (> 100 (: ail)) (inc (:: ail) 20) (inc (:: rud) 20) (z3dArot (: leftAileron) -0.2) (z3dArot (: rightAileron) -0.2) (z3dArot (: rudder) -0.2) ) ) (dm throt> (X) (=: thr (cond ((not X) 0) ((=T X) 100) ((lt0 X) (max 10 (- (: thr) 25))) ((=0 (: thr)) 10) ((= 10 (: thr)) 25) (T (min 100 (+ 25 (: thr)))) ) ) ) (dm sim> () (cond ((gt0 (: ele)) (dec (:: ele)) (z3dArot (: elevator) +0.01) ) ((lt0 (: ele)) (inc (:: ele)) (z3dArot (: elevator) -0.01) ) ) (cond ((gt0 (: ail)) (dec (:: ail)) (dec (:: rud)) (z3dArot (: leftAileron) +0.01) (z3dArot (: rightAileron) +0.01) (z3dArot (: rudder) +0.01) ) ((lt0 (: ail)) (inc (:: ail)) (inc (:: rud)) (z3dArot (: leftAileron) -0.01) (z3dArot (: rightAileron) -0.01) (z3dArot (: rudder) -0.01) ) ) (cond ((> (: thr) (: thrust)) (inc (:: thrust)) ) ((> (: thrust) (: thr)) (dec (:: thrust)) ) ) (struct (: propeller) NIL (if (> 20 (: thrust)) (: blade) (: disk) ) ) (unless (=0 (: thrust)) (z3dXrot (if (> 20 (: thrust)) (: blade 1) (: disk 1) ) 0.2 ) ) (use (Touch VX VY VZ Body Taxi Stick A FX FY FZ DX DY DZ) (z3dRotate (: body) (: tx) 0 (: tz) NIL NIL 'Touch) (z3dRotate (: body) (: vx) (: vy) (: vz) 'VX 'VY 'VZ T) (setq Body (struct (: body) (1.0 . 12)) Taxi (> 0.1 (+ (caddr Body) Touch)) Stick (>= 1.0 (+ VX VY)) FX (+ (*/ (: thrust) (: power) 100) `(MUL (: rc) VX (abs VX))) FZ (+ (cond ((> 0.1 VX) 0) ((> (abs (setq A (*/ 1.0 VZ VX))) (: lim2)) 0 ) ((>= (: lim1) A) `(MUL VX VX (: lc) A) ) (T `(MUL VX VX (: lc) (- (: lim2) A))) ) `(MUL 8.0 (: rc) VZ (abs VZ)) ) ) (ifn Taxi (setq FY `(MUL 4.0 (: rc) VY (abs VY))) (let F (>> 2 (: mass)) (cond ((> 0.1 (abs VX)) (and (>= F FX) (zero FX)) ) ((gt0 VX) (dec 'FX F) ) (T (inc 'FX F)) ) (setq FY (if (lt0 VY) (* 12 F) (* -12 F))) ) (z3dYrot (: body) (>> 3 (- (: pitch) (get Body 6))) ) ) # rot.a.z (unless Stick (z3dYrot (: body) (+ (*/ VX (+ (: ele) (: trim)) 80000) `(MUL VZ (: stab 2)) ) ) (if Taxi (prog (z3dZrot (: body) (*/ VX (: rud) 80000)) (z3dXrot (: body) (get Body 9)) ) # rot.b.z (z3dXrot (: body) # roll (+ (- (*/ VX (: ail) 80000) (/ VY 400)) (*/ (: thrust) (: torq) (: mass)) `(MUL (get Body 9) (: stab 1)) ) ) # rot.b.z (z3dZrot (: body) (+ (*/ VX (: rud) 80000) `(MUL VY (: stab 3)) ) ) ) ) # World system (z3dRotate (: body) FX FY FZ 'FX 'FY 'FZ) (dec 'FZ `(MUL (: mass) 9.81)) # Accelerate (setq A (*/ 1.0 *DT (: mass)) DX `(MUL A (damp (:: fx) FX)) DY `(MUL A (damp (:: fy) FY)) DZ `(MUL A (damp (:: fz) FZ)) ) (if (and Stick (> 0.001 (+ `(MUL DX DX) `(MUL DY DY)))) (=: vx (=: vy (=: dx (=: dy 0)))) (inc (:: vx) (damp (:: dx) DX)) (inc (:: vy) (damp (:: dy) DY)) ) (inc (:: vz) (damp (:: dz) DZ)) (when (and Taxi (lt0 (: vz))) (when (> -6.0 (: vz)) (=: thr (=: thrust 0)) (=: vx (=: vy 0)) (struct (: propeller) NIL (: blade)) ) (z3dZ (: body) (- Touch)) (=: vz 0) ) # Translate (z3dDX (: body) `(MUL (: vx) *DT)) (z3dDY (: body) `(MUL (: vy) *DT)) (z3dDZ (: body) `(MUL (: vz) *DT)) # Instruments (setq *Throttle (: thr) *Speed (*/ VX 3.6 `(* 1.0 1.0)) *Altitude (/ (caddr Body) 1.0) ) ) ) (dm draw> () (z3dDraw (: body)) ) # Scene (class +Scene) # env (dm T () (model This '(runway1 -120.0 -200.0 -0.02 (`DarkGrey NIL +20.0 -20.0 0 +20.0 +20.0 0 -20.0 +20.0 0 -20.0 -20.0 0) (`White NIL +10.0 -1.0 0 +10.0 +1.0 0 -10.0 +1.0 0 -10.0 -1.0 0) ) ) (model This '(runway2 -80.0 -200.0 -0.02 (`DarkGrey NIL +20.0 -20.0 0 +20.0 +20.0 0 -20.0 +20.0 0 -20.0 -20.0 0) (`White NIL +10.0 -1.0 0 +10.0 +1.0 0 -10.0 +1.0 0 -10.0 -1.0 0) ) ) (model This '(runway3 -40.0 -200.0 -0.02 (`DarkGrey NIL +20.0 -20.0 0 +20.0 +20.0 0 -20.0 +20.0 0 -20.0 -20.0 0) (`White NIL +10.0 -1.0 0 +10.0 +1.0 0 -10.0 +1.0 0 -10.0 -1.0 0) ) ) (model This '(runway4 0.0 -200.0 -0.02 (`DarkGrey NIL +20.0 -20.0 0 +20.0 +20.0 0 -20.0 +20.0 0 -20.0 -20.0 0) (`White NIL +10.0 -1.0 0 +10.0 +1.0 0 -10.0 +1.0 0 -10.0 -1.0 0) ) ) (model This '(runway5 +40.0 -200.0 -0.02 (`DarkGrey NIL +20.0 -20.0 0 +20.0 +20.0 0 -20.0 +20.0 0 -20.0 -20.0 0) (`White NIL +10.0 -1.0 0 +10.0 +1.0 0 -10.0 +1.0 0 -10.0 -1.0 0) ) ) (model This '(runway6 +80.0 -200.0 -0.02 (`DarkGrey NIL +20.0 -20.0 0 +20.0 +20.0 0 -20.0 +20.0 0 -20.0 -20.0 0) (`White NIL +10.0 -1.0 0 +10.0 +1.0 0 -10.0 +1.0 0 -10.0 -1.0 0) ) ) (model This '(runway7 +120.0 -200.0 -0.02 (`DarkGrey NIL +20.0 -20.0 0 +20.0 +20.0 0 -20.0 +20.0 0 -20.0 -20.0 0) (`White NIL +10.0 -1.0 0 +10.0 +1.0 0 -10.0 +1.0 0 -10.0 -1.0 0) ) ) (=: env (list (: runway1) (: runway2) (: runway3) (: runway4) (: runway5) (: runway6) (: runway7) ) ) ) (dm sim> ()) (dm draw> () (mapc z3dDraw (: env)) ) # Key Controls (fkey *XtIns (and (> 32000.0 *FocLen) (setq *FocLen (>> -1 *FocLen)))) (fkey *XtDel (and (> *FocLen 2000.0) (setq *FocLen (>> 1 *FocLen)))) (fkey *XtUp (down> *Model)) (fkey *XtDown (up> *Model)) (fkey *XtLeft (left> *Model)) (fkey *XtRight (right> *Model)) (fkey *XtHome (throt> *Model T)) (fkey *XtPgDn (throt> *Model -1)) (fkey *XtPgUp (throt> *Model +1)) (fkey *XtEnd (throt> *Model)) # Init/Run (de main () (setq *FocLen 8000.0 *Scene (new '(+Scene)) *Model (new '(+Model)) ) ) (de go () (when (z3dWindow "RC Simulator" 800 600) (quit @) ) (zero "MSec") (task `(*/ -1000 *DT 1.0) 0 # -Milliseconds (let R (assoc @ *Run) (sim> *Scene) (sim> *Model) (use (Yaw Pitch) (dir> *Model 'Yaw 'Pitch) (z3dCamera *FocLen Yaw Pitch 0 0 *Tower LightBlue DarkGreen) ) (draw> *Scene) (draw> *Model) (z3dPut) (z3dText 20 580 (pack *Throttle " %")) (z3dText 120 580 (pack *Speed " km/h")) (z3dText 220 580 (pack *Altitude " m")) (z3dText 320 580 (case *FocLen (2000.0 "(--)") (4000.0 "(-)") (16000.0 "(+)") (32000.0 "(++)") ) ) (z3dSync) (let M (*/ (usec) 1000) (setq "MSec" (- M (set (cdr R) (min -2 (- M "MSec" `(*/ 1000 *DT 1.0))) ) ) ) ) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/reverse.l0000644000000000000000000000037312265263724015736 0ustar rootroot# 19dec05abu # (c) Software Lab. Alexander Burger (setq *Port (port 6789)) (loop (setq *Sock (listen *Port)) (NIL (fork) (close *Port)) (close *Sock) ) (in *Sock (until (eof) (out *Sock (prinl (flip (line))) ) ) ) (bye) picolisp-3.1.5.2.orig/misc/setf.l0000644000000000000000000000146312265263724015225 0ustar rootroot# 31jan08abu # (c) Software Lab. Alexander Burger # 'setf' is the most perverse concept ever introduced into Lisp (de setf "Args" (let "P" (car "Args") (set (if (atom "P") "P" (let (: :: get prop car prog cadr cdr caddr cadr cadddr caddr) (eval "P") ) ) (eval (cadr "Args")) ) ) ) ### Test ### (test 7 (use A (setf A 7) A ) ) (test (7 2 3) (let L (1 2 3) (setf (car L) 7) L ) ) (test (1 7 3) (let L (1 2 3) (setf (cadr L) 7) L ) ) (test 7 (put 'A 'a 1) (setf (get 'A 'a) 7) (get 'A 'a) ) (test 7 (put 'A 'a 1) (with 'A (setf (: a) 7) (: a) ) ) # But also: (undef 'foo) (de foo (X) (cadr X) ) (test (1 7 3) (let L (1 2 3) (setf (foo L) 7) L) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/sieve.l0000644000000000000000000000047012265263724015374 0ustar rootroot# 25feb10abu # (c) Software Lab. Alexander Burger # Sieve of Eratosthenes (de sieve (N) (let Sieve (range 1 N) (set Sieve) (for I (cdr Sieve) (when I (for (S (nth Sieve (* I I)) S (nth (cdr S) I)) (set S) ) ) ) (filter bool Sieve) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/misc/stress.l0000644000000000000000000000307712265263724015612 0ustar rootroot# 25may11abu # (c) Software Lab. Alexander Burger # Use: nice pil misc/stress.l -main -go -bye; rm db/test jnl db/test2 (load "@lib/too.l") (class +A +Entity) (rel key (+Key +Number)) # Key 1 .. 999 (rel dat (+Ref +Number)) # Data 1 .. 999 (de rnd () (rand 1 999) ) (de modify (N) (do N (do (rand 10 40) (let K (rnd) (with (db 'key '+A K) (unless (= K (: key)) (quit "key mismatch" K) ) ) ) ) (dbSync) (let (D (rnd) X (db 'key '+A (rnd))) (inc *DB (- D (get X 'dat))) (put> X 'dat D) ) (commit 'upd) ) ) (de verify () (dbCheck) (let N 0 (scan (tree 'dat '+A) '((K V) (unless (= (car K) (get V 'dat)) (quit "dat mismatch" K) ) (inc 'N (car K)) ) ) (unless (= N (val *DB)) (quit "val mismatch" (- N (val *DB))) ) ) ) (de main () (seed (in "/dev/urandom" (rd 8))) (call 'mkdir "-p" "db") (call 'rm "-f" "db/test" "jnl" "db/test2") (pool "db/test" NIL "jnl") (set *DB 0) (for K 999 (let D (rnd) (new T '(+A) 'key K 'dat D) (inc *DB D) ) ) (commit) ) (de go () (do 10 (let Pids (make (do 40 (rand) (if (fork) (link @) (modify 999) (bye) ) ) ) (while (find '((P) (kill P 0)) Pids) (wait 1000) ) (rollback) ) ) (verify) (pool "db/test2") (journal "jnl") (call 'cmp "db/test" "db/test2") ) picolisp-3.1.5.2.orig/misc/travel.l0000644000000000000000000000242012265263724015553 0ustar rootroot# 22oct03abu # (c) Software Lab. Alexander Burger (de travel (A B) (mini car (solve (quote @A A @B B (path @A @B @P @N) ) (cons @N @P) ) ) ) (be path (@A @B @P @N) (path1 @A @B (@A) @P @N)) (be path1 (@A @A @L (@A) 0)) (be path1 (@A @B @L (@A . @P) @N) (edge @A @Z @X) (not (member @Z @L)) (path1 @Z @B (@Z . @L) @P @Y) (@N + (-> @X) (-> @Y)) ) (be edge (@A @B @N) (vect @A @B @N)) (be edge (@A @B @N) (vect @B @A @N)) (be vect (Rheine Muenster 39)) (be vect (Rheine Osnabrueck 42)) (be vect (Muenster Osnabrueck 51)) (be vect (Warendorf Muenster 28)) (be vect (Warendorf Osnabrueck 43)) (be vect (Warendorf Rheda 24)) (be vect (Warendorf Guetersloh 27)) (be vect (Osnabrueck Bielefeld 48)) (be vect (Rheda Guetersloh 10)) (be vect (Bielefeld Guetersloh 16)) (be vect (Bielefeld Paderborn 39)) (be vect (Paderborn Guetersloh 31)) (be vect (Paderborn Rheda 32)) (be vect (Paderborn Soest 41)) (be vect (Soest Rheda 38)) (be vect (Soest Beckum 26)) (be vect (Beckum Rheda 24)) (be vect (Beckum Warendorf 27)) (be vect (Ahlen Warendorf 27)) (be vect (Ahlen Muenster 46)) (be vect (Ahlen Beckum 11)) (be vect (Ahlen Soest 27)) (test '(123 Rheine Muenster Warendorf Rheda Paderborn) (travel 'Rheine 'Paderborn) ) picolisp-3.1.5.2.orig/misc/trip.l0000644000000000000000000000432012265263724015235 0ustar rootroot# 25may11abu # (c) Software Lab. Alexander Burger (load "@lib/simul.l") # Set up distance properties # See "misc/travel.l" and "doc/travel" (mapc '((L) (put (car L) (cadr L) (caddr L)) (put (cadr L) (car L) (caddr L)) ) (quote (Rheine Muenster 39) (Rheine Osnabrueck 42) (Muenster Osnabrueck 51) (Warendorf Muenster 28) (Warendorf Osnabrueck 43) (Warendorf Rheda 24) (Warendorf Guetersloh 27) (Osnabrueck Bielefeld 48) (Rheda Guetersloh 10) (Bielefeld Guetersloh 16) (Bielefeld Paderborn 39) (Paderborn Guetersloh 31) (Paderborn Rheda 32) (Paderborn Soest 41) (Soest Rheda 38) (Soest Beckum 26) (Beckum Rheda 24) (Beckum Warendorf 27) (Ahlen Warendorf 27) (Ahlen Muenster 46) (Ahlen Beckum 11) (Ahlen Soest 27) ) ) # Find a route from 'A' to 'B' (de route (A B Lst) (if (get A B) (list A B) (and (pick '((X) (and (not (memq X Lst)) (route X B (cons A Lst)) ) ) (shuffle (mapcar cdr (getl A))) ) (cons A @) ) ) ) # Minimize trip from 'A' to 'B' (de trip (Pop Gen A B) (gen (make (do Pop (link (route A B)))) # Population '((Pop) (lt0 (dec 'Gen))) # Condition '((X Y) # Recombination (make (while (prog (link (pop 'X)) X) (when (member (car X) (cdr Y)) (setq Y @) (xchg 'X 'Y) ) ) ) ) '((L) # Mutation (let (N (length L) H (>> 1 N) N1 (rand 1 H) N2 (rand (inc H) N)) (if (route (get L N1) (get L N2)) (append (head (dec N1) L) @ (nth L (inc N2)) ) L ) ) ) '((L) # Selection (let A (pop 'L) (- (sum '((X) (get A (setq A X))) L ) ) ) ) ) ) # Optimum hit percentage, e.g. (tst 12 8) (de tst (Pop Gen) (let OK 0 (do 100 (when (= (trip Pop Gen 'Rheine 'Paderborn) '(Rheine Muenster Warendorf Rheda Paderborn) ) (inc 'OK) ) ) OK ) ) picolisp-3.1.5.2.orig/opt/0000755000000000000000000000000012265263724013752 5ustar rootrootpicolisp-3.1.5.2.orig/opt/pilog.l0000644000000000000000000000053312265263724015242 0ustar rootroot# 19jul13abu # (c) Software Lab. Alexander Burger (be mapcar (@ NIL NIL)) (be mapcar (@P (@X . @L) (@Y . @M)) (call @P @X @Y) (mapcar @P @L @M) ) # Contributed by Clemens Hinze (be findall (@Pat @P @Res) (^ @Res (solve (-> @P) (or @Pat (fill (-> @Pat))) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/pil0000755000000000000000000000007612265263724013665 0ustar rootroot#!/bin/sh exec ${0%/*}/bin/picolisp ${0%/*}/lib.l @ext.l "$@" picolisp-3.1.5.2.orig/test/0000755000000000000000000000000012265263724014127 5ustar rootrootpicolisp-3.1.5.2.orig/test/lib.l0000644000000000000000000001025212265263724015052 0ustar rootroot# 30oct13abu # (c) Software Lab. Alexander Burger ### task ### (test (3 . 4) (let (*Run NIL *A NIL *B NIL) (task -10 0 (setq *A 3)) (task (port T 0 "TaskPort") (eval (udp @))) (udp "localhost" "TaskPort" '(setq *B 4)) (wait NIL (and *A *B)) (cons *A *B) ) ) ### timeout ### (test '((-1 3600000 (bye))) (let *Run NIL (timeout 3600000) *Run ) ) ### abort ### (test 6 (abort 2 (+ 1 2 3))) (test NIL (abort 2 (wait 4000))) ### macro ### (test 6 (let (@A 1 @B 2 @C 3) (macro (* @A @B @C)) ) ) ### later ### (test '((@ . 1) (@ . 4) (@ . 9) (@ . 16) (@ . 25) (@ . 36)) (prog1 (mapcan '((N) (later (cons) (cons *Pid (* N N)))) (1 2 3 4 5 6) ) (wait NIL (full @)) ) ) ### recur recurse ### (test 720 (let N 6 (recur (N) (if (=0 N) 1 (* N (recurse (dec N))) ) ) ) ) ### curry ### (test '((N) (* 7 N)) ((quote (@X) (curry (@X) (N) (* @X N))) 7) ) (test 21 (((quote (@X) (curry (@X) (N) (* @X N))) 7) 3) ) (test '((N) (job '((A . 1)) (+ A 7 N))) (let (A 1 @X 7) (curry (A @X) (N) (+ A @X N))) ) ### getd ### (test car (getd 'car)) (test '((File . @) (load File)) (getd 'script) ) (test NIL (getd 1)) ### expr subr undef ### (let foo car (test 7 (foo (7))) (test T (== 'pass (caadr (expr 'foo)))) (test car (subr 'foo)) (test car (undef 'foo)) (test NIL (val 'foo)) ) ### redef ### (let foo inc (redef foo (N) (inc (foo N))) (test 3 (foo 1)) ) ### daemon patch ### (let foo car (daemon 'foo (msg 'daemon)) (test T (= '(msg 'daemon) (cadr (getd 'foo)))) (patch foo 'daemon 'patch) (test T (= '(msg 'patch) (cadr (getd 'foo)))) ) ### scl ### (scl 0) (test 123 (any "123.45")) (scl 1) (test (1235) (scl 1 (str "123.45"))) (test 1235 (any "123.45")) (scl 3) (test 123450 (any "123.45")) ### ** ### (test 32768 (** 2 15)) (test 1 (** 123 0)) (test 0 (** 3 -1)) ### accu ### (off Sum) (test '(a . 1) (accu 'Sum 'a 1)) (test 6 (accu 'Sum 'a 5)) (test (22 . 100) (accu 'Sum 22 100)) (test '((22 . 100) (a . 6)) Sum) (test '((b . 2) (a . 3)) (let L NIL (accu 'L 'a 2) (accu 'L 'b 2) (accu 'L 'a 1) L) ) ### script ### (out (tmp "script") (println '(pass * 7)) ) (test 42 (script (tmp "script") 2 3)) ### once ### (let N 0 (test 1 (once (inc 'N)) (once (inc 'N)) N ) ) ### rc ### (let F (tmp "rc") (rc F 'a 123) (rc F 'b "test") (rc F 'c (1 2 3)) (test '((c 1 2 3) (b . "test") (a . 123)) (in F (read)) ) (test 123 (rc F 'a)) (test "test" (rc F 'b)) (test (1 2 3) (rc F 'c)) ) ### acquire release ### (let F (tmp "sema") (test *Pid (acquire F)) (test T (acquire F)) (test *Pid (in F (rd))) (test NIL (release F)) (test NIL (in F (rd))) ) ### insert ### (test '(a b 777 c d e) (insert 3 '(a b c d e) 777)) (test (777 a b c d e) (insert 1 '(a b c d e) 777)) (test '(a b c d e 777) (insert 9 '(a b c d e) 777)) ### remove ### (test '(a b d e) (remove 3 '(a b c d e))) (test '(b c d e) (remove 1 '(a b c d e))) (test '(a b c d e) (remove 9 '(a b c d e))) ### place ### (test '(a b 777 d e) (place 3 '(a b c d e) 777)) (test (777 b c d e) (place 1 '(a b c d e) 777)) (test '(a b c d e 777) (place 9 '(a b c d e) 777)) ### uniq ### (test (2 4 6 1 3 5) (uniq (2 4 6 1 2 3 4 5 6 1 3 5))) ### group ### (test '((1 a b c) (2 d e f)) (group '((1 . a) (1 . b) (1 . c) (2 . d) (2 . e) (2 . f))) ) ### qsym ### (let "A" 1234 (put '"A" 'a 1) (put '"A" 'b 2) (put '"A" 'f T) (test (1234 f (2 . b) (1 . a)) (qsym . "A") ) ) ### loc ### (let (X 'foo bar '((A B) (foo B A))) (test "foo" (zap 'foo)) (test "foo" (str? "foo")) (test T (== X (loc "foo" bar))) ) ### class ### (off "+A" "+B" "+C") (test '"+A" (class "+A" "+B" "+C")) (test '"+A" *Class) (test '("+B" "+C") "+A") ### object ### (off "Obj") (test '"Obj" (object '"Obj" '("+A" "+B" "+C") 'a 1 'b 2 'c 3) ) (test '((3 . c) (2 . b) (1 . a) (@X . *Dbg)) (getl '"Obj") ) ### extend var var: ### (test '"+B" (extend "+B")) (test T (== *Class '"+B")) (test 1 (var a . 1)) (test 2 (var b . 2)) (test '((2 . b) (1 . a)) (getl '"+B")) (with '"Obj" (test 1 (var: a)) (test 2 (var: b)) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/lib/0000755000000000000000000000000012265263724014675 5ustar rootrootpicolisp-3.1.5.2.orig/test/lib/lint.l0000644000000000000000000000071112265263724016017 0ustar rootroot# 26mar09abu # (c) Software Lab. Alexander Burger ### noLint ### (let foo '(() (bar FreeVariable)) (use *NoLint (noLint 'bar) (noLint 'foo 'FreeVariable) (test NIL (lint 'foo)) ) ) ### lint ### (let foo '((R S T R) (let N 7 (bar X Y))) (test '((var T) (dup R) (def bar) (bnd Y X) (use N)) (lint 'foo) ) ) (let foo '(() (task -6000 0 X 7 (println N))) (test '((bnd N) (use X)) (lint 'foo) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/lib/math.l0000644000000000000000000000120112265263724015775 0ustar rootroot# 31oct12abu # (c) Software Lab. Alexander Burger (scl 6) (load "@lib/math.l") ### pow ### (test 8.0 (pow 2.0 3.0)) (test 8.0 (pow 64.0 0.5)) ### exp ### (test 2.718282 (exp 1.0)) ### log ### (test 0.693147 (log 2.0)) ### sin ### (test 0.0 (sin 0.0)) (test 1.0 (sin (/ pi 2))) ### cos ### (test 1.0 (cos 0.0)) (test -1.0 (cos pi)) ### tan ### (test 0.0 (tan 0.0)) (test 0.0 (tan pi)) ### asin ### (test 0.0 (asin 0.0)) (test (/ pi 2) (asin 1.0)) ### acos ### (test 0.0 (acos 1.0)) (test pi (acos -1.0)) ### atan ### (test 0.0 (atan 0.0)) ### atan2 ### (test 0.0 (atan2 0.0 1.0)) (test (/ pi 2) (atan2 1.0 0.0)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/lib/misc.l0000644000000000000000000001015512265263724016007 0ustar rootroot# 30oct13abu # (c) Software Lab. Alexander Burger ### locale ### (locale "DE" "de") (test "Ja" (val ,"Yes")) (locale) ### align ### (test " a" (align 4 'a)) (test " a" (align 4 "a")) (test "12 " (align -4 12)) (test " a 12 b" (align (4 4 4) "a" 12 "b")) ### center ### (test " 12" (center 4 12)) (test " a" (center 4 "a")) (test " a" (center 7 'a)) (test " a b c" (center (3 3 3) "a" "b" "c")) ### wrap ### (test "The quick brown fox^Jjumps over the lazy^Jdog" (wrap 20 (chop "The quick brown fox jumps over the lazy dog")) ) (test "The^Jquick^Jbrown^Jfox^Jjumps^Jover the^Jlazy dog" (wrap 8 (chop "The quick brown fox jumps over the lazy dog")) ) ### pad ### (test "00001" (pad 5 1)) (test "123456789" (pad 5 123456789)) ### bin ### (test "1001001" (bin (+ 64 8 1))) (test (+ 64 8 1) (bin "1001001")) (test "-110110" (bin -54)) (test -54 (bin "-110110")) ### oct ### (test "111" (oct (+ 64 8 1))) (test (+ 64 8 1) (oct "111")) (test "-66" (oct -54)) (test -54 (oct "-66")) ### hex ### (test "111" (hex (+ 256 16 1))) (test (+ 256 16 1) (hex "111")) (test "-FFFF" (hex -65535)) ### money ### (test "1,234,567.89" (money 123456789)) (test "1,234,567.89 EUR" (money 123456789 "EUR")) (locale "DE" "de") (test "1.234.567,89 EUR" (money 123456789 "EUR")) (locale) ### round ### (scl 4) (test "12.35" (round 123456 2)) (test "12.3456" (round 123456 6)) (test "12.346" (round 123456)) ### balance ### (test (5 (2 (1) 3 NIL 4) 7 (6) 8 NIL 9) (let I NIL (balance 'I (sort (1 4 2 5 3 6 7 9 8))) I) ) ### *Allow allowed allow ### (allowed ("app/") "start" "stop" "lib.css" "psh" ) (allow "myFoo") (allow "myDir/" T) (test '(("psh" ("lib.css" NIL "myFoo") "start" NIL "stop") "app/" "myDir/") *Allow ) (test '("lib.css" "myFoo" "psh" "start" "stop") (idx *Allow) ) (test '("app/" "myDir/") (cdr *Allow) ) ### telStr ### (test "+49 1234 5678-0" (telStr "49 1234 5678-0")) (locale "DE" "de") (test "01234 5678-0" (telStr "49 1234 5678-0")) (locale) ### expTel ### (test "49 1234 5678-0" (expTel "+49 1234 5678-0")) (test "49 1234 5678-0" (expTel "0049 1234 5678-0")) (test NIL (expTel "01234 5678-0")) (locale "DE" "de") (test "49 1234 5678-0" (expTel "01234 5678-0")) (locale) ### dat$ ### (test "20070601" (dat$ (date 2007 6 1))) (test "2007-06-01" (dat$ (date 2007 6 1) "-")) ### $dat ### (test 733134 ($dat "20070601")) (test 733134 ($dat "2007-06-01" "-")) ### datSym ### (test "01jun07" (datSym (date 2007 6 1))) ### datStr ### (test "2007-06-01" (datStr (date 2007 6 1))) (locale "DE" "de") (test "01.06.2007" (datStr (date 2007 6 1))) (test "01.06.07" (datStr (date 2007 6 1) T)) (locale) ### strDat ### (test 733134 (strDat "2007-06-01")) (test NIL (strDat "01.06.2007")) (locale "DE" "de") (test 733134 (strDat "01.06.2007")) (test 733134 (strDat "1.6.2007")) (locale) ### expDat ### (test 733133 (date 2007 5 31)) (test 733133 (expDat "31057")) (test 733133 (expDat "310507")) (test 733133 (expDat "2007-05-31")) (test 733133 (expDat "7-5-31")) (locale "DE" "de") (test 733133 (expDat "31.5.7")) (locale) ### day ### (test "Friday" (day (date 2007 6 1))) (locale "DE" "de") (test "Freitag" (day (date 2007 6 1))) (test "Fr" (day (date 2007 6 1) '("Mo" "Tu" "We" "Th" "Fr" "Sa" "Su")) ) (locale) ### week ### (test 22 (week (date 2007 6 1))) ### ultimo ### (test (2007 1 31) (date (ultimo 2007 1))) (test (2007 2 28) (date (ultimo 2007 2))) (test (2004 2 29) (date (ultimo 2004 2))) (test (2000 2 29) (date (ultimo 2000 2))) (test (1900 2 28) (date (ultimo 1900 2))) ### tim$ ### (test "10:57" (tim$ (time 10 57 56))) (test "10:57:56" (tim$ (time 10 57 56) T)) ### $tim ### (test (10 57 56) (time ($tim "10:57:56"))) (test (10 57 0) (time ($tim "10:57"))) (test (10 0 0) (time ($tim "10"))) ### stamp ### (test "2007-06-01 10:57:56" (stamp (date 2007 6 1) (time 10 57 56)) ) ### chdir ### (let P (pwd) (chdir "/" (test "/" (pwd)) ) (test P *PWD) ) ### dirname basename ### (test "a/b/c/" (dirname "a/b/c/d")) (test "d" (basename "a/b/c/d")) ### fmt64 ### (test "9" (fmt64 9)) (test ":" (fmt64 10)) (test ";" (fmt64 11)) (test "A" (fmt64 12)) (test 4096 (fmt64 "100")) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/0000755000000000000000000000000012265263724014716 5ustar rootrootpicolisp-3.1.5.2.orig/test/src/apply.l0000644000000000000000000000450512265263724016224 0ustar rootroot# 21may10abu # (c) Software Lab. Alexander Burger ### apply ### (test 6 (apply + (1 2 3))) (test 360 (apply * (5 6) 3 4)) (test 27 (apply '((X Y Z) (* X (+ Y Z))) (3 4 5))) (test (5 7 9) (apply mapcar '((1 2 3) (4 5 6)) +)) ### pass ### (test 24 ((quote (N . @) (* N (pass + 6))) 2 1 2 3)) ### maps ### (let L '((1 . a) (2 . b) flg) (test L (let X (box) (putl X (reverse L)) (make (maps link X)))) ) ### map ### (test '((1 2 3) (2 3) (3)) (make (map link (1 2 3)))) ### mapc ### (test (1 2 3) (make (mapc link (1 2 3)))) ### maplist ### (test '(((1 2 3) A B C) ((2 3) B C) ((3) C)) (maplist cons (1 2 3) '(A B C))) ### mapcar ### (test (5 7 9) (mapcar + (1 2 3) (4 5 6))) (test (26 38 52 68) (mapcar '((X Y) (+ X (* Y Y))) (1 2 3 4) (5 6 7 8))) ### mapcon ### (test (1 2 3 4 5 2 3 4 5 3 4 5 4 5 5) (mapcon copy (1 2 3 4 5))) ### mapcan ### (test '(c b a f e d i h g) (mapcan reverse '((a b c) (d e f) (g h i)))) ### filter ### (test (1 2 3) (filter num? (1 A 2 (B) 3 CDE))) ### extract ### (let (A NIL B 1 C NIL D 2 E NIL F 3) (test (1 2 3) (extract val '(A B C D E F)) ) (test (1 2 3) (extract val '(B D E F)) ) ) ### seek ### (test (12 19 22) (seek '((X) (> (car X) 9)) (1 5 8 12 19 22))) ### find ### (test '(B) (find pair (1 A 2 (B) 3 CDE))) (test 4 (find > (1 2 3 4 5 6) (6 5 4 3 2 1))) (test 4 (find '((A B) (> A B)) (1 2 3 4 5 6) (6 5 4 3 2 1))) ### pick ### (test "Hello" (pick '((X) (get X 'str)) (list (box) (prog1 (box) (put @ 'str "Hello")) (box)) ) ) ### cnt ### (test 2 (cnt cdr '((1 . T) (2) (3 4) (5)))) ### sum ### (test 6 (sum val (list (box 1) (box) (box 2) (box 'a) (box 3)))) ### maxi mini ### (let (A 1 B 2 C 3) (test 'C (maxi val '(A B C))) (test 'A (mini val '(A B C))) (test '(A B C) (by val sort '(C A B))) ) ### fish ### (test (1 2 3) (fish gt0 '(a -2 (1 b (-3 c 2)) 3 d -1)) ) (test '(a b c d) (fish sym? '(a -2 (1 b (-3 c 2)) 3 d -1)) ) ### by ### (test '(A B C) (let (A 1 B 2 C 3) (by val sort '(C A B)) ) ) (test '((3 11 9 5 7 1) (6 2 4 10 12 8)) (by '((N) (bit? 1 N)) group (3 11 6 2 9 5 4 10 12 7 8 1) ) ) (test '(("x" "x" "x") ("y") ("z" "z")) (by name group '("x" "x" "y" "z" "x" "z")) ) (test '((123 "xyz") ((1 2) "XY") ("abcd" (1 2 3 4))) (by length group '(123 (1 2) "abcd" "xyz" (1 2 3 4) "XY")) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/big.l0000644000000000000000000000602712265263724015641 0ustar rootroot# 22aug13abu # (c) Software Lab. Alexander Burger ### format ### (test "123456789" (format 123456789)) (test "12346" (format 12345.6789)) (test "1234567.89" (format 123456789 2)) (test "1234567,89" (format 123456789 2 ",")) (test "1.234.567,89" (format 123456789 2 "," ".")) (test 123456789 (format "123456789")) (test 12345678900 (format "1234567.89" 4)) (test NIL (format "1.234.567,89")) (test 12345678900 (format "1234567,89" 4 ",")) (test NIL (format "1.234.567,89" 4 ",")) (test 12345678900 (format "1.234.567,89" 4 "," ".")) (test 123456 (format (1 "23" (4 5 6)))) ### + ### (test 6 (+ 1 2 3)) (test 0 (+ 1 2 -3)) (test NIL (+ NIL 7)) ### - ### (test -7 (- 7)) (test 7 (- -7)) (test 6 (- 7 2 -1)) (test NIL (- NIL 7)) ### inc ### (test 8 (inc 7)) (test -6 (inc -7)) (test 0 (inc -1)) (test 1 (inc 0)) (test (8 -6 0 1) (let L (7 -7 -1 0) (map inc L) L)) (test NIL (inc NIL)) (let N 0 (test 1 (inc 'N)) (test 1 N) (test 8 (inc 'N 7)) (test 8 N) ) (let L (1 2 3 4) (test 3 (inc (cdr L))) (test (1 3 3 4) L) ) ### dec ### (test 7 (dec 8)) (test -8 (dec -7)) (test -1 (dec 0)) (test (7 -8 -1) (let L (8 -7 0) (map dec L) L)) (test NIL (dec NIL)) (let N 7 (test 6 (dec 'N)) (test 6 N) (test 3 (dec 'N 3)) (test 3 N) ) ### * ### (test 6 (* 1 2 3)) (test -60 (* -5 3 2 2)) (test NIL (* NIL 7)) ### */ ### (test 6 (*/ 3 4 2)) (test -247 (*/ 1234 -2 10)) (test 17 (*/ 100 6)) (test NIL (*/ 3 4 NIL)) ### / ### (test 4 (/ 12 3)) (test -5 (/ 60 -3 2 2)) (test NIL (/ 10 NIL)) ### % ### (test 2 (% 17 5)) (test -2 (% -17 5)) (test 1 (% 5 2)) (test 5 (% 15 10)) (test 1 (% 15 10 2)) (test NIL (% NIL 7)) ### >> ### (test 4 (>> 1 8)) (test 2 (>> 3 16)) (test 128 (>> -3 16)) (test -32 (>> -1 -16)) ### lt0 ### (test -2 (lt0 -2)) (test NIL (lt0 7)) (test NIL (lt0 0)) ### le0 ### (test -7 (le0 -7)) (test NIL (le0 2)) (test 0 (le0 0)) ### ge0 ### (test 7 (ge0 7)) (test NIL (ge0 -2)) (test 0 (ge0 0)) ### gt0 ### (test 7 (gt0 7)) (test NIL (gt0 -2)) (test NIL (gt0 0)) ### abs ### (test 7 (abs -7)) (test 7 (abs 7)) (test NIL (abs NIL)) ### bit? ### (test 7 (bit? 7 15 255)) (test 1 (bit? 1 3)) (test NIL (bit? 1 2)) ### & ### (test 2 (& 6 3)) (test 1 (& 7 3 1)) (test NIL (& 7 NIL)) ### | ### (test 3 (| 1 2)) (test 15 (| 1 2 4 8)) (test NIL (| NIL 1)) ### x| ### (test 5 (x| 2 7)) (test 4 (x| 2 7 1)) (test NIL (x| NIL 1)) ### sqrt ### (test 8 (sqrt 64)) (test 4 (sqrt 21)) (test 5 (sqrt 21 T)) (test 31 (sqrt 1000)) (test 32 (sqrt 1000 T)) (test 458 (sqrt 2100 100)) (test 479 (sqrt 230000)) (test 480 (sqrt 2300 100)) (test 800 (sqrt 6400 100)) (test 100000000000000000000 (sqrt 10000000000000000000000000000000000000000) ) (test NIL (sqrt NIL)) ### seed rand hash ### (test (if (== 64 64) -1883594281 -1007791040) (seed "init string")) (test (if (== 64 64) 1699219178 -1053142179) (rand)) (test (if (== 64 64) 494771840 1884033960) (rand)) (test (if (== 64 64) 3 3) (rand 3 9)) (test (if (== 64 64) 3 6) (rand 3 9)) (test 1 (hash 0)) (test 55682 (hash 1)) (test 35970 (hash 7)) (test 29691 (hash 1234567)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/db.l0000644000000000000000000000121612265263724015460 0ustar rootroot# 08oct09abu # (c) Software Lab. Alexander Burger ### id ### (test *DB (id 1)) (test 1 (id *DB)) (let I (id 3 4) (test (3 . 4) (id I T)) ) ### lieu ### (rollback) (test NIL (lieu *DB)) (test *DB (val *DB) (lieu *DB)) ### commit rollback ### (let (X (new T) Y (new T)) (set X 1 Y 2) (commit) (test 1 (val X)) (test 2 (val Y)) (set X 111) (set Y 222) (test 111 (val X)) (test 222 (val Y)) (rollback) (test 1 (val X)) (test 2 (val Y)) ) ### mark ### (test NIL (mark *DB)) (test NIL (mark *DB T)) (test T (mark *DB)) (test T (mark *DB 0)) (test NIL (mark *DB)) ### dbck ### (test NIL (dbck)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/ext.l0000644000000000000000000000073112265263724015674 0ustar rootroot# 12nov09abu # (c) Software Lab. Alexander Burger ### ext:Snx ### (test "PSLSFSNTSNNLSF" (ext:Snx "PicoLisp is not Common Lisp") ) (test "PSLSFSNT" (ext:Snx "PicoLisp is not Common Lisp" 8) ) ### ext:Ulaw ### (test (32 47 63 78 255 206 191 175 160) (mapcar 'ext:Ulaw (-8000 -4000 -2000 -1000 0 1000 2000 4000 8000)) ) ### ext:Base64 ### (test "TQ==" (pipe (ext:Base64 77) (line T)) ) (test "AQID" (pipe (ext:Base64 1 2 3) (line T)) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/flow.l0000644000000000000000000001766612265263724016062 0ustar rootroot# 31jul13abu # (c) Software Lab. Alexander Burger ### quote ### (test (1 2 3) (quote 1 2 3)) ### as ### (test NIL (as (= 3 4) A B C)) (test '(A B C) (as (= 3 3) A B C)) ### lit ### (test 123 (lit 123)) (test NIL (lit NIL)) (test T (lit T)) (test (1) (lit '(1))) (test ''"abc" (lit "abc")) (test ''a (lit 'a)) (test (1 2 3) (lit '(1 2 3))) (test ''(a b c) (lit '(a b c))) ### eval ### (test 6 (eval (list '+ 1 2 3))) (let (X 'Y Y 7) (test 7 (eval X)) ) (let N 1 ((quote (N) ((quote (N) (test 3 N) (test 2 (eval 'N 1)) (test 2 (eval 'N 1 '(X))) (test 3 (eval 'N 1 '(N))) (test 1 (eval 'N 2)) (test 3 (eval 'N 2 '(N))) ) 3 ) ) 2 ) ) ### run ### (test 6 (run (list (list '+ 1 2 3)))) (test 2 (let N 1 ((quote (N) (run '((+ N N)) 1)) 2) ) ) ### def ### (test '"a" (def '"a" '((X Y) (* X (+ X Y)))) ) (test '((X Y) (* X (+ X Y))) "a" ) ### de ### (test '"b" (de "b" (X Y) (* X (+ X Y))) ) (test '((X Y) (* X (+ X Y))) "b" ) ### dm ### (off "+Cls" "+A") (class "+Cls" "+A") (test '"foo>" (dm "foo>" (X Y) (* X (+ X Y)) ) ) (test '"foo>" (dm ("foo>" . "+Cls") (X Y) (* X (+ X Y)) ) ) (test '(("foo>" (X Y) (* X (+ X Y))) "+A") "+Cls" ) ### box ### (let X (box '(A B C)) (test X (box? X)) (test '(A B C) (val X)) ) ### new type isa method meth send try ### (let X (new '("+Cls")) (test X (box? X)) (test 21 ("foo>" X 3 4)) (test '("+Cls") (type X)) (test X (isa '"+Cls" X)) (test NIL (isa '(A B C) X)) (test '((X Y) (* X (+ X Y))) (method '"foo>" X) ) (test meth "foo>") (test 21 (send '"foo>" X 3 4)) (test NIL (try '"bar>" X)) (test 21 (try '"foo>" X 3 4)) ) ### super ### (off "+Sub") (class "+Sub" "+Cls") (dm ("foo>" . "+Sub") (X Y) (super X Y) ) (let X (new '("+Sub")) (test 21 ("foo>" X 3 4)) ) ### super ### (off "+Pref") (class "+Pref") (dm ("foo>" . "+Pref") (X Y) (extra X Y) ) (let X (new '("+Pref" "+Sub")) (test 21 ("foo>" X 3 4)) ) ### with ### (let X (box) (put X 'a 1) (put X 'b 2) (test (1 2) (with X (list (: a) (: b))) ) ) ### bind ### (let X 123 (test "Hello" (bind 'X (setq X "Hello") X ) ) (test (3 4 12) (bind '((X . 3) (Y . 4)) (list X Y (* X Y)) ) ) ) ### job ### (off "tst") (de "tst" () (job '((A . 0) (B . 0)) (cons (inc 'A) (inc 'B 2)) ) ) (test (1 . 2) ("tst")) (test (2 . 4) ("tst")) (test (3 . 6) ("tst")) ### let let? use ### (let N 1 (test NIL (let? N NIL N)) (test 7 (let? N 7 N)) (use N (setq N 2) (let N 3 (test 3 N) ) (test 2 N) ) (test 1 N) ) (let N 1 (use (N) (setq N 2) (let (N 3) (test 3 N) ) (test 2 N) ) (test 1 N) ) ### and ### (test 7 (and T 123 7)) (test NIL (and NIL 123)) ### or ### (test NIL (or NIL)) (test 7 (or NIL 7 123)) ### nand ### (test NIL (nand T 123 7)) (test T (nand NIL 123)) ### nor ### (test T (nor NIL)) (test NIL (nor NIL 7 123)) ### xor ### (test T (xor T NIL)) (test T (xor NIL T)) (test NIL (xor NIL NIL)) (test NIL (xor T T)) ### bool ### (test T (bool 'a)) (test T (bool 123)) (test NIL (bool NIL)) ### not ### (test T (not NIL)) (test NIL (not T)) (test NIL (not 'a)) ### nil ### (test NIL (nil (+ 1 2 3))) ### t ### (test T (t (+ 1 2 3))) ### prog ### (let N 7 (test 3 (prog (dec 'N) (dec 'N) (dec 'N) (dec 'N) N) ) ) ### prog1 prog2 ### (test 1 (prog1 1 2 3)) (test 2 (prog2 1 2 3)) ### if ### (test 1 (if (= 3 3) 1 2)) (test 2 (if (= 3 4) 1 2)) ### if2 ### (test 'both (if2 T T 'both 'first 'second 'none) ) (test 'first (if2 T NIL 'both 'first 'second 'none) ) (test 'second (if2 NIL T 'both 'first 'second 'none) ) (test 'none (if2 NIL NIL 'both 'first 'second 'none) ) (test 4 (if2 3 4 @)) (test 7 (and 7 (if2 @ @ @))) (test 7 (and 7 (if2 @ NIL 1 @))) (test 7 (and 7 (if2 NIL @ 1 2 @))) ### ifn ### (test 2 (ifn (= 3 3) 1 2)) (test 1 (ifn (= 3 4) 1 2)) ### when ### (test 7 (when (= 3 3) 7)) (test NIL (when (= 3 4) 7)) ### unless ### (test NIL (unless (= 3 3) 7)) (test 7 (unless (= 3 4) 7)) ### cond ### (test 1 (cond ((= 3 3) 1) (T 2))) (test 2 (cond ((= 3 4) 1) (T 2))) ### nond ### (test 2 (nond ((= 3 3) 1) (NIL 2))) (test 1 (nond ((= 3 4) 1) (NIL 2))) (test (1 . a) (nond ((num? 'a) (cons 1 'a)) (NIL (cons 2 @))) ) (test (2 . 7) (nond ((num? 7) (cons 1 7)) (NIL (cons 2 @))) ) ### case ### (test 1 (case 'a (a 1) ((b c) 2) (T 3))) (test 2 (case 'b (a 1) ((b c) 2) (T 3))) (test 2 (case '"b" (a 1) ((b c) 2) (T 3))) (test 2 (case 'c (a 1) ((b c) 2) (T 3))) (test 2 (case "c" (a 1) ((b c) 2) (T 3))) (test 3 (case 'd (a 1) ((b c) 2) (T 3))) (test 3 (casq 'a ("a" 1) (("b" "c") 2) (T 3))) (test 3 (casq 'b ("a" 1) (("b" "c") 2) (T 3))) (test 2 (casq '"b" ("a" 1) (("b" "c") 2) (T 3))) (test 2 (casq '"c" ("a" 1) (("b" "c") 2) (T 3))) (test 3 (casq 'b (a 1) ("b" 2) ((a b c) 3) (c 4))) ### state ### (off "tst") (de "tst" () (job '((Cnt . 4)) (state '(start) (start 'run (link 'start) ) (run (and (gt0 (dec 'Cnt)) 'run) (link 'run) ) (run 'stop (link 'run) ) (stop 'start (setq Cnt 4) (link 'stop) ) ) ) ) (test '(start run run run run stop start run run run run stop) (make (do 12 ("tst"))) ) (test '(start run run) (make (do 3 ("tst"))) ) ### while ### (test (1 2 3 4 5 6 7) (make (let N 0 (while (>= 7 (inc 'N)) (link N) ) ) ) ) ### until ### (test (1 2 3 4 5 6 7) (make (let N 0 (until (> (inc 'N) 7) (link N) ) ) ) ) ### loop ### (test (1 2 3 4 5 6 7) (make (let N 1 (loop (link N) (T (> (inc 'N) 7)) ) ) ) ) (test (1 2 3 4 5 6 7) (make (let N 1 (loop (link N) (NIL (>= 7 (inc 'N))) ) ) ) ) (test '(a . 3) (loop (T NIL (cons @ 1)) (NIL 'a (cons @ 2)) (NIL NIL (cons @ 3))) ) ### do ### (test (1 2 3 4 5 6 7) (make (let N 0 (do 7 (link (inc 'N)) ) ) ) ) (test (1 2 3 4 5 6 7) (make (let N 1 (do T (link N) (T (> (inc 'N) 7)) ) ) ) ) ### at ### (test (1 2 3 - 4 5 6 - 7 8 9 -) (make (let N 0 (do 9 (link (inc 'N)) (at (0 . 3) (link '-)) ) ) ) ) ### for ### (test (1 2 3 4 5 6 7) (make (for N (1 2 3 4 5 6 7) (link N) ) ) ) (test (1 2 3 4 5 6 7) (make (for (N . X) '(a b c d e f g) (link N) ) ) ) (test (1 2 3 4 5 6 7) (make (for N 7 (link N) ) ) ) (test (1 2 3 4 5 6 7) (make (for (N 1 (>= 7 N) (inc N)) (link N) ) ) ) (test (1 2 3 4 5 6 7) (make (for ((N . X) 7 (gt0 X) (dec X)) (link N) ) ) ) (test (1 2 3 4 5 6 7) (make (for (N 1 T) (link N) (T (> (inc 'N) 7)) ) ) ) ### catch throw ### (test NIL (catch NIL (throw))) (test 'b (catch 'a (throw 'a 'b))) (test 123 (catch T (throw 'a 123))) (test "Undefined" (catch '("Undefined") (mist)) ) (test "No such file" (catch '("No such file") (in "doesntExist" (foo)) ) ) (test 6 (casq (catch '("No such file" "Undefined" "expected") (+ 1 2 3) ) ("No such file" (shouldNotComeHere)) ("Undefined" (shouldNotComeHere)) ("expected" (shouldNotComeHere)) (T @) ) ) ### finally ### (test 'B (let X 'A (catch NIL (finally (setq X 'B) (setq X 'C) (throw) (setq X 'D) ) ) X ) ) ### co yield ### (when co (test (1 2 3 (1 2 3)) (make (do 4 (link (co "co123" (make (yield (link 1)) (yield (link 2)) (yield (link 3)) ) ) ) ) ) ) ) ### call ### (test T (call 'test "-d" (path "@test"))) (test NIL (call 'test "-f" (path "@test"))) ### kill ### (test T (kill *Pid 0)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/ht.l0000644000000000000000000000212612265263724015507 0ustar rootroot# 07jun12abu # (c) Software Lab. Alexander Burger ### ht:Prin ### (test "1<2>3&äöü<i>ÄÖÜß" (pipe (ht:Prin "1<2>3&äöüÄÖÜß") (line T)) ) ### ht:Fmt ### (test "+123&abc&$def&-123&_+1_xyz_+7" (ht:Fmt 123 "abc" 'def '{123} (1 "xyz" 7)) ) ### ht:Pack ### (test "A+B C" (ht:Pack '("A" "+" "B" "%" "2" "0" "C")) ) (test "a b>c" (ht:Pack '("a" "%" "2" "0" "b" "&" "g" "t" ";" "c")) ) (test "a€z" (ht:Pack '("a" "&" "#" "8" "3" "6" "4" ";" "z")) ) (test "äöü" (ht:Pack '("%" "C" "3" "%" "A" "4" "%" "C" "3" "%" "B" "6" "%" "C" "3" "%" "B" "C")) ) ### ht:Read ### (test NIL (pipe (prin "abcde") (ht:Read 0)) ) (test NIL (pipe (prin "abcde") (ht:Read 6)) ) (test NIL (pipe NIL (ht:Read 3)) ) (test NIL (pipe (prin "äö") (ht:Read 3)) ) (test '("ä" "ö") (pipe (prin "äö") (ht:Read 4)) ) (test '("a" "b" "c") (pipe (prin "abcde") (ht:Read 3)) ) (test '("ä" "ö" "ü") (pipe (prin "äöüxyz") (ht:Read 6)) ) ### ht:In ht:Out ### (test "Hello world" (pipe (ht:Out T (prinl "Hello world")) (ht:In T (line T))) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/io.l0000644000000000000000000001140612265263724015504 0ustar rootroot# 26sep13abu # (c) Software Lab. Alexander Burger ### path ### (test 'task (cadr (in (path "@lib.l") (read)))) (test (char "+") (char (path "+@"))) ### read ### (test (1 2 3) (~(1 2) 3)) (test (1 3) (~(1 . 2) 3)) (test (1 2 3 4) (1 ~(2 3) 4)) (test (1 2 4) (1 ~(2 . 3) 4)) (test (1 2 3) [1 2 3]) (test (1 2 3) (1 2 3] (test (1 2 3) (1 2 3)] (test (1 (2 3)) (1 (2 3] (test (quote 1 (2 (3))) '(1 (2 (3] (test (quote 1 (2 (3))) '[1 (2 (3]) (test (1 abc (d e f)) (pipe (prinl "(1 abc (d e f))") (read) ) ) (test '(abc "=" def_ghi "(" ("x" "y" "z") "+" "-" 123 ")") (pipe (prinl "abc = def_ghi(\"xyz\"+-123) # Comment") (make (while (read "_" "#") (link @) ) ) ) ) ### wait ### (let (*Run NIL *Cnt 0) (test (1 2 3 4 5 6 7) (make (task -10 0 (link (inc '*Cnt))) (wait NIL (>= *Cnt 7)) ) ) ) ### peek char ### (pipe (prin "ab") (test "a" (peek)) (test "a" (char)) (test "b" (peek)) (test "b" (char)) (test NIL (peek)) (test NIL (char)) ) (test "A" (char 65)) (test 65 (char "A")) ### skip ### (test "a" (pipe (prinl "# Comment^Ja") (skip "#") ) ) (test "#" (pipe (prinl "# Comment^Ja") (skip) ) ) ### eof ### (test T (pipe NIL (eof))) (test NIL (pipe (prin "a") (eof))) (test T (pipe (prin "a") (eof T) (eof))) ### from till ### (test "cd" (pipe (prin "ab.cd:ef") (from ".") (till ":" T) ) ) ### line ### (test '("a" "b" "c") (pipe (prin "abc^J") (line)) ) (test "abc" (pipe (prin "abc") (line T)) ) (test '("abc" "def") (pipe (prin "abc^Jdef") (list (line T) (line T)) ) ) (test '("abc" "def") (pipe (prin "abc^Mdef") (list (line T) (line T)) ) ) (test '("abc" "def") (pipe (prin "abc^M^Jdef") (list (line T) (line T)) ) ) (test '("a" "bc" "def") (pipe (prin "abcdef") (line T 1 2 3) ) ) ### lines ### (out (tmp "lines") (do 3 (prinl "abc")) ) (test 3 (lines (tmp "lines"))) ### any ### (test '(a b c d) (any "(a b # Comment^Jc d)")) (test "A String" (any "\"A String\"")) ### sym ### (test "(abc \"Hello\" 123)" (sym '(abc "Hello" 123)) ) ### str ### (test '(a (1 2) b) (str "a (1 2) b") ) (test '(a (1 2)) (str "a (1 2) # b") ) (test "a \"Hello\" DEF" (str '(a "Hello" DEF)) ) ### load ### (test 6 (load "-* 1 2 3")) ### in out err ### (out (tmp "file") (println 123) (println 'abc) (println '(d e f)) ) (in (tmp "file") (test 123 (read)) (in (tmp "file") (test 123 (read)) (test 'abc (in -1 (read))) ) (test '(d e f) (read)) ) (let Err (tmp "err") (test 1 (err Err (msg 1))) (test 2 (err (pack "+" Err) (msg 2))) (test "1^J2^J" (in Err (till NIL T))) ) ### pipe ### (test 123 (pipe (println 123) (read))) ### open close ### (let F (open (tmp "file")) (test 123 (in F (read))) (test 'abc (in F (read))) (test '(d e f) (in F (read))) (test F (close F)) ) ### echo ### (out (tmp "echo") (in (tmp "file") (echo) ) ) (in (tmp "echo") (test 123 (read)) (test 'abc (read)) (test '(d e f) (read)) ) (let F (tmp "file") (test "12" (pipe (in F (echo 2)) (line T) ) ) (test "23" (pipe (in F (echo 1 2)) (line T) ) ) ) ### prin prinl space print printsp println ### (out (tmp "prin") (prin 1) (prinl 2) (space) (print 3) (printsp 4) (println 5) ) (test (12 "^J" " " 34 5) (in (tmp "prin") (list (read) (char) (char) (read) (read)) ) ) ### flush rewind ### (out (tmp "prin") (prinl "abc") (flush) (test "abc" (in (tmp "prin") (line T))) (rewind) ) (out (tmp "prin") (prinl "def")) (test "def" (in (tmp "prin") (line T))) ### ext rd pr ### (let L (list (id 1 2) (cons (id 3 9) 'a) (cons (id 2 7) 'b)) (let L5 (list (id 6 2) (cons (id 8 9) 'a) (cons (id 7 7) 'b)) (out (tmp "ext") (ext 5 (pr L5)) ) (test L (in (tmp "ext") (rd)) ) (test L5 (in (tmp "ext") (ext 5 (rd))) ) ) ) (pipe (for N 4096 (pr N) ) (for N 4096 (test N (rd)) ) ) (pipe (for C 4096 (pr (char C)) ) (for C 4096 (test C (char (rd))) ) ) (pipe (pr (7 "abc" (1 2 3) 'a)) (test (7 "abc" (1 2 3) 'a) (rd)) ) (test "def" (out (tmp "pr") (pr 'abc "EOF" 123 "def") ) ) (test '(abc "EOF" 123 "def") (in (tmp "pr") (make (use X (until (== "EOF" (setq X (rd "EOF"))) (link X) ) ) ) ) ) (let N 1 (do 200 (test N (pipe (pr N) (rd)) ) (test (- N) (pipe (pr (- N)) (rd)) ) (setq N (* 2 N)) (wait 10) ) ) ### wr ### (test 3 (out (tmp "wr") (wr 1 2 3) ) ) (test (hex "010203") (in (tmp "wr") (rd 3) ) ) (for I 100 (let (L (need I "01") N (hex (pack L))) (test N (pipe (apply wr (mapcar format L)) (rd I)) ) (wait 10) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/main.l0000644000000000000000000000724612265263724016030 0ustar rootroot# 06may13abu # (c) Software Lab. Alexander Burger ### Evaluation ### (test 2 (when 1 ('((N) N) (and 2)) @ ) ) ### alarm ### (let N 6 (alarm 1 (inc 'N)) (test 6 N) (wait 2000) (test 7 N) (alarm 0) ) ### sigio ### (unless (member *OS '("SunOS" "OpenBSD")) (sigio (setq "SigSock" (port T 0 "SigPort")) (setq "SigVal" (udp "SigSock")) ) (udp "localhost" "SigPort" '(a b c)) (wait 200) (test '(a b c) "SigVal") (close "SigSock") ) ### protect ### (test NIL (pipe (prog (kill *Pid) (pr 7)) (rd))) (test 7 (pipe (protect (kill *Pid) (pr 7)) (rd))) ### quit ### (test "Quit" (catch '("Quit") (quit "Quit"))) ### adr ### (let (X (box 7) L (123)) (test 7 (val (adr (adr X)))) (test 123 (car (adr (adr L)))) ) ### env ### (test NIL (env)) (test '((A . 1) (B . 2)) (let (A 1 B 2) (env) ) ) (test '((B . 2) (A . 1)) (let (A 1 B 2) (env '(A B)) ) ) (test '((Y . 8) (C . 3) (B . 2) (A . 1) (X . 7)) (let (A 1 B 2) (env 'X 7 '(A B (C . 3)) 'Y 8) ) ) ### trail ### (when trail (let (F '((A B) (G (inc A) (dec B))) G '((X Y) (trail T)) ) (test '(@X (F 3 4) A 3 B 4 (G (inc A) (dec B)) X 4 Y 3) (F 3 4) ) ) ) ### up ### (test 1 (let N 1 ((quote (N) (up N)) 2) ) ) (test 7 (let N 1 ((quote (N) (up N 7)) 2) N ) ) ### sys ### (test "PicoLisp" (sys "TEST" "PicoLisp")) (test "PicoLisp" (sys "TEST")) ### args next arg rest #### (test '(T 1 1 3 (2 3 4)) (let foo '(@ (list (args) (next) (arg) (arg 2) (rest))) (foo 1 2 3 4) ) ) (test (7 7 NIL NIL) ((quote @ (list (next) (arg) (next) (arg))) 7) ) ### usec ### (let U (usec) (wait 400) (test 4 (*/ (- (usec) U) 100000)) ) ### pwd ### (test *PWD (pwd)) ### cd ### (chdir "/" (test "/" (pwd)) ) ### info ### (test '(T . @) (info "@test")) (test (5 . @) (out (tmp "info") (prinl "info")) (info (tmp "info")) ) ### file ### (test (cons (tmp) "file" 1) (out (tmp "file") (println '(file))) (load (tmp "file")) ) ### dir ### (call 'mkdir "-p" (tmp "dir")) (out (tmp "dir/.abc")) (out (tmp "dir/a")) (out (tmp "dir/b")) (out (tmp "dir/c")) (test '("a" "b" "c") (sort (dir (tmp "dir")))) (test '("." ".." ".abc" "a" "b" "c") (sort (dir (tmp "dir") T))) ### cmd ### (cmd "test") (test "test" (cmd)) ### argv ### (test '("abc" "123") (pipe (call *CMD "-prog (println (argv)) (bye)" "abc" 123) (read) ) ) (test '("abc" "123") (pipe (call *CMD "-prog (argv A B) (println (list A B)) (bye)" "abc" 123) (read) ) ) ### opt ### (test '("abc" "123") (pipe (call *CMD "-prog (println (list (opt) (opt))) (bye)" "abc" 123) (read) ) ) (test "abc" (pipe (call *CMD "-de f () (println (opt))" "-f" "abc" "-bye") (read) ) ) ### date time ### (use (Dat1 Tim1 Dat2 Tim2 D1 T1 D2 T2) (until (= (setq Dat1 (date) Tim1 (time T)) (prog (setq Dat2 (date T) Tim2 (time T) D1 (in '(date "+%Y %m %d") (list (read) (read) (read))) T1 (in '(date "+%H %M %S") (list (read) (read) (read))) D2 (in '(date "-u" "+%Y %m %d") (list (read) (read) (read))) T2 (in '(date "-u" "+%H %M %S") (list (read) (read) (read))) ) (time) ) ) ) (test Tim1 (time T1)) (test Tim1 (apply time T1)) (test Tim2 (time T2)) (test Dat1 (date D1)) (test Dat1 (apply date D1)) (test Dat2 (date D2)) ) (test (2000 7 15) (date 730622)) (test 730622 (date 2000 7 15)) (test 730622 (date (2000 7 15))) (test NIL (date NIL)) (test (11 17 23) (time 40643)) (test 40643 (time 11 17 23)) (test 40643 (time (11 17 23))) (test NIL (time NIL)) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/net.l0000644000000000000000000000106712265263724015665 0ustar rootroot# 10jun11abu # (c) Software Lab. Alexander Burger ### port listen connect ### (test '(a b c) (let P (port 0 "ListenPort") (if (fork) (prog1 (in (listen P) (rd)) (close P) ) (close P) (wait 400) (and (connect "localhost" "ListenPort") (out @ (pr '(a b c)))) (bye) ) ) ) ### udp ### (test '(a b c) (let P (port T 0 "UdpPort") (if (fork) (udp P) (close P) (wait 400) (udp "localhost" "UdpPort" '(a b c)) (bye) ) ) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/subr.l0000644000000000000000000002437612265263724016062 0ustar rootroot# 23jul13abu # (c) Software Lab. Alexander Burger ### c[ad]*r ### (let L '(1 2 3 4 5) (test 1 (car L)) (test (2 3 4 5) (cdr L)) (test 2 (cadr L)) (test (3 4 5) (cddr L)) (test 3 (caddr L)) (test (4 5) (cdddr L)) (test 4 (cadddr L)) (test (5) (cddddr L)) ) (let L '((1 2 3) (4 5)) (test 1 (caar L)) (test (2 3) (cdar L)) (test 2 (cadar L)) (test (3) (cddar L)) (test 4 (caadr L)) (test (5) (cdadr L)) ) (let L '(((1 2))) (test 1 (caaar L)) (test (2) (cdaar L)) ) ### nth ### (test '(b c d) (nth '(a b c d) 2)) (test '(c) (nth '(a (b c) d) 2 2)) ### con ### (let C (1 . a) (test '(b c d) (con C '(b c d))) (test (1 b c d) C) ) ### cons ### (test (1 . 2) (cons 1 2)) (test '(a b c d) (cons 'a '(b c d))) (test '((a b) c d) (cons '(a b) '(c d))) (test '(a b c . d) (cons 'a 'b 'c 'd)) ### conc ### (let (A (1 2 3) B '(a b c)) (test (1 2 3 a b c) (conc A B)) (test (1 2 3 a b c) A) ) (test (1 2 3 4 5 6) (conc (1 2 3) NIL (4 5 6)) ) ### circ ### (let C (circ 'a 'b 'c) (test '(a b c . @) C) (test T (== C (cdddr C))) ) ### rot ### (test (4 1 2 3) (rot (1 2 3 4))) (test (3 1 2 4 5 6) (rot (1 2 3 4 5 6) 3)) (test (3 1 2 . @Z) (rot (1 2 3 .))) ### list ### (test (1 2 3 4) (list 1 2 3 4)) (test '(a (2 3) "OK") (list 'a (2 3) "OK")) ### need ### (test '(NIL NIL NIL NIL NIL) (need 5)) (test '(NIL NIL a b c) (need 5 '(a b c))) (test '(a b c NIL NIL) (need -5 '(a b c))) (test '(" " " " a b c) (need 5 '(a b c) " ")) (test (0 0 0) (need 3 0)) ### range ### (test (1 2 3 4 5 6) (range 1 6)) (test (1 2 3 4 5 6) (range 1 6)) (test (6 5 4 3 2 1) (range 6 1)) (test (-3 -2 -1 0 1 2 3) (range -3 3)) (test (3 1 -1 -3) (range 3 -3 2)) (test (-3 -2 -1) (range -3 -1)) ### full ### (test T (full (1 2 3))) (test NIL (full (1 NIL 3))) (test T (full 123)) ### make made chain link yoke ### (let (A 'a I 'i) (test '(x y z z a) (make (link (for A '(x y z) (link A))) (link A) ) ) (test (-1 0 1 x 2 y 3 z i a) (make (made (cons 0 (box))) (for (I . A) '(x y z) (link I A)) (test (0 1 x 2 y 3 z) (made)) (made (cons -1 (made))) (link I A) ) ) (test (1 2 3 4 5 6 7 8 9) (make (chain (1 2 3)) (chain (4 5 6) (7 8 9))) ) (test '(a b c) (make (yoke 'b) (link 'c) (yoke 'a)) ) (test '((x y z) (y z) (z) (z) a) (make (link (for (A '(x y z) A (cdr A)) (link A))) (link A)) ) (test (1 (x y z) 2 (y z) 3 (z) (z) i a) (make (link (for ((I . A) '(x y z) A (cdr A)) (link I A))) (link I A)) ) ) ### copy ### (test T (=T (copy T))) (let L (1 2 3) (test T (== L L)) (test NIL (== L (copy L))) (test T (= L (copy L))) (test T (= (1 2 3) (copy L))) ) ### mix ### (test '(c d a b) (mix '(a b c d) 3 4 1 2)) (test '(a A d D) (mix '(a b c d) 1 'A 4 'D)) ### append ### (test '(a b c 1 2 3) (append '(a b c) (1 2 3))) (test (1 2 3 . 4) (append (1) (2) (3) 4)) ### delete ### (test (1 3) (delete 2 (1 2 3))) (test '((1 2) (5 6) (3 4)) (delete (3 4) '((1 2) (3 4) (5 6) (3 4)))) ### delq ### (test '(a c) (delq 'b '(a b c))) (test (1 (2) 3) (delq (2) (1 (2) 3))) ### replace ### (test '(A b b A) (replace '(a b b a) 'a 'A)) (test '(a B B a) (replace '(a b b a) 'b 'B)) (test '(B A A B) (replace '(a b b a) 'a 'B 'b 'A)) ### strip ### (test 123 (strip 123)) (test '(a) (strip '''(a))) (test '(a b c) (strip (quote quote a b c))) ### split ### (test '((1) (2 b) (c 4 d 5) (6)) (split (1 a 2 b 3 c 4 d 5 e 6) 'e 3 'a) ) (test '("The" "quick" "brown" "fox") (mapcar pack (split (chop "The quick brown fox") " ")) ) ### reverse ### (test (4 3 2 1) (reverse (1 2 3 4))) (test NIL (reverse NIL)) ### flip ### (test (4 3 2 1) (flip (1 2 3 4))) (test (3 2 1 4 5 6) (flip (1 2 3 4 5 6) 3)) (test NIL (flip NIL)) ### trim ### (test (1 NIL 2) (trim (1 NIL 2 NIL NIL))) (test '(a b) (trim '(a b " " " "))) ### clip ### (test (1 NIL 2) (clip '(NIL 1 NIL 2 NIL))) (test '(a " " b) (clip '(" " a " " b " "))) ### head ### (test '(a b c) (head 3 '(a b c d e f))) (test NIL (head NIL '(a b c d e f))) (test NIL (head 0 '(a b c d e f))) (test '(a b c d e f) (head 10 '(a b c d e f))) (test '(a b c d) (head -2 '(a b c d e f))) (test '(a b c) (head '(a b c) '(a b c d e f))) ### tail ### (test '(d e f) (tail 3 '(a b c d e f))) (test '(c d e f) (tail -2 '(a b c d e f))) (test NIL (tail NIL '(a b c d e f))) (test NIL (tail 0 '(a b c d e f))) (test '(a b c d e f) (tail 10 '(a b c d e f))) (test '(d e f) (tail '(d e f) '(a b c d e f))) ### stem ### (test '("g" "h" "i") (stem (chop "abc/def\\ghi") "/" "\\")) (test '("g" "h" "i") (stem (chop "abc/def\\ghi") "\\" "/")) ### fin ### (test 'a (fin 'a)) (test 'b (fin '(a . b))) (test 'c (fin '(a b . c))) (test NIL (fin '(a b c))) ### last ### (test 4 (last (1 2 3 4))) (test '(d e f) (last '((a b) c (d e f)))) ### == ### (test T (== 'a 'a)) (test T (== 'NIL NIL (val NIL) (car NIL) (cdr NIL))) (test NIL (== (1 2 3) (1 2 3))) ### n== ### (test NIL (n== 'a 'a)) (test T (n== (1) (1))) ### = ### (test T (= 6 (* 1 2 3))) (test T (= "a" "a")) (test T (== "a" "a")) (test T (= (1 (2) 3) (1 (2) 3))) (test T (= (1 . (2 3 .)) (1 . (2 3 .)))) ### <> ### (test T (<> 'a 'b)) (test T (<> 'a 'b 'b)) (test NIL (<> 'a 'a 'a)) ### =0 ### (test 0 (=0 (- 6 3 2 1))) (test NIL (=0 'a)) ### =T ### (test NIL (=T 0)) (test NIL (=T "T")) (test T (=T T)) ### n0 ### (test NIL (n0 (- 6 3 2 1))) (test T (n0 'a)) ### nT ### (test T (nT 0)) (test T (nT "T")) (test NIL (nT T)) ### < ### (test T (< 3 4)) (test T (< 'a 'b 'c)) (test T (< 999 'a)) (test T (< NIL 7 'x (1) T)) ### <= ### (test T (<= 3 3)) (test T (<= 1 2 3)) (test T (<= "abc" "abc" "def")) ### > ### (test T (> 4 3)) (test T (> 'A 999)) (test T (> T (1) 'x 7 NIL)) ### >= ### (test T (>= 'A 999)) (test T (>= 3 2 2 1)) ### max ### (test 'z (max 2 'a 'z 9)) (test (5) (max (5) (2 3) 'X)) ### min ### (test 2 (min 2 'a 'z 9)) (test 'X (min (5) (2 3) 'X)) ### atom ### (test T (atom 123)) (test T (atom 'a)) (test T (atom NIL)) (test NIL (atom (123))) ### pair ### (test NIL (pair NIL)) (test (1 . 2) (pair (1 . 2))) (test (1 2 3) (pair (1 2 3))) ### circ? ### (test NIL (circ? 'a)) (test NIL (circ? (1 2 3))) (test (2 3 . @) (circ? (1 . (2 3 .)))) ### lst? ### (test T (lst? NIL)) (test NIL (lst? T)) (test T (lst? (1 . 2))) (test T (lst? (1 2 3))) ### num? ### (test 123 (num? 123)) (test NIL (num? 'abc)) (test NIL (num? (1 2 3))) ### sym? ### (test T (sym? 'a)) (test T (sym? NIL)) (test NIL (sym? 123)) (test NIL (sym? '(a b))) ### flg? ### (test T (flg? T)) (test T (flg? NIL)) (test NIL (flg? 0)) (test T (flg? (= 3 3))) (test T (flg? (= 3 4))) (test NIL (flg? (+ 3 4))) ### member ### (test (3 4 5 6) (member 3 (1 2 3 4 5 6))) (test NIL (member 9 (1 2 3 4 5 6))) (test '((d e f) (g h i)) (member '(d e f) '((a b c) (d e f) (g h i))) ) ### memq ### (test '(c d e f) (memq 'c '(a b c d e f))) (test NIL (memq (2) '((1) (2) (3)))) (test 'c (memq 'c '(a b . c))) (test '(b c a . @Z) (memq 'b '(a b c .))) (test NIL (memq 'd '(a b c .))) ### mmeq ### (test NIL (mmeq '(a b c) '(d e f))) (test '(b x) (mmeq '(a b c) '(d b x))) ### sect ### (test (3 4) (sect (1 2 3 4) (3 4 5 6))) (test (1 2 3) (sect (1 2 3) (1 2 3))) (test NIL (sect (1 2 3) (4 5 6))) ### diff ### (test (1 3 5) (diff (1 2 3 4 5) (2 4))) (test (1 2 3) (diff (1 2 3) NIL)) (test NIL (diff (1 2 3) (1 2 3))) ### index ### (test 3 (index 'c '(a b c d e f))) (test NIL (index 'z '(a b c d e f))) (test 3 (index '(5 6) '((1 2) (3 4) (5 6) (7 8)))) ### offset ### (test 3 (offset '(c d e f) '(a b c d e f))) (test NIL (offset '(c d e) '(a b c d e f))) ### prior ### (let (L (1 2 3 4 5 6) X (cdddr L)) (test NIL (prior L L)) (test (3 4 5 6) (prior X L)) ) ### length ### (test 3 (length "abc")) (test 3 (length "äbc")) (test 3 (length 123)) (test 3 (length (1 (2) 3))) (test T (length (1 2 3 .))) (test T (length (1 . (2 3 .)))) ### size ### (test 3 (size "abc")) (test 4 (size "äbc")) (test 1 (size 127)) (test 2 (size 128)) (test 4 (size (1 (2) 3))) (test 3 (size (1 2 3 .))) (test 8 (size '((1 2 3) (4 5 6)))) (test 6 (size '((1 2 .) (4 5 .)))) (test 3 (size (1 . (2 3 .)))) ### bytes ### (test 4 (bytes "abc")) (test 5 (bytes "äbc")) (test 2 (bytes 127)) (test 3 (bytes 128)) (test 10 (bytes (101 (102) 103))) (test 9 (bytes (101 102 103 .))) (let (L (7 "abc" (1 2 3) 'a) F (tmp "bytes")) (out F (pr L)) (test (bytes L) (car (info F))) ) ### assoc ### (test '("b" . 7) (assoc "b" '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) ) (test (999 1 2 3) (assoc 999 '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) ) (test NIL (assoc 'u '((999 1 2 3) ("b" . 7) ("ok" "Hello"))) ) ### asoq ### (test NIL (asoq (9) '(((9) 1 2 3) (b . 7) ("ok" "Hello"))) ) (test '(b . 7) (asoq 'b '(((9) 1 2 3) (b . 7) ("ok" "Hello"))) ) ### rank ### (test NIL (rank 0 '((1 . a) (100 . b) (1000 . c))) ) (test (1 . a) (rank 50 '((1 . a) (100 . b) (1000 . c))) ) (test (100 . b) (rank 100 '((1 . a) (100 . b) (1000 . c))) ) (test (100 . b) (rank 300 '((1 . a) (100 . b) (1000 . c))) ) (test (1000 . c) (rank 9999 '((1 . a) (100 . b) (1000 . c))) ) (test (100 . b) (rank 50 '((1000 . a) (100 . b) (1 . c)) T) ) ### match ### (use (@A @B @X @Y @Z) (test T (match '(@A is @B) '(This is a test)) ) (test '(This) @A) (test '(a test) @B) (test T (match '(@X (d @Y) @Z) '((a b c) (d (e f) g) h i)) ) (test '((a b c)) @X) (test '((e f) g) @Y) (test '(h i) @Z) ) ### fill ### (let (@X 1234 @Y (1 2 3 4)) (test 1234 (fill '@X)) (test '(a b (c 1234) (((1 2 3 4) . d) e)) (fill '(a b (c @X) ((@Y . d) e))) ) ) (test (1 a b c 9) (fill (1 ^ (list 'a 'b 'c) 9)) ) (test (1 9) (fill (1 ^ 7 9)) ) (let X 2 (test (1 2 3) (fill (1 X 3) 'X))) (let X 2 (test (1 2 3) (fill (1 X 3) '(X)))) ### prove ### (test T (prove (goal '((equal 3 3)))) ) (test '((@X . 3)) (prove (goal '((equal 3 @X)))) ) (test NIL (prove (goal '((equal 3 4)))) ) ### -> ### (test '((@A . 3) (@B . 7)) (prove (goal '(@A 3 (^ @B (+ 4 (-> @A)))))) ) ### unify ### (test '((@A ((NIL . @C) 0 . @C) ((NIL . @B) 0 . @B) T)) (prove (goal '((^ @A (unify '(@B @C)))))) ) ### sort ### (test '(NIL 1 2 3 4 a b c d (1 2 3) (a b c) (x y z) T) (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2)) ) (test '(T (x y z) (a b c) (1 2 3) d c b a 4 3 2 1 NIL) (sort '(a 3 1 (1 2 3) d b 4 T NIL (a b c) (x y z) c 2) >) ) # vi:et:ts=3:sw=3 picolisp-3.1.5.2.orig/test/src/sym.l0000644000000000000000000001720612265263724015711 0ustar rootroot# 28aug13abu # (c) Software Lab. Alexander Burger ### name ### (test "abc" (name 'abc)) (test "A123" (name '{A123})) (let X (box) (test NIL (name X)) (name X "xxx") (test "xxx" (name X)) ) ### sp? ### (test T (sp? " ^I^J")) (test NIL (sp? " abc")) (test NIL (sp? 123)) ### pat? ### (test `(char '@) (char (pat? '@))) (test NIL (pat? "ABC")) (test NIL (pat? 123)) ### fun? ### (test 1000000000 (fun? 1000000000)) (test NIL (fun? 12345678901234567890)) (test '(A B) (fun? '((A B) (* A B)))) (test NIL (fun? '((A B) (* A B) . C))) (test NIL (fun? (1 2 3 4))) (test NIL (fun? '((A 2 B) (* A B)))) (test T (fun? '(NIL (* 3 4)))) ### all ### (test '(test) (filter '((S) (= S "test")) (all)) ) ### symbols ### (when symbols (test T (bool (pair pico))) (test 'pico (symbols 'myLib 'pico)) ) (when symbols (one Foo) (test 'myLib (symbols 'pico)) ) (when symbols (test 1 myLib~Foo) ) ### intern ### (test car (val (intern (pack "c" "a" "r")))) ### extern ### (test NIL (extern (box))) (test *DB (extern "1")) ### ==== ### (setq *Sym "abc") (test T (== *Sym "abc")) (====) (test NIL (== *Sym "abc")) ### box? ### (let X (box) (test X (box? X)) ) (test NIL (box? 123)) (test NIL (box? 'a)) (test NIL (box? NIL)) ### str? ### (test NIL (str? 123)) (test NIL (str? '{A123})) (test NIL (str? 'abc)) (test "abc" (str? "abc")) ### ext? ### (test *DB (ext? *DB)) (test NIL (ext? 'abc)) (test NIL (ext? "abc")) (test NIL (ext? 123)) ### touch ### (test *DB (touch *DB)) (rollback) ### zap ### (test "abc" (str? (zap 'abc))) ### chop ### (test '("c" "a" "r") (chop 'car)) (test '("H" "e" "l" "l" "o") (chop "Hello")) (test '("1" "2" "3") (chop 123)) (test (1 2 3) (chop (1 2 3))) (test NIL (chop NIL)) ### pack ### (test "car is 1 symbol name" (pack 'car " is " 1 '(" symbol " name)) ) ### glue ### (test 1 (glue NIL 1)) (test "a" (glue NIL '(a))) (test "ab" (glue NIL '(a b))) (test "a,b" (glue "," '(a b))) (test "a8b" (glue 8 '(a b))) (test "a123b123c" (glue (1 2 3) '(a b c))) ### text ### (test "abc XYZ def 123" (text "abc @1 def @2" 'XYZ 123)) (test "aXYZz" (text "a@3z" 1 2 '(X Y Z))) (test "a@bc.de" (text "a@@bc.@1" "de")) (test "10.11.12" (text "@A.@B.@C" 1 2 3 4 5 6 7 8 9 10 11 12)) ### pre? ### (test "abcdef" (pre? "" "abcdef")) (test NIL (pre? "abc" "")) (test "abcdef" (pre? "abc" "abcdef")) (test NIL (pre? "def" "abcdef")) (test "abcdef" (pre? "" "abcdef")) (test "7fach" (pre? (+ 3 4) "7fach")) ### sub? ### (test "abcdef" (sub? "" "abcdef")) (test NIL (sub? "abc" "")) (test "abcdef" (sub? "cde" "abcdef")) (test "abcdef" (sub? "def" "abcdef")) (test NIL (sub? "abb" "abcdef")) (test "abcdef" (sub? "" "abcdef")) ### val ### (let L '(a b c) (test '(a b c) (val 'L)) (test 'b (val (cdr L))) ) ### set ### (use L (test '(a b c) (set 'L '(a b c))) (test 999 (set (cdr L) '999)) (test '(a 999 c) L) ) ### setq ### (use (A B) (test (123 123) (setq A 123 B (list A A)) ) (test 123 A) (test (123 123) B) ) ### swap ### (let (A 1 L (1 2 3)) (test 1 (swap 'A 7)) (test 7 (swap 'A 'xyz)) (test 3 (swap (cddr L) A)) (test (1 2 xyz) L) ) ### xchg ### (let (A 1 B 2 C '(a b c)) (test 2 (xchg 'A C 'B (cdr C))) (test 'a A) (test 'b B) (test (1 2 c) C) ) ### on off onOff zero one ### (use (A B) (test T (on A B)) (test T A) (test T B) (test NIL (off A)) (test NIL A) (test NIL (onOff B)) (test NIL B) (test T (onOff A B)) (test T A) (test T B) (test 0 (zero A B)) (test 0 A) (test 0 B) (test 1 (one A B)) (test 1 A) (test 1 B) ) ### default ### (let (A NIL B NIL) (test 2 (default A 1 B 2)) (test A 1) (test B 2) (test 2 (default A 7 B 8)) (test A 1) (test B 2) ) ### push push1 pop cut ### (let L NIL (test 1 (push 'L 3 2 1)) (test L (1 2 3)) (test 0 (push1 'L 0)) (test 1 (push1 'L 1)) (test L (0 1 2 3)) (test 0 (pop 'L)) (test (1 2) (cut 2 'L)) (test (3) L) ) ### del ### (let (L '((a b c) (d e f)) S (new)) (put S 'lst L) (test '((a b c)) (del '(d e f) 'L)) (test '(a b c) (del 'x L)) (test '(a c) (del 'b L)) (with S (test '((a b c)) (del '(d e f) (:: lst))) (test NIL (del '(a b c) (:: lst))) (test NIL (: lst)) ) ) ### queue ### (let A NIL (test 1 (queue 'A 1)) (test 2 (queue 'A 2)) (test 3 (queue 'A 3)) (test (1 2 3) A) ) ### fifo ### (let X NIL (test 1 (fifo 'X 1)) (test 3 (fifo 'X 2 3)) (test 1 (fifo 'X)) (test 2 (fifo 'X)) (test 3 (fifo 'X)) ) ### idx lup ### (let X NIL (test NIL (idx 'X 'd T)) (test NIL (idx 'X (2 . f) T)) (test NIL (idx 'X (3 . g) T)) (test NIL (idx 'X '(a b c) T)) (test NIL (idx 'X 17 T)) (test NIL (idx 'X 'A T)) (test '(d . @) (idx 'X 'd T)) (test NIL (idx 'X T T)) (test '(A) (idx 'X 'A)) (test '(17 A d (2 . f) (3 . g) (a b c) T) (idx 'X) ) (test (2 . f) (lup X 2)) (test '((2 . f) (3 . g)) (lup X 1 4)) (test '(17 . @) (idx 'X 17 NIL)) (test '(A d (2 . f) (3 . g) (a b c) T) (idx 'X) ) (off X) (for N '((4 . D) 3 (2 . B) Y (3 . C) Z (6 . F) 7 (7 . G) X (1 . A) T (5 . E) 5) (idx 'X N T) ) (test '(3 5 7 X Y Z (1 . A) (2 . B) (3 . C) (4 . D) (5 . E) (6 . F) (7 . G) T) (idx 'X) ) (test '((3 . C) (4 . D) (5 . E)) (lup X 3 5) ) (test '((1 . A) (2 . B) (3 . C) (4 . D) (5 . E) (6 . F) (7 . G)) (lup X 0 9) ) ) ### put get prop ; =: : :: putl getl ### (let (A (box) B (box A) C (box (cons A B))) (put B 'a A) (put C 'b B) (put A 'x 1) (put B 'a 'y 2) (put C 0 -1 'a 'z 3) (test '(NIL . p) (prop 'A 'p)) (test 1 (get A 'x)) (test 1 (; A x)) (test 2 (with A (: y))) (test 2 (get A 'y)) (test 2 (; A y)) (test 2 (with B (: 0 y))) (test 2 (get B 0 'y)) (test 2 (; B 0 y)) (test 3 (with C (: b a z))) (test 3 (with C (: 0 1 z))) (test 3 (with C (: 0 -1 a z))) (test 3 (get C 0 1 'z)) (test 3 (get C 0 -1 'a 'z)) (test 3 (; C 0 -1 a z)) (test 1 (push (prop 'A 'p) 1)) (test 1 (with 'A (pop (:: p)))) (test NIL (get 'A 'p)) (test (3 . z) (prop C 0 -1 'a 'z)) (test 9 (with C (=: 0 -1 a z (* 3 3)))) (test (9 . z) (with C (:: 0 -1 a z))) (test (putl C 0 -1 'a '((1 . x) (2 . y))) (flip (getl C 'b 0))) ) (test NIL (get (1 2 3) 0)) (test 1 (get (1 2 3) 1)) (test 3 (get (1 2 3) 3)) (test NIL (get (1 2 3) 4)) (test (3) (get (1 2 3) -2)) (test 1 (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'a 'b)) (test 4 (get '((a (b . 1) (c . 2)) (d (e . 3) (f . 4))) 'd 'f)) ### wipe ### (let X (box (1 2 3 4)) (put X 'a 1) (put X 'b 2) (test (1 2 3 4) (val X)) (test '((2 . b) (1 . a)) (getl X)) (wipe X) (test NIL (val X)) (test NIL (getl X)) ) (setq "W" (1 2 3 4)) (put '"W" 'a 1) (put '"W" 'b 2) (test (1 2 3 4) "W") (test '((2 . b) (1 . a)) (getl '"W")) (wipe '"W") (test NIL "W") (test NIL (getl '"W")) (set *DB (1 2 3 4)) (put *DB 'a 1) (put *DB 'b 2) (test (1 2 3 4) (val *DB)) (test '((2 . b) (1 . a)) (getl *DB)) (wipe *DB) (test (1 2 3 4) (val *DB)) (test '((2 . b) (1 . a)) (getl *DB)) (rollback) (test NIL "W") (test NIL (getl '"W")) ### meta ### (let A '("B") (put '"B" 'a 123) (test 123 (meta 'A 'a)) ) ### low? ### (test "a" (low? "a")) (test NIL (low? "A")) (test NIL (low? 123)) (test NIL (low? ".")) ### upp? ### (test "A" (upp? "A")) (test NIL (upp? "a")) (test NIL (upp? 123)) (test NIL (upp? ".")) ### lowc ### (test "abc" (lowc "ABC")) (test "äöü" (lowc "ÄÖÜ")) (test "äöü" (lowc "äöü")) (test 123 (lowc 123)) ### uppc ### (test "ABC" (uppc "abc")) (test "ÄÖÜ" (uppc "äöü")) (test "ÄÖÜ" (uppc "ÄÖÜ")) (test 123 (lowc 123)) ### fold ### (test "1a2b3" (fold " 1A 2-b/3")) (test "1a2" (fold " 1A 2-B/3" 3)) # vi:et:ts=3:sw=3