;A test program exploring how to structure GUI code in Clojure

;The GUI draws whatever you type in the text field nicely in the panel below.

;license: Public domain

(import '(javax.swing JFrame JLabel JTextField JButton JPanel)

'(java.awt.event ActionListener)

'(java.awt GridBagLayout GridBagConstraints Color Font RenderingHints))

(defn make-model [] (ref "Hello MVC!"))

(defn make-graphics-panel [model]

(let [panel

(proxy [JPanel] []

(JPanel [] (println "in constructor"))

(paint [g]

(doto g

;clear the background

(.setColor (. Color black))

(.fillRect 0 0 (.getWidth this) (.getHeight this))

;draw the text

(.setRenderingHint (. RenderingHints KEY_ANTIALIASING)

(. RenderingHints VALUE_ANTIALIAS_ON))

(.setFont (Font. "Serif" (. Font PLAIN) 40))

(.setColor (. Color white))

(.drawString @model 20 40))))]

;repaint when the model changes

(add-watch model "repaint" (fn [k r o n] (.repaint panel)))

panel))

(defn make-text-field [model]

(doto (JTextField.)

(.setText @model)

(.addActionListener

(proxy [ActionListener] []

(actionPerformed [e]

(let [new-text (.getActionCommand e)]

(dosync (ref-set model new-text))))))))

(defn make-gui-panel [model]

(defn make-text-field-constraints []

(let [c (GridBagConstraints.)]

(set! (.fill c) (. GridBagConstraints HORIZONTAL))

(set! (.weightx c) 1)

c))

(defn make-panel-constraints []

(let [c (GridBagConstraints.)]

(set! (.gridy c) 1)

(set! (.weighty c) 1)

(set! (.fill c) (. GridBagConstraints BOTH))

c))

(let [gridbag (GridBagLayout.)

text-field (make-text-field model)

panel (make-graphics-panel model)]

;set up the gridbag constraints

(doto gridbag

(.setConstraints text-field (make-text-field-constraints))

(.setConstraints panel (make-panel-constraints)))

;add the components to the panel and return it

(doto (JPanel.)

(.setLayout gridbag)

(.add text-field)

(.add panel))))

(defn show-in-frame [panel width height frame-title]

(doto (JFrame. frame-title)

(.add panel)

(.setSize width height)

(.setVisible true)))

(show-in-frame (make-gui-panel (make-model)) 300 110 "GUI Test")

; A test program exploring how to structure GUI code in Clojure

; The GUI draws whatever you type in the text field nicely in the panel below.

; license: Public domain

import .p javax.swing JFrame JLabel JTextField JButton JPanel

.p java.awt.event ActionListener

.p java.awt GridBagLayout GridBagConstraints Color Font RenderingHints

.sub add addChild

defunc make-model

ref "Hello MVC!"

defunc make-graphics-panel model

let panel

proxy JPanel

.m JPanel

println "in constructor"

.m paint g

doto g

; clear the background

setColor Color.BLACK ; an imported class’s statics get mapped to Class.name

fillRect 0 0 (getWidth) (getHeight)

; draw the text

; you can optionally specify to import statics by own name rather than qualified by their class

setRenderingHint KEY_ANTIALIASING VALUE_ANTIALIAS_ON

setFont (Font "Serif" Font.PLAIN 40)

setColor Color.WHITE

drawstring d'model 20 40

; repaint when the model changes

add-watch model "repaint" (func a b c d (repaint panel))

,panel

defunc make-text-field model

doto (JTextField)

setText d’model

addActionListener

proxy ActionListener

.m actionPerformed e

let new-text (getActionCommand e)

dosync (ref-set model new-text)

defunc make-text-field-constraints

let c (GridBagConstraints)

set! (fill c) GridBagConstraints.HORIZONTAL

set! (weightx c) 1

defunc make-panel-constraints

let c (GridBagConstraints)

set! (gridy c) 1

set! (weighty c) 1

set! (fill c) GridBagConstraints.BOTH

defunc make-gui-panel model

let gridbag (GridBagLayout)

,text-field (make-text-field model)

,panel (make-graphics-panel model)

;set up the gridbag constraints

doto gridbag

setConstraints text-field (make-text-field-constraints)

setConstraints panel (make-panel-constraints)

;add the components to the panel and return it

doto (JPanel)

setLayout gridbag

addChild text-field

addChild panel

defunc show-in-frame panel width height frame-title

doto (JFrame frame-title)

addChild panel

setSize width height

setVisible true

show-in-frame (make-gui-panel (make-model)) 300 110 "GUI Test"

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

public static Surface CreateGlitzSurface (Gdk.Drawable d)

{

Console.WriteLine ("XvisID: " + GdkUtils.GetXVisualId (d.Visual));

IntPtr fmt = NDesk.Glitz.GlitzAPI.glitz_glx_find_drawable_format_for_visual (

GdkUtils.GetXDisplay (d.Display),

d.Screen.Number,

GdkUtils.GetXVisualId (d.Visual));

Console.WriteLine ("fmt: " + fmt);

uint w = 100, h = 100;

IntPtr glitz_drawable = NDesk.Glitz.GlitzAPI.glitz_glx_create_drawable_for_window (

GdkUtils.GetXDisplay (d.Display),

d.Screen.Number,

fmt,

GdkUtils.GetXid (d), w, h);

NDesk.Glitz.Drawable ggd = new NDesk.Glitz.Drawable (glitz_drawable);

IntPtr glitz_format = ggd.FindStandardFormat (NDesk.Glitz.FormatName.ARGB32);

NDesk.Glitz.Surface ggs = new NDesk.Glitz.Surface (ggd, glitz_format, 100, 100, 0, IntPtr.Zero);

Console.WriteLine (ggd.Features);

bool doublebuffer = false;

ggs.Attach (ggd,

doublebuffer ? NDesk.Glitz.DrawableBuffer.BackColor : NDesk.Glitz.DrawableBuffer.FrontColor);

//GlitzAPI.glitz_drawable_destroy (glitz_drawable);

return new GlitzSurface (ggs.Handle);

}

; here we’re translating C# into a semi-functional style

defmeth-cs CreateGlitzSurface Surface .static d Gdk.Drawable

WriteLine Console (str "XvisID: " (GetXVisualId (Visual d)))

let fmt

glitz_glx_find_drawable_format_for_visual

GetXDisplay GdkUtils (Display d)

Number (Screen d)

GetXVisualId GdkUtils (Visual d)

WriteLine Console (str "fmt: " fmt)

let ggd

Drawable Glitz

glitz_glx_create_drawable_for_window

GetXDisplay (Display d)

Number (Screen d)

,fmt

GetXid d

100

,glitz_format (FindStandardFormat ggd FormatName.ARGB32)

,ggs (Surface ggd glitz_format 100 100 0 IntPtr.Zero)

,doublebuffer false

WriteLine (Features ggd)

Attach ggs ggd

ife doublebuffer

BackColor (DrawableBuffer Glitz)

FrontColor (DrawableBuffer Glitz)

GlitzSurface (Handle ggs)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(import '(java.util.concurrent Executors))

(defn test-stm [nitems nthreads niters]

(let [refs (map ref (replicate nitems 0))

pool (. Executors (newFixedThreadPool nthreads))

tasks (map (fn [t]

(fn []

(dotimes n niters

(dosync

(doseq r refs

(alter r + 1 t))))))

(range nthreads))]

(doseq future (. pool (invokeAll tasks))

(. future (get)))

(. pool (shutdown))

(map deref refs)))

(test-stm 10 10 10000)

import .p java.util.concurrent Executors

defunc test-stm nitems nthreads niters

let refs (map ref (replicate nitems 0))

,pool (newFixedThreadPool Executors nthreads)

,tasks

map

func t

func (dotimes n niters (dosync (doseq r refs (alter (add r 1) t)))))

range nthreads

doseq future (invokeAll pool tasks)

get future

shutdown pool

map deref refs

test-stm 10 10 10000

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(import '(javax.swing JFrame JLabel JTextField JButton)

'(java.awt.event ActionListener)

'(java.awt GridLayout))

(defn celsius []

(let [frame (new JFrame "Celsius Converter")

temp-text (new JTextField)

celsius-label (new JLabel "Celsius")

convert-button (new JButton "Convert")

fahrenheit-label (new JLabel "Fahrenheit")]

(. convert-button

(addActionListener

(proxy [ActionListener] []

(actionPerformed [evt]

(let [c (. Double (parseDouble (. temp-text (getText))))]

(. fahrenheit-label

(setText (str (+ 32 (* 1.8 c)) " Fahrenheit"))))))))

(doto frame

(setLayout (new GridLayout 2 2 3 3))

(add temp-text)

(add celsius-label)

(add convert-button)

(add fahrenheit-label)

(setSize 300 80)

(setVisible true))))

(celsius)

import .p javax.swing JFrame JLabel JTextField JButton

.p java.awt.event ActionListener

.p java.awt GridLayout

.sub add addChild

defunc celsius

let frame (JFrame 'Celsius Converter')

,temp-text (JTextField)

,celsius-label (JLabel 'Celsius')

,convert-button (JButton 'Convert')

,fahrenheit-label (JLabel 'Fahrenheit')

addActionListener convert-button

proxy ActionListener

actionPerformed evt

let c (parseDouble (getText temp-text))

setText fahrenheit-label

str (add 32 (mul 1.8 c)) ' Fahrenheit'

doto frame

setLayout (GridLayout 2 2 3 3)

addChild temp-text

addChild celsius-label

addChild convert-button

addChild fahrenheit-label

setSize 300 80

setVisible true

celsius

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

static long compat_nanosleep_restart(struct restart_block *restart)

{

struct compat_timespec __user *rmtp;

struct timespec rmt;

mm_segment_t oldfs;

long ret;

restart->nanosleep.rmtp = (struct timespec __user *) &rmt;

oldfs = get_fs();

set_fs(KERNEL_DS);

ret = hrtimer_nanosleep_restart(restart);

set_fs(oldfs);

if (ret) {

rmtp = restart->nanosleep.compat_rmtp;

if (rmtp && put_compat_timespec(&rmt, rmtp))

return -EFAULT;

}

return ret;

}

defunc-c compat_nanosleep_restart .static long restart restart_block .p

var rmtp* compat_timespec __user .p

var rmt timespec

var oldfs mm_segment_t

var ret long

= (rmtp (nanosleep restart)) (cast __user timespec .p &rmt)

= oldfs (get_fs)

set_fs KERNEL_DS

= ret (hrtimer_nanosleep_restart restart)

set_fs oldfs

if ret

= rmtp* (compat_rmtp (nanosleep restart))

if (and rmtp* (put_compat_timespec &rmt rmtp*))

return (neg EFAULT)

return ret

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

<?xml version="1.0"?>

</target>

</target>

</target>

</manifest>

</jar>

</target>

</project>

project Hello compile

    target clean "remove intermediate files"

        delete .dir classes

    target clobber . clean "remove all artifact files"

        delete .file "hello.jar"

    target compile "compile the Java source code to class files"

        mkdir .dir classes

        javac .srcdir "." .destdir "classes"

    target jar compile .description "create a Jar file for the application"

        jar "hello.jar"

            fileset .dir classes .includes "**/*.class"

            manifest

                attribute .name "Main-Class" .value "HelloProgram"

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn parting

"returns a String parting in a given language"

([] (parting "World"))

([name] (parting name "en"))

([name language]

(condp = language

"en" (str "Goodbye, " name)

"es" (str "Adios, " name)

(throw (IllegalArgumentException. (str "unsupported language " language))))))

defunc parting

"returns a String parting in a given language"

parting "World"

.alt name

parting name "en"

.alt name language

condp eq language

"en" (str "Goodbye, " name)

"es" (str "Adios, " name)

throw IllegalArgumentException (str "unsupported language " language)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

_restacked: function() {

let global = Shell.Global.get();

let windows = global.get_windows();

let i;

// We want to be visible unless there is a window with layer

// FULLSCREEN, or a window with layer OVERRIDE_REDIRECT that

// completely covers us. (We can't set a non-rectangular

// stage_input_area, so we don't let windows overlap us

// partially.). "override_redirect" is not actually a layer

// above all other windows, but this seems to be how mutter

// treats it currently...

// @windows is sorted bottom to top.

let actor = this.actor;

actor.show();

for (i = windows.length - 1; i > -1; i--) {

let wi = windows[i];

let layer = wi.get_meta_window().get_layer();

if (layer == Meta.StackLayer.OVERRIDE_REDIRECT) {

if (wi.x <= actor.x &&

wi.x + wi.width >= actor.x + actor.width &&

wi.y <= actor.y &&

wi.y + wi.height >= actor.y + PANEL_HEIGHT) {

actor.hide();

break;

}

} else if (layer == Meta.StackLayer.FULLSCREEN) {

actor.hide();

break;

} else

break;

}

j-method restacked

var global (get Shell.Global)

var windows (get_windows global)

var i

var actor (actor this)

; We want to be visible unless there is a window with layer

; FULLSCREEN, or a window with layer OVERRIDE_REDIRECT that

; completely covers us. (We can't set a non-rectangular

; treats it currently...

;

; +windows is sorted bottom to top.

; wi is immutable, but it can be used as an alias for target in assignment to assign to

; windows[i] (meaning whatever was the value of i at time of binding wi. To get an

; expression that binds to windows[i] that uses whatever the current value of i is requires

; another operator (don’t know what to call it)

show actor

for i (dec (length windows)) (gt i -1) (=dec i)

var wi (# windows i)

var layer (get_layer (get_meta_window wi))

if (eq layer (OVERRIDE_REDIRECT Meta.StackLayer))

and

lte (x wi) (x actor)

gte

add (x wi) (width wi)

add (x actor) (width actor)

lte (x actor) (y actor)

gte

add (y wi) (height wi)

add (y actor) PANEL_HEIGHT

hide actor

break

.ei (eq layer (FULLSCREEN Meta.StackLayer))

hide actor

break

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn div? [n d]

  (= 0 (rem n d)))

(defn largest-prime-factor [number]

  (loop [n number d 2]

    (cond (> d (int (Math/sqrt number))) n

      (= n d) n

      (div? n d) (recur (/ n d) d)

      true (recur n (inc d)))))

(largest-prime-factor 600851475143)

defunc div? n d

    eq 0 (rem n d)

defunc largest-prime-factor number

    loop n number d 2

        if (gt d (int (Math/sqrt number))) n

            .ei (eq n d)

,n

            .ei (div? n d)

            recur (div n d) d)

            .ei true

            recur n (inc d)

largest-prime-factor 600851475143

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

function main() {

    window.alert("Integer = " + intValue);

    window.alert("Float = " + floatValue);

    window.alert("String = " + stringValue);

    for (var item in emptyList) {

        window.alert("Empty list item = " + item);

    // Script style index iteration

    for (var i in homogenousList) {

        window.alert("Homogenous list item = "

                     + homogenousList[i]);

    // C style index iteration

    for (var i=0; i < heterogenousList.length; ++i) {

        window.alert("Heterogenous list item = "

                     + heterogenousList[i]);

    // Dot notation property access

    window.alert("Homogenous map property \"one\" "

                 + homogenousMap.one);

    // Subscript notation property access

    window.alert("Homogenous map property \"two\" "

                 + homogenousMap["two"]);

    for (var key in heterogenousMap) {

        window.alert("Heterogenous map property \""

                     + key

                     + "\" = "

                     + heterogenousMap[key]);

    callable("(Function value invoked)");

    closure();

    closure();

    callCallable(closure);

    composeCallables(callable, quote, "My Message");

    var my = new MyObject("foo", 5);

    window.alert("MyObject my.name = " + my.name);

    window.alert("MyObject my[\"value\"] = " + my["value"]);

    var msg = new Message("bar");

    for (var key in Message.prototype) {

        window.alert("Message prototype member \""

                     + key

                     + "\" = "

                     + Message.prototype[key]);

    window.alert("Message msg.message = " + msg.message);

    msg.show();

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

defunc-js main

    alert "Integer = " intValue

    alert "Float = " floatValue

    alert "String = " stringValue

    foreach item emptyList

        alert str "Empty list item = " item

    ; Script style index iteration

    foreach i homogenousList

        alert "Homogenous list item = " (a’homogenousList i)

    ; C style index iteration

    for i 0 (lt i (length heterogenousList)) (inc i)

        alert "Heterogenous list item = " (a’heterogenousList i)

    ; Dot notation property access

    alert "Homogenous map property \"one\" " (one homogenousMap)

    ; Subscript notation property access

    alert "Homogenous map property \"two\" " (two homogenousMap)

    foreach key heterogenousMap

        alert "Heterogenous map property \"" key "\" = " (a’heterogenousMap key)

    callable "(Function value invoked)"

    closure

    closure

    callCallable closure

    composeCallables callable quote "My Message"

    var my (MyObject "foo" 5)

    alert "MyObject my.name = " (name my)

    alert "MyObject my[\"value\"] = " (value my)

    var msg (Message "bar")

    foreach key Message.prototype

        alert "Message prototype member \"" key "\" = " (a’key Message.prototype)

    alert "Message msg.message = " (message msg)

    show msg

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn countpence

  ([] (countpence 0 [200 100 50 20 10 5 2 1]))

  ([sum opts]

    (cond

      (== sum 200) 1

      (>  sum 200) 0

      (not opts)   0

      :else (+ (countpence sum (rest opts))

               (countpence (+ sum (first opts)) opts)))))

defunc countpence

    countpence 0 (*200 100 50 20 10 5 2 1)

    .alt sum opts

    if (eq sum 200) 1

        .ei (gt sum 200) 0

        .ei (not opts) 0

.e

        add (countpence sum r'opts)

            countpence (add sum f'opts) opts

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- polynomial

  "computes the value of a polynomial

   with the given coefficients for a given value x"

  [coefs x]

  ; For example, if coefs contains 4 values then exponents is (3 2 1 0).

  (let [exponents (reverse (range (count coefs)))]

    ; Multiply each coefficient by x raised to the corresponding exponent

    ; and sum those results.

    ; coefs go into %1 and exponents go into %2.

    (apply + (map #(* %1 (Math/pow x %2)) coefs exponents))))

(defn- derivative

  "computes the value of the derivative of a polynomial

   with the given coefficients for a given value x"

  [coefs x]

  ; The coefficients of the derivative function are obtained by

  ; multiplying all but the last coefficient by its corresponding exponent.

  ; The extra exponent will be ignored.

  (let [exponents (reverse (range (count coefs)))

        derivative-coefs (map #(* %1 %2) (butlast coefs) exponents)]

    (polynomial derivative-coefs x)))

(def f (partial polynomial [2 1 3])) ; 2x^2 + x + 3

(def f-prime (partial derivative [2 1 3])) ; 4x + 1

(println "f(2) =" (f 2)) ; -> 13.0

(println "f'(2) =" (f-prime 2)) ; -> 9.0

defunc polynomial coefs x

    "computes the value of a polynomial

     with the given coefficients for a given value x"

    ; For example, if coefs contains 4 values then exponents is (3 2 1 0).

    let exponents (reverse (range (count coefs)))]

        ; Multiply each coefficient by x raised to the corresponding exponent

        ; and sum those results.

        ; coefs go into %1 and exponents go into %2.

        apply add (map (fn mul %1 (Math/pow x %2)) coefs exponents)

defunc derivative coefs x

    "computes the value of the derivative of a polynomial

     with the given coefficients for a given value x"

    ; The coefficients of the derivative function are obtained by

    ; multiplying all but the last coefficient by its corresponding exponent.

    ; The extra exponent will be ignored.

    let exponents (reverse (range (count coefs)))

        ,derivative-coefs (map (fn mul %1 %2) (butlast coefs) exponents)

        polynomial derivative-coefs x

def f (partial polynomial (*2 1 3)       ; 2x^2 + x + 3

def f-prime (partial derivative (*2 1 3)) ; 4x + 1

println "f(2) =" (f 2)          ; -> 13.0

println "f'(2) =" (f-prime 2) ; -> 9.0

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

package clojure.lang;

import java.io.*;

import java.util.regex.Pattern;

import java.util.regex.Matcher;

import java.util.ArrayList;

import java.util.List;

import java.util.Map;

import java.math.BigInteger;

import java.math.BigDecimal;

import java.lang.*;

public class LispReader{

static final Symbol QUOTE = Symbol.create("quote");

static final Symbol THE_VAR = Symbol.create("var");

//static Symbol SYNTAX_QUOTE = Symbol.create(null, "syntax-quote");

static Symbol UNQUOTE = Symbol.create("clojure.core", "unquote");

static Symbol UNQUOTE_SPLICING = Symbol.create("clojure.core", "unquote-splicing");

static Symbol CONCAT = Symbol.create("clojure.core", "concat");

static Symbol SEQ = Symbol.create("clojure.core", "seq");

static Symbol LIST = Symbol.create("clojure.core", "list");

static Symbol APPLY = Symbol.create("clojure.core", "apply");

static Symbol HASHMAP = Symbol.create("clojure.core", "hash-map");

static Symbol HASHSET = Symbol.create("clojure.core", "hash-set");

static Symbol VECTOR = Symbol.create("clojure.core", "vector");

static Symbol WITH_META = Symbol.create("clojure.core", "with-meta");

static Symbol META = Symbol.create("clojure.core", "meta");

static Symbol DEREF = Symbol.create("clojure.core", "deref");

//static Symbol DEREF_BANG = Symbol.create("clojure.core", "deref!");

static IFn[] macros = new IFn[256];

static IFn[] dispatchMacros = new IFn[256];

//static Pattern symbolPat = Pattern.compile("[:]?([\\D&&[^:/]][^:/]*/)?[\\D&&[^:/]][^:/]*");

static Pattern symbolPat = Pattern.compile("[:]?([\\D&&[^/]].*/)?([\\D&&[^/]][^/]*)");

//static Pattern varPat = Pattern.compile("([\\D&&[^:\\.]][^:\\.]*):([\\D&&[^:\\.]][^:\\.]*)");

//static Pattern intPat = Pattern.compile("[-+]?[0-9]+\\.?");

static Pattern intPat =

Pattern.compile(

"([-+]?)(?:(0)|([1-9][0-9]*)|0[xX]([0-9A-Fa-f]+)|0([0-7]+)|([1-9][0-9]?)[rR]([0-9A-Za-z]+)|0[0-9]+)\\.?");

static Pattern ratioPat = Pattern.compile("([-+]?[0-9]+)/([0-9]+)");

static Pattern floatPat = Pattern.compile("[-+]?[0-9]+(\\.[0-9]+)?([eE][-+]?[0-9]+)?[M]?");

static final Symbol SLASH = Symbol.create("/");

static final Symbol CLOJURE_SLASH = Symbol.create("clojure.core","/");

//static Pattern accessorPat = Pattern.compile("\\.[a-zA-Z_]\\w*");

//static Pattern instanceMemberPat = Pattern.compile("\\.([a-zA-Z_][\\w\\.]*)\\.([a-zA-Z_]\\w*)");

//static Pattern staticMemberPat = Pattern.compile("([a-zA-Z_][\\w\\.]*)\\.([a-zA-Z_]\\w*)");

//static Pattern classNamePat = Pattern.compile("([a-zA-Z_][\\w\\.]*)\\.");

//symbol->gensymbol

static Var GENSYM_ENV = Var.create(null);

//sorted-map num->gensymbol

static Var ARG_ENV = Var.create(null);

static

{

macros['"'] = new StringReader();

macros[';'] = new CommentReader();

macros['\''] = new WrappingReader(QUOTE);

macros['@'] = new WrappingReader(DEREF);//new DerefReader();

macros['^'] = new WrappingReader(META);

macros['`'] = new SyntaxQuoteReader();

macros['~'] = new UnquoteReader();

macros['('] = new ListReader();

macros[')'] = new UnmatchedDelimiterReader();

macros['['] = new VectorReader();

macros[']'] = new UnmatchedDelimiterReader();

macros['{'] = new MapReader();

macros['}'] = new UnmatchedDelimiterReader();

// macros['|'] = new ArgVectorReader();

macros['\\'] = new CharacterReader();

macros['%'] = new ArgReader();

macros['#'] = new DispatchReader();

dispatchMacros['^'] = new MetaReader();

dispatchMacros['\''] = new VarReader();

dispatchMacros['"'] = new RegexReader();

dispatchMacros['('] = new FnReader();

dispatchMacros['{'] = new SetReader();

dispatchMacros['='] = new EvalReader();

dispatchMacros['!'] = new CommentReader();

dispatchMacros['<'] = new UnreadableReader();

dispatchMacros['_'] = new DiscardReader();

}

static boolean isWhitespace(int ch){

return Character.isWhitespace(ch) || ch == ',';

}

static void unread(PushbackReader r, int ch) throws IOException{

if(ch != -1)

r.unread(ch);

}

public static class ReaderException extends Exception{

final int line;

public ReaderException(int line, Throwable cause){

super(cause);

this.line = line;

}

static public Object read(PushbackReader r, boolean eofIsError, Object eofValue, boolean isRecursive)

throws Exception{

try

{

for(; ;)

{

int ch = r.read();

while(isWhitespace(ch))

ch = r.read();

if(ch == -1)

{

if(eofIsError)

throw new Exception("EOF while reading");

return eofValue;

}

if(Character.isDigit(ch))

{

Object n = readNumber(r, (char) ch);

if(RT.suppressRead())

return null;

return n;

}

IFn macroFn = getMacro(ch);

if(macroFn != null)

{

Object ret = macroFn.invoke(r, (char) ch);

if(RT.suppressRead())

return null;

//no op macros return the reader

if(ret == r)

continue;

return ret;

}

if(ch == '+' || ch == '-')

{

int ch2 = r.read();

if(Character.isDigit(ch2))

{

unread(r, ch2);

Object n = readNumber(r, (char) ch);

if(RT.suppressRead())

return null;

return n;

}

unread(r, ch2);

}

String token = readToken(r, (char) ch);

if(RT.suppressRead())

return null;

return interpretToken(token);

}

catch(Exception e)

{

if(isRecursive || !(r instanceof LineNumberingPushbackReader))

throw e;

LineNumberingPushbackReader rdr = (LineNumberingPushbackReader) r;

//throw new Exception(String.format("ReaderError:(%d,1) %s", rdr.getLineNumber(), e.getMessage()), e);

throw new ReaderException(rdr.getLineNumber(), e);

}

static private String readToken(PushbackReader r, char initch) throws Exception{

StringBuilder sb = new StringBuilder();

sb.append(initch);

for(; ;)

{

int ch = r.read();

if(ch == -1 || isWhitespace(ch) || isTerminatingMacro(ch))

{

unread(r, ch);

return sb.toString();

}

sb.append((char) ch);

}

ns clojure.lang.lisp-reader

.use animus-java

.p java.math BigInteger BigDecimal

.p java.io

.p java.util.regex Pattern

.p java.util.regex Matcher

.p java.util ArrayList

.p java.util List

.p java.util Map

defclass-j .pub LispReader

field .s .f QUOTE Symbol (Symbol.create Symbol "quote") ; all members mapped to namespace name

field .s .f THE_VAR Symbol (Symbol.create "var")

;field .s .f SYNTAX_QUOTE Symbol (Symbol.create nil "var")

field .s .f UNQUOTE Symbol (Symbol.create “cloure.core” ‘unquote’)

field .s .f UNQOTE_SPLICING Symbol (Symbol.create ‘clojure.core’ ‘unquote-splicing’)

field .s .f CONCAT Symbol (Symbol.create ‘clojure.core’ ‘concat’)

field .s .f SEQ Symbol (Symbol.create ‘clojure.core’ ‘seq’)

field .s .f LIST Symbol (Symbol.create ‘clojure.core’ ‘list’)

field .s .f HASHMAP Symbol (Symbol.create ‘clojure.core’ ‘hash-map’)

field .s .f HASHSET Symbol (Symbol.create ‘clojure.core’ ‘hash-set’)

field .s .f VECTOR Symbol (Symbol.create ‘clojure.core’ ‘vector’)

field .s .f WITH_META Symbol (Symbol.create ‘clojure.core’ ‘with-list’)

field .s .f META Symbol (Symbol.create ‘clojure.core’ ‘meta’)

field .s .f DEREF Symbol (Symbol.create ‘clojure.core’ ‘deref’)

;field .s .f DEREF_BANG Symbol (Symbol.create ‘clojure.core’ ‘deref!’)

field .s macros IFn .a (array IFn 256)

field .s dispatchMacros .a (array IFn 256)

;field .s symbolPat Pattern (Pattern.compile “[:]?([\\D&&[^:/]][^:/]*/)?[\\D&&[^:/]][^:/]*")

;field .s varPat Pattern (Pattern.compile "([\\D&&[^:\\.]][^:\\.]*):([\\D&&[^:\\.]][^:\\.]*)")

;field .s intPat Pattern (Pattern.compile ("[-+]?[0-9]+\\.?")

field .s intPat Pattern (Pattern.compile "([-+]?)(?:(0)|([1-9][0-9]*)|0[xX]([0-9A-Fa-f]+)|0([0-7]+)|([1-9][0-9]?)[rR]([0-9A-Za-z]+)|0[0-9]+)\\.?")

field .s ratioPat Pattern (Pattern.compile "([-+]?[0-9]+)/([0-9]+)")

field .s floatPat Pattern (Pattern.compile "[-+]?[0-9]+(\\.[0-9]+)?([eE][-+]?[0-9]+)?[M]?")

field .s .f SLASH Symbol (Symbol.create "/")

field .s .f CLOJURE_SLASH Symbol (Symbol.create "clojure.core" "/")

;symbol->gensymbol

field .s GENSYM_ENV Var (Var.create nil)

;sorted-map num->gensymbol

field .s ARG_ENV Var (Var.create nil)

static-init

= (#macros c'"') (StringReader)

= (#macros c';') (CommentReader)

= (#macros c'\’') (WrappingReader QUOTE)

= (#macros c'@') (WrappingReader DEREF)

= (#macros c'^') (WrappingReader META)

= (#macros c'`') (SyntaxQuoteReader)

= (#macros c'~') (UnquoteReader)

= (#macros c'(') (ListReader)

= (#macros c')') (UnmatchedDelimiterReader)

= (#macros c'[') (VectorReader)

= (#macros c']') (UnmatchedDelimiterReader)

= (#macros c'{') (MapReader)

= (#macros c'}') (UnmatchedDelimiterReader)

= (#macros c'\\') (CharacterReader)

= (#macros c'%') (ArgReader)

= (#macros c'#') (DispatchReader)

= (#dispatchMacros c'^') (MetaReader)

= (#dispatchMacros c'\'') (VarReader)

= (#dispatchMacros c'"') (RegexReader)

= (#dispatchMacros c'(') (FnReader)

= (#dispatchMacros c'{') (SetReader)

= (#dispatchMacros c'=') (EvalReader)

= (#dispatchMacros c'!') (CommentReader)

= (#dispatchMacros c'<') (UnreadableReader)

= (#dispatchMacros c'_') (DiscardReader)

j-method .s isWhitespace boolean ch int

or (Character.isWhitespace ch) (eq ch c',')

j-method .s unread void r PushbackReader c int .th IOException

if (neq ch -1)

PushbackReader.unread r ch

j-in-class .s ReaderException .e Exception

field .f line int

constructor .pub line int cause Throwable

super cause

= t’line line ; t’ for this. Yeah, it’s inconsistent from normal form

; of (method obj) and (inst obj) but still seems like a good idea

j-method .s .pub read Object r PushbackReader eofIsError boolean eofValue Object isRecursive boolean .th Exception

try

while true

var ch int (read r)

while (isWhitespace ch)

= ch (read r)

if (eq ch -1)

if eofIsError

throw (Exception "EOF while reading")

return eofValue

if (Character.isDigit ch)

var n Object (readNumber r (cast char ch))

if (RT.suppressRead)

return nil

return n

var macroFn IFn (getMacro ch)

if (neq macroFn nil)

var ret Object (invoke macroFn r (cast char ch)

if (RT.suppressRead)

return nil

;no op macros return the reader

if (eq ret r)

continue

return ret

if (or (eq ch c'+') (eq ch c'-'))

var ch2 int (t’read r)

if (Character.isDigit ch2)

t’unread r ch2

var n Object (t’readNumber r (cast char ch))

if (RT.suppressRead)

return nil

return n

unread r ch2

var token String (readToken r (cast char ch))

if (RT.suppressRead)

return nil

return (interpretToken token)

.catch e Exception

if (or isRecursive (not (instanceof r LineNumberingPushbackReader)))

throw e

var rdr (LineNumberingPushbackReader r)

throw (ReaderException (getLineNumber rdr) e)

j-method .s .pri readToken String r PushbackReader initch char .th Exception

var sb StringBuilder (StringBuilder)

append sb initch

while true

var c int (read r)

if (or (eq ch -1) (isWhitespace ch) (isTerminatingMacro ch))

unread r ch

return (toString sb)

append sb (cast char ch)