When you don't know whether you need a fork or a spoon.

spoon.rkt

#lang racket/base

(require
  (only-in
   racket/pretty pretty-print)
  (only-in
   racket/bool nor)
  (only-in
   racket/function disjoin)
  (only-in
   racket/splicing splicing-parameterize)
  (only-in
   racket/dict dict-ref dict-set in-dict dict-has-key?))

(provide
  (except-out
   (all-defined-out)
   stack-pull-error
   stack-push-error
   
   hosts under merge
   flush flush++ flush--
   stack stack++ stack--
   trace trace++
   depth depth++ depth--
   
   J mark-clos none))

(define (stack-pull-error)
  (error 'spork "cannot pull from an empty stack"))

(define (stack-push-error ex)
  (error 'spork "expected a stack-item? found: ~a"
         ex))

(define host? keyword?)
(define atom? (disjoin symbol? string? char? number? boolean? null?))
(define clos? procedure?)
(define item? (disjoin host? atom? pair? clos?))

(define hosts (make-parameter #false))
(define under (make-parameter #false))
(define stack (make-parameter #false))
(define depth (make-parameter #false))

(define trace (make-parameter #false))
(define track (make-parameter #true))

(define (merge old new)
  {hosts
   (for/fold ([hosts old]) ([(host stack) (in-dict new)]
                            #:when (dict-has-key? old host))
     (dict-set hosts host stack))})

(define (flush [ex (void)])
  {hosts (dict-set {hosts} {under} {stack})}
  ex)

(define (trace++ do ex)
  (when {track} {trace `((,do ,ex) . ,{trace})}))

(define (trace-- do id ex)
  (when {track} {trace `((,do ,id ,ex) . ,{trace})}))

(define (stack++ ex)
  (trace++ 'push ex)
  {stack (cons ex {stack})})

(define (stack-- id)
  (define ex (car {stack}))
  (trace-- 'pull id ex)
  {stack (cdr {stack})}
  ex)

(define depth++ (compose1 depth add1 depth))
(define depth-- (compose1 depth sub1 depth))

(define flush++ (compose1 flush stack++))
(define flush-- (compose1 flush stack--))

(define (← [ex (gensym 'top)])
  (when (zero? {depth}) (stack-pull-error))
  (depth--)
  (flush-- ex))

(define (→ ex)
  (unless (void? ex)
    (unless (item? ex) (stack-push-error ex))
    (depth++)
    (flush++ ex)))

(define (♯ ex)
  (trace++ 'host ex)
  (define on (dict-ref {hosts} ex null))
  (define dp (length on))
  {under ex}
  {stack on}
  {depth dp})

(define (≫ ex)
  (define xe {under})
  (define io (←))
  (♯ ex)
  (→ io)
  (♯ xe))

(define (≪ ex)
  (define xe {under})
  (♯ ex)
  (define io (←))
  (♯ xe)
  (→ io))

(define (⇒ ex)
  (trace++ 'call ex)
  (cond [(clos? ex) (ex)] [(host? ex) (♯ ex)]
    [else (→ ex)]))

(define (core:hosts)  (→ {hosts}))
(define (core:under)  (→ {under}))
(define (core:stack)  (→ {stack}))
(define (core:trace)  (→ {trace}))
(define (core:depth)  (→ {depth}))

(define (core:print)  (pretty-print (←) #:newline? #true))
(define (core:write)  #false)
(define (core:read)   #false)

(define (core:cons)   (→ (cons (←) (←))))
(define (core:car)    (→ (car  (←))))
(define (core:cdr)    (→ (cdr  (←))))
(define (core:list)   (→ (list (←))))

(define (core:which)  (when (←) (let ([x (←)] [y (←)]) (→ x) (→ y))))
(define (core:equal?) (→ (equal? (←) (←))))

(define (core:take)   (→ (build-list (←) (λ (_) (←)))))
(define (core:feed)   (for-each → (reverse (←))))
(define (core:lookup) (→ (let ([x (←)]) (dict-ref (←) x #false))))
(define (core:member) (→ (member (←) (←))))

(define J             (log -1))
(define (core:jay)    (→ J))
(define (core:neg)    (→ (- (←))))
(define (core:add)    (→ (+ (←) (←))))
(define (core:exp)    (→ (exp (←))))
(define (core:log)    (→ (let ([x (←)]) (if (zero? x) -inf.0 (log x)))))
(define (core:real)   (→ (real-part (←))))
(define (core:imag)   (→ (imag-part (←))))

(define (core:eq?)    (→ (let ([x (←)]) (=  (←) x))))
(define (core:lt?)    (→ (let ([x (←)]) (<  (←) x))))
(define (core:leq?)   (→ (let ([x (←)]) (<= (←) x))))
(define (core:gt?)    (→ (let ([x (←)]) (>  (←) x))))
(define (core:geq?)   (→ (let ([x (←)]) (>= (←) x))))

(define (core:nor)    (→ (let ([x (←)]) (nor (←) x))))

(define (core:null?)  (→ (null? (←))))
(define (core:atom?)  (→ (atom? (←))))
(define (core:host?)  (→ (host? (←))))
(define (core:pair?)  (→ (pair? (←))))
(define (core:clos?)  (→ (clos? (←))))

(define (mark-clos clos) (procedure-rename clos (gensym 'clos)))

(define-syntax mk-clos
  (syntax-rules ()
    [(_ ex)    (mark-clos (λ () (let* ex (void))))]
    [(_ hd ex) (mark-clos (λ () (let* ([hd {hosts}] . ex) (merge hd {hosts}))))]))

(define none '([#: . ()]))
(define-syntax-rule
  (isolate ex)
  (splicing-parameterize
      ([hosts ({hosts} . or . none)]
       [under ({under} . or . '#:)]
       [stack ({stack} . or . null)]
       [trace ({trace} . or . null)]
       [depth ({depth} . or . 0)])
    ex))

spork.rkt

#lang racket/base

(require
  (for-syntax
   "sugar.rkt"
   racket/base
   syntax/parse
   racket/syntax)
  (only-in
   "spoon.rkt" isolate mk-clos → ← ⇒ ♯ ≫ ≪))

(provide
  spork sporklet ς σ)

(begin-for-syntax
  (define pin (generate-temporary 'pin))
  (define who (generate-temporary 'who))
  
  (define-syntax-class
    host
    #:attributes
    ([ex 0])
    #:datum-literals (unquote quasiquote)
    
    ; call-like
    (pattern foo:keyword
      #:attr ex #'([who (♯ 'foo)]))

    ; pull-like
    (pattern `()
      #:attr ex #'([who (≫ (← '()))]))

    (pattern `foo:keyword
      #:attr ex #'([who (≫ 'foo)]))

    ; push-like
    (pattern ,()
      #:attr ex #'([who (≪ (← '()))]))

    (pattern ,foo:keyword
      #:attr ex #'([who (≪ 'foo)])))

  (define out (generate-temporary 'push))

  (define-syntax-class
    atom
    #:attributes
    ([ex 0])
    #:datum-literals (quote)
    
    (pattern '()
      #:attr ex #'([out (→ null)]))
    
    (pattern (~or* 'foo:id 'foo:keyword foo:string foo:char foo:bytes foo:number foo:boolean)
      #:attr ex #'([out (→ 'foo)])))
  
  (define-syntax-class
    call
    #:attributes
    ([ex 0])

    ; affirmation
    (pattern foo:echo
      #:with (c:call ...) #'foo.ex
      #:attr ex #'((~@ . c.ex) ...))
    
    (pattern #[foo:core]
      #:attr ex #'([out (⇒ foo.ex)]))

    (pattern foo:fork
      #:attr ex #'([out (⇒ foo)])))

  (define-syntax-class
    push
    #:attributes
    ([ex 0])
    #:datum-literals (unquote)
    
    (pattern ,foo:atom
      #:attr ex #'foo.ex)

    ; replication
    (pattern ,foo:echo
      #:with (__ ...)     #'foo.ex
      #:with (p:push ...) #'(,__ ...)
      #:attr ex #'((~@ . p.ex) ...))
    
    (pattern ,#[foo:core]
      #:attr ex #'([out (→ foo.ex)]))
    
    (pattern ,foo:fork
      #:attr ex #'([out (→ foo)])))
  
  (define-syntax-class
    pull
    #:attributes
    ([ex 0])
    #:datum-literals (quasiquote)

    ; elision
    (pattern `foo:echo
      #:with (__ ...)     #'foo.ex
      #:with (p:pull ...) #'(`__ ...)
      #:attr ex #'((~@ . p.ex) ...))
    
    (pattern `foo:fork
      #:attr ex #'([foo (← 'foo)]))
    
    ; spoonerism
    (pattern (~or* `foo:push `foo:pull)
      #:attr __ (generate-temporary '__)
      #:attr ex #'([__ (← '__)] (~@ . foo.ex) [out (→ __)])))

  (define-syntax-class
    xeno
    #:attributes
    ([ex 0])
    #:datum-literals (unquote-splicing)
    
    (pattern ,@foo:expr
      #:attr ex #'([out (→ foo)])))
  
  (define-syntax-class
    clos
    #:attributes
    ([ex 0])

    (pattern ()
      #:attr fn #'void
      #:attr ex #'([out (→ fn)]))
    
    (pattern (foo:program)
      #:attr fn
      (if (not (attribute foo.h?))
          #'(mk-clos foo.ex)
          #'(mk-clos pin foo.ex))
      #:attr ex #'([out (→ fn)])))
  
  (define-syntax-class
    term
    #:attributes
    ([ex 0]
     [h? 0])
    
    (pattern :host
      #:attr h? #true)
    
    (pattern (~or* :pull :push :clos :atom :call :xeno)
      #:attr h? #false))
  
  (define-splicing-syntax-class
    program
    #:attributes
    ([ex 0]
     [h? 0]
     [xp 0])
    #:datum-literals (export)

    (pattern {~seq u:term p:program}
      #:attr ex #'((~@ . u.ex) (~@ . p.ex))
      #:attr h? ((attribute u.h?) . or . (attribute p.h?))
      #:attr xp (attribute p.xp))

    (pattern #[export foo:fork ...+]
      #:attr ex #'()
      #:attr h? #false
      #:attr xp #'(foo ...))
    
    (pattern (~peek-not _)
      #:attr ex #'()
      #:attr h? #false
      #:attr xp #false)))

(define-syntax (spork stx)
  (syntax-parse stx
    [(_ :program)
     (if (not (attribute xp))
         #'(let* ex (void))
         #'(define-values xp
             (let* ex (values . xp))))]))

(define-syntax-rule
  (sporklet exs ...) (isolate (spork exs ...)))

(define-syntax ς (make-rename-transformer #'spork))
(define-syntax σ (make-rename-transformer #'sporklet))

(sporklet
 ; utility functions
 ; ------------------------------------
 (`_)                            `pop
 (`_,_₂)                         `dup
 (`_ _)                          `app
 (#t #[ψ])                       `swap
 (`a `b `c ,c ,b ,a ,c)          `over2
 (`a `b `c ,b ,a ,c)             `rot
 
 (#[⊢] `_)                       `drop
 (#[depth] drop)                 `none
 
 (app #[ψ] `_ app)               `if
 (`f `t `c `fn ,f ,t ,c fn)      `endif
 
 ; recursion using the Y-combinator
 ;-------------------------------------
 (`f (`x (,x x) f) dup app)      `Y
 (`_ (,_ Y))                     `rec

 (`self
  `fn `n
  (fn ,n 1 sub ,fn self) () (0 ,n #[=]) if)
 rec `repeat

 ; arithmetic operators
 ;-------------------------------------
 ,#[+]                           `add
 (#[⊖] #[+])                     `sub
 (`y `x ,@(*    x y))            `mul
 (`y `x ,@(/    x y))            `div
 (`y `x ,@(expt x y))            `pow

 ; boolean operators
 ;-------------------------------------
 ,#[•]                           `nor
 (#f nor)                        `not
 (nor not)                       `or
 (`x not ,x not nor)             `and
 
 ; list operations
 ;-------------------------------------
 (`self
  `_
  (#f (,_ #[cdr] self) (,_ #[pair?]) if) #t (,_ #[nil?]) if)
 rec
 `list?
 
 (`self
  `fn `ls
  (,ls #[cdr])            `get-tail
  (,ls #[car] fn #[cons]) `app-cons
  (,fn self)              `map-rest
  (get-tail map-rest app-cons) '() (,ls #[nil?]) if)
 rec
 `map
 
 (`self
  `fn `accu `ls
  (,ls #[cdr])          `get-tail
  (,accu ,ls #[car] fn) `app-func
  (,fn self)            `fold-rest
  (get-tail app-func fold-rest) accu (,ls #[nil?]) if)
 rec
 `foldl
 
 ('() ,#[cons] foldl) `reverse

 ; functional operations
 ;-------------------------------------
 (`self) rec `curry
 (`self) rec `uncurry
 (swap app)  `::
 
 #[export
   pop dup app swap over2 rot

   drop none

   Y rec repeat

   if endif

   add sub mul div pow

   not or and

   list? map foldl reverse])

#;(sporklet
 ("congo" "bongo" "bango" "bingo") `phrase
 
 phrase
 `_,_    stack print none
 phrase
 `_`,_   stack print none
 phrase
 `_``,_  stack print none
 phrase
 `_```,_ stack print none
 
 phrase
 `_₂,_   stack print none
 phrase
 `_₂`,_  stack print none
 phrase
 `_₂``,_ stack print none

 phrase
 `_₃,_   stack print none
 phrase
 `_₃`,_  stack print none

 phrase
 `_₄,_   stack print none

 ,stack app print none)

#;(sporklet
 (dup mul)      `sqr
 (`_ ,@(abs _)) `abs
 
 [#[under]
  `$
  [sqr ,$ `()] `sqr
  [abs ,$ `()] `abs
  `#:x dup `#:y `#:y `#:z
   #:z pop
   #:y sqr #:x sqr $ add #:y abs $ sub]
 `y²+x²-|y|
 
 #:foo
 3 2 1 y²+x²-|y|
 #:bar
 4 3 2 y²+x²-|y|
 #:baz
 2 3 4 y²+x²-|y|
 #:foo
 1 2 3 y²+x²-|y|
 #[hosts] #[print]

 #[hosts] '#:bif #[∃] #[print]

 1 #[list] 2 #[cons] 3 #[cons]
 2 #[∋] #[print])

#;(sporklet
 1 `x
 2 `y
 3 `z
 ,x #[list] ,y #[cons] ,z #[cons]
 #[print])

(sporklet
 (swap #[cons]) `snoc
 
 1 2 3 4 5 6 7 '()
 snoc₇ #[print])

#;(sporklet
 5 4 3 2 1
 depth 1 sub ,mul repeat
 stack print)

#;(sporklet
 1 2 3 4 5
 stack print
 
 #: 3 ⊢ `#:A
 #:A ⊣ `x `y `z ,z ,y add ,x sub
 `#:

 #: 2 ⊢ `#:B
 #:B ⊣ `x `y ,y ,y add ,x sub
 `#:
 
 #: add stack print

 '#:foo
 under print
 `_ _
 under print
 #:
 3 2 1 3 ⊢
 '#:bar `()
 hosts print
 '#:bar ,() ⊣
 hosts print)

#;(sporklet
 '() 2 cons list? print
 
 4 3 2 1   
 add₃  stack print
 5 sub stack print
 3 mul stack print
 5 div stack print
 2 pow stack print
 
 pop
 #f #t
 and stack print
 #t
 or  stack print
 not stack print
 
 pop
 4 3 2 1
 stack print

 4 ,print repeat
 
 4 3 2 1
 3 ,mul repeat
 stack print
 
 pop
 ,add `fn
 
 (`fn (`x (`y ,y ,x fn))) `curry2
 (`fn (,fn app app))      `uncurry2
 
 ,fn curry2               `fn-curried
 ,fn-curried uncurry2     `fn-uncurried
 (swap app)               `::
 
 5 4 fn print
 ,fn-curried 4 :: 5 :: print
 5 4 fn-uncurried print
 
 ; idem
 0 ⊓ ⊔ print
 0 ⊔ ⊓ print
 
 ; J = πi
 J print
 
 ; -1 * 5
 5 ⊔ J + ⊓
 re print

 ; e^(J + J)
 J₂ + ⊓ print
 
 ; - 5
 5 ⊖ print
 
 ; 5 * 5
 5 ⊔
 5 ⊔
 + ⊓
 re print
 
 ; 25 / 5
 25 ⊔
  5 ⊔ ⊖
  + ⊓
 re print
 
 ; 5 ^ 2
 5 ⊔₂
 2 ⊔
 + ⊓₂
 re print
 
 ; 5 ^ -2
 5 ⊔₂
 2 ⊖ ⊔
 + ⊓₂
 re print
 
 ; √25
 25 ⊔₂
  2 ⊔ ⊖
  + ⊓₂
 re print
 
 ; log_5 25
 25 ⊔₂
  5 ⊔₂ ⊖
  + ⊓
 re print

 (`_ ⊔₂
  ,_ ⊔ ⊖
   + ⊓₂) `root

 (`_ ⊔₂
  ,_ ⊔
   + ⊓₂) `expt

 (`_ ⊔₂
  ,_ ⊔₂ ⊖
   + ⊓)  `log

 1/25 -1 expt print
 
 1000 10 log print

 1 ⊓ print

 1 ⊖ 2 root print

 0 ⊓ ⊖ ⊔ print

 2 2 pop₂)

sugar.rkt

#lang racket/base

(require
  syntax/parse
  racket/syntax
  (only-in
   racket/list make-list)
  (for-template "spoon.rkt"))

(provide
  echo core fork)

(define-syntax-class
  name
  #:datum-literals (quote quasiquote unquote unquote-splicing)
  (pattern (~and :id (~not (~or* quote quasiquote unquote unquote-splicing)))))

(define (subscript-error x)
  (λ _ (raise-syntax-error 'spork "invalid subscript" x)))
  
(define  rx-subscript  #px"^(.+?)(\\p{No}+)$")
(define (subscript? x) (regexp-match rx-subscript (symbol->string x)))
(define  ch-subscript  (hasheq #\₀ #\0 #\₁ #\1 #\₂ #\2 #\₃ #\3 #\₄ #\4
                               #\₅ #\5 #\₆ #\6 #\₇ #\7 #\₈ #\8 #\₉ #\9))
(define (ch-convert x) (hash-ref ch-subscript x (subscript-error x)))
(define (subscript->number sub)
  (string->number (list->string (map ch-convert (string->list sub)))))

(define fst cadr)
(define snd caddr)
(define-syntax-class
  echo
  #:attributes
  ([ex 0])

  (pattern #[bar:name]
    #:do [(define maybe (subscript? (syntax-e #'bar)))]
    #:when maybe
    #:do [(define foo (format-id #'bar "~a" (fst maybe)))
          (define cnt (subscript->number (snd maybe)))]
    #:attr ex #`#,(make-list cnt `#[,foo]))
  
  (pattern bar:name
    #:do [(define maybe (subscript? (syntax-e #'bar)))]
    #:when maybe
    #:do [(define foo (format-id #'bar "~a" (fst maybe)))
          (define cnt (subscript->number (snd maybe)))]
    #:attr ex #`#,(make-list cnt foo)))

(define-syntax-class
  core
  #:attributes
  ([ex 0])
  #:datum-literals
  (hosts under stack trace depth
   host? atom? clos?
   print write read
   ⊢ ⊣ ∃ ∋
   ≡ ψ •
   re im ⊖ + ⊓ ⊔ J
   = < > ≤ ≥
   cons car cdr list
   nil? pair?)
    
  (pattern hosts #:attr ex #'core:hosts)
  (pattern under #:attr ex #'core:under)
  (pattern stack #:attr ex #'core:stack)
  (pattern trace #:attr ex #'core:trace)
  (pattern depth #:attr ex #'core:depth)
    
  (pattern print #:attr ex #'core:print)
    
  (pattern cons  #:attr ex #'core:cons)
  (pattern car   #:attr ex #'core:car)
  (pattern cdr   #:attr ex #'core:cdr)
  (pattern list  #:attr ex #'core:list)
    
  (pattern ⊢     #:attr ex #'core:take)
  (pattern ⊣     #:attr ex #'core:feed)
  (pattern ∃     #:attr ex #'core:lookup)
  (pattern ∋     #:attr ex #'core:member)
    
  (pattern ≡     #:attr ex #'core:equal?)
  (pattern ψ     #:attr ex #'core:which)
    
  (pattern J     #:attr ex #'core:jay)
  (pattern ⊖     #:attr ex #'core:neg)
  (pattern +     #:attr ex #'core:add)
  (pattern ⊓     #:attr ex #'core:exp)
  (pattern ⊔     #:attr ex #'core:log)

  (pattern =     #:attr ex #'core:eq?)
  (pattern <     #:attr ex #'core:lt?)
  (pattern ≤     #:attr ex #'core:leq?)
  (pattern >     #:attr ex #'core:gt?)
  (pattern ≥     #:attr ex #'core:geq?)
    
  (pattern •     #:attr ex #'core:nor)
    
  (pattern re    #:attr ex #'core:real)
  (pattern im    #:attr ex #'core:imag)
    
  (pattern atom? #:attr ex #'core:atom?)
  (pattern host? #:attr ex #'core:host?)
  (pattern nil?  #:attr ex #'core:null?)
  (pattern pair? #:attr ex #'core:pair?)
  (pattern clos? #:attr ex #'core:clos?))

(define-syntax-class
  fork
  (pattern (~and ex:name (~not :core))))

I'll see; I feel as though using the let-bindings somewhat diminishes the extensibility, but I admit that I probably have a poor grasp on either of the choices' trade-offs at this point. This is super cool in DrRacket, though.

Pipes!

Better keyword semantics (I think).

We get swaps for free!

Keywords were for stacks--obvious in hindsight.

Subscripts make calling commands repeatedly much more readable.

Exports!