Perl6 thread

There are too many ways to do it.

The completely backwards way:

> sub foo(&f) { f() }
{ "hi".say }.&foo();
hi

On the other hand, closures are much nicer now (JavaScript needs this):
> say (1,2,3,4,5).reduce: { $^a + $^b };
15
Note about .reduce: it only supports binary functions.

A note on operators:
Hyperops, eg: (1,2,3,4) «+» (5,6,7,8)
These are permitted to auto-parallelize (implementation dependent.)
Lazy meta-ops, eg: 1,2,3,4 Z+ 5,6,7,8
These support lazy evaluation. The result is generated as needed.
Reduction meta-ops, eg: [+] 1,2,3,4,5
Triangular reduction: [code][\+] 1,2,3,4,5 # result is (1,3,6,10,15)[code]
These are basically .reduce(*[b][i]op[/i][/b]*) with the binary operator provided.

Perl: https://github.com/perl6/std/blob/master/STD.pm6

Symta:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;; READER

(defparameter  /base   nil)   ; beginning of input stream
(defparameter  /in     nil)   ; current position inside input
(defparameter  /src    nil)   ; source, from where input comes
(defparameter  /res    nil)   ; result
(defparameter  /row    nil)   ; current row
(defparameter  /col    nil)   ; current column
(defparameter  /off    nil)   ; current offset inside input
(defparameter  /last   nil)   ; last processed char

(to /error msg ! error "{/src}:{/row},{/col}: {msg}")

(to /top-char ! car /in)

(to /next-char
  ! c = (/top-char)
  ! if eq c #\newline
  ! ! do (setf /col 0)
         (incf /row)
  ! ! incf /col
  ! incf /off
  ! setf /last c
  ! setf /in (cdr /in)
  ! c)

(to /skip-ws
  ! c = (/top-char)
  ! cond
  ! ! find c '(#\space #\newline)
  ! ! ! (/next-char)
  ! ! ! (/skip-ws)
  ! ! and (eq c #\/) (eq (second /in) #\/)
  ! ! ! (/next-char)
  ! ! ! (/next-char)
  ! ! ! while and (/top-char) (not (eq (/top-char) #\newline))
  ! ! ! ! (/next-char)
  ! ! ! (/skip-ws)
  ! ! and (eq c #\/) (eq (second /in) #\*)
  ! ! ! (/next-char)
  ! ! ! (/next-char)
  ! ! ! o = 1
  ! ! ! while plusp o
  ! ! ! ! unless /in
  ! ! ! ! ! /error "`/*`: missing `*/`"
  ! ! ! ! a = (/next-char)
  ! ! ! ! b = first /in
  ! ! ! ! cond
  ! ! ! ! ! and (eql a #\*) (eql b #\/) :> (! (/next-char) ! decf o)
  ! ! ! ! ! and (eql a #\/) (eql b #\*) :> (! (/next-char) ! incf o)
  ! ! ! (/skip-ws)
  )

(to /take-prefix p
  ! rec r ys nil
  ! ! y = (/top-char)
  ! ! if funcall p y
  ! ! ! r (cons (/next-char) ys)
  ! ! ! nreverse ys)

(to /location match
  ! l = length match
  ! list
  ! ! list "Col" (- /col l)
  ! ! list "Off" (- /off l)
  ! ! list "Row" /row
  ! ! list "Src" /src)

(to /expect c
  ! if eq (/top-char) c
  ! ! (/next-char)
  ! ! /error "Expected `{c}`; Got `{or (/top-char) 'EOF}`")

(defmacro try ((var expr fail) &body body)
  `(! ,var = ,expr
    ! if eq ,var :fail
    ! ! ,fail
    ! ! do ,@body))

(to str-empty? o ! and (quote? o) (equal (second o) ""))

(to interp l e r ; interpolate expression into string
  ! l = (! if str-empty? l
         ! ! list "\"" e
         ! ! list "\"" l e)
  ! unless str-empty? r
  ! ! setf l (! if headed "\"" r
              ! ! q ''l ''(cdr r)
              ! ! q ''l ''(list r))
  ! l)

(to /read-string ic d s e
  ! l = nil
  ! while t
  ! ! c = (/top-char)
  ! ! unless eq c ic :> (/next-char)
  ! ! cond
  ! ! ! eq c #\\
  ! ! ! ! setf c (/next-char)
  ! ! ! ! cond
  ! ! ! ! ! eq c #\n :> push #\newline l
  ! ! ! ! ! eq c #\t :> push #\tab l
  ! ! ! ! ! eq c #\\ :> push #\\ l
  ! ! ! ! ! or (eq c #\n) (eq c ic) (eq c e) (eq c s) :> push c l
  ! ! ! ! ! eq c nil :> /error "EOF in string"
  ! ! ! ! ! or t :> /error "Invalid escape code: {c}"
  ! ! ! eq c s
  ! ! ! ! incf d
  ! ! ! ! push c l
  ! ! ! eq c e
  ! ! ! ! decf d
  ! ! ! ! if < d 0
  ! ! ! ! ! return-from /read-string (list "\\" (coerce (reverse l) 'string))
  ! ! ! ! ! push c l
  ! ! ! eq c ic ;interpolate
  ! ! ! ! try it (/term) (/error "`[`: missing argument")
  ! ! ! ! ! r = /read-string ic d s e
  ! ! ! ! ! return-from /read-string (interp (list "\\" (coerce (reverse l) 'string)) (cdr it) r)
  ! ! ! eq c nil :> /error "EOF in string"
  ! ! ! or t :> push c l
  )

(to /string
  ! case (/top-char)
  ! ! #\" (/next-char) (/read-string #[ 0 nil #\")
  ! ! #\' (/next-char) (/read-string #[ 0 nil #\')
  ! ! #\` (second (/read-string nil 0 nil (/next-char)))
  ! ! otherwise :fail)

(to /list &key r-op
  ! opening = (/top-char)
  ! op = (or r-op
             (find-if (fn (x) (eq (char x 0) opening))
                      '("()" "[]"))
             (return-from /list (/string)))
  ! ending = aref op 1
  ! row = nil
  ! col = nil
  ! setf row /row
  ! setf col /col
  ! unless r-op :> /expect opening
  ! rec r xs nil
  ! ! try x (/expr) (! if eq (/top-char) ending
                     ! ! (/next-char)
                     ! ! error "{/src}:{row},{col}: unclosed `{opening}`"
                     ;;! (meta-set (ns-set nil "Src" (/location nil)) xs)
                     ! xs = nreverse xs
                     ! when string= op "[]" :> setf xs (q "list" ''xs)
                     ! xs)
  ! ! ! r (cons x xs)
  )

(to hex-digit? x ! or (digit? x) (find x "abcdefABCDEF"))

(to /num
  ! cond
  ! ! digit? (/top-char)
  ! ! ! rec r i t
              ys nil
  ! ! ! ! y = (/top-char)
  ! ! ! ! cond
  ! ! ! ! ! and (eql y #\.) i (digit? (second /in)) :> r nil (cons (/next-char) ys)
  ! ! ! ! ! digit? y :> r i (cons (/next-char) ys)
  ! ! ! ! ! or t :> read-from-string (coerce (nreverse ys) 'string)
  ! ! eq (/top-char) #\#
  ! ! ! /expect #\#
  ! ! ! when eq (/top-char) #\{ :> return-from /num (list "#" (second (/list)))
  ! ! ! when /sym-body? (/top-char)
  ! ! ! ! s = coerce (/take-prefix #'/sym-body?) 'string
  ! ! ! ! when hex-digit? (aref s 0) :> return-from /num (read-from-string (concatenate 'string "#x" s))
  ! ! ! ! when string= s "yes" :> return-from /num :yes
  ! ! ! ! when string= s "no" :> return-from /num :no
  ! ! ! ! when string= s "void" :> return-from /num :void
  ! ! ! ! when string= s "head" :> return-from /num :head
  ! ! ! ! /error "`#{s}` is unexpected"
  ! ! ! /error "`#{(/top-char)}` is unexpected"
  ! ! or t :> :fail)

(to /delim
  ! (/skip-ws)
  ! c = assoc (/top-char) '((#\| :|\||) (#\: :|:|) (#\; :|;|))
  ! unless c :> return-from /delim (/list)
  ! (/next-char)
  ! second c)

(to /term
  ! (/skip-ws)
  ! x = (/top-char)
  ! if /sym-head? x
  ! ! coerce (/take-prefix #'/sym-body?) 'string
  ! ! try n (/num) (/delim)
  ! ! ! when /sym-head? (/top-char)
  ! ! ! ! setf n (list "*" n (/dot))
  ! ! ! n)

(defun left-curly () "{")
(defun curly-braces () "{}")

(to delim? x ! find x '(:|\|| :|:| "=" "=>") :test 'equal)

(to /op &rest ops
  ! (/skip-ws)
  ! c = (/top-char)
  ! when or (alpha? c) (digit? c) (not (find c ops))
  ! ! return-from /op :fail
  ! string (/next-char))

(defmacro /lop (name down &rest ops) ; left-biased op
  `(to ,name
     ! try a (,down) :fail
     ! ! rec r e a
     ! ! ! try o (/op ,@ops) e
     ! ! ! ! if string= o (left-curly)
     ! ! ! ! ! do
     ! ! ! ! ! ! xs = /list :r-op (curly-braces)
     ! ! ! ! ! ! when find-if #'delim? xs :> setf xs (list xs)
     ! ! ! ! ! ! r (q '(curly-braces) 'e ''xs)
     ! ! ! ! ! try b (,down) (/error "`{o}`: missing right operand")
     ! ! ! ! ! ! r (list o e b)))

(defmacro /rop (name down &rest ops) ; right-biased op
  `(to ,name
     ! try a (,down) :fail
     ! ! try o (/op ,@ops) a
     ! ! ! try b (,name) (/error "`{o}`: missing right operand")
     ! ! ! ! list o a b))


(defmacro /prop (name down &rest ops) ; prefix op
  `(to ,name
     ! try o (/op ,@ops) (,down)
     ! ! try a (,name) (/error "`{o}`: missing operand")
     ! ! ! if and (numberp a) (equal o "~") ;dangerous hack
     ! ! ! ! - a
     ! ! ! ! list o a))

(/prop /gs   /term #\^)
(/lop  /dot  /gs   #\. #\, #\{)
(/prop /pref /dot  #\~ #\\ #\$ #\! #\@ #\&)
(/lop  /mul  /pref #\* #\/ #\%)
(/lop  /add  /mul  #\+ #\-)

(to /expr ! (/add))

(to /line
  ! rec r xs nil
  ! ! try x (/expr) (! if-bind it (/top-char) (/error "Unexpected `{it}`")
                     ! nreverse xs)
  ! ! ! push x xs
  ! ! ! (/skip-ws)
  ! ! ! if and (eq /last #\newline) (not (eq (/top-char) #\|))
  ! ! ! ! nreverse xs
  ! ! ! ! r xs)

(to head-args? xs ! headed :head xs)
(to head-args-as-list xs ! if (headed :head xs) (cdr xs) xs)
(to list-as-head-args &rest xs ! q :head ''xs)

(to sioc xs ; processes symta indentation of code
  ! unless listp xs :> return-from sioc xs
  ! p = position-if #'delim? xs
  ! unless p
  ! ! unless headed :|\|| xs :> setf xs (mapcar #'sioc xs)
  ! ! return-from sioc xs
  ! text = elt xs p
  ! pref = subseq xs 0 p
  ! xs = subseq xs p (length xs)
  ! body = cdr xs
  ! zs = nil
  ! when equal text "=>" :> return-from sioc (sioc `("to" ,@pref :|:| ,@body))
  ! when equal text "=" :> return-from sioc (sioc `("my" ,@pref :|:| ,@body))
  ! when equal text :|:|
  ! ! pref = or pref '(:void)
  ! ! return-from sioc (sioc (q '(car pref) (:head ''(cdr pref)) '(sioc body)))
  ! while xs
  ! ! pop xs
  ! ! ys = nil
  ! ! while equal (car xs) :|\|| :> push (pop xs) ys
  ! ! while and xs (not (equal (car xs) :|\||)) :> push (pop xs) ys
  ! ! ys = nreverse ys
  ! ! if equal (car ys) :|\||
  ! ! ! push (append (pop zs) ys) zs
  ! ! ! push ys zs
  ! xs = map xs (nreverse zs) :> sioc xs
  ! if pref
  ! ! q '(car pref) (:head ''(cdr pref)) ''xs
  ! ! q do ''xs)

(to /read-toplevel xs src
  ! unless listp xs :> setf xs (coerce xs 'list)
  ! /src = src
  ! /base = xs
  ! /in = /base
  ! /off = 0
  ! /row = 0
  ! /col = 0
  ! /last = nil
  ! r = nil
  ! while /in
  ! ! l = (/line)
  ! ! when xs? l :> push (sioc l) r
  ! nreverse r)

(to /read xs ! first (/read-toplevel xs "<REPL>"))