On this page:
5.1 Quote
5.2 Uplevel
5.3 Intermission:   Utilities
5.4 Execution
5.5 Conditional execution
5.6 Looping

5 Builtins

All non-trivial programs will depend on these builtins.

    5.1 Quote

    5.2 Uplevel

    5.3 Intermission: Utilities

    5.4 Execution

    5.5 Conditional execution

    5.6 Looping

5.1 Quote

context-next-code returns the lexically next item of code. The builtin quote can put this on the stack without evaluating it.

  (quote ctx stack)
  (let-values ([(ctx code) (context-next-code ctx)])
    (if (void? code)
      (interp-error 'quote-nothing)
      (values ctx (cons code stack)))))

We can test this:

(test-case "Quote"
  (let* ([defines (choose-global-builtins 'quote)]
         [ctx (make-context
                #:definitions defines
                ; this renders funny, it should be '(quote hello)
                #:body ''hello)])
    (let-values ([(ctx stack) (interp-run ctx '())])
      (check-equal? ctx (make-context #:definitions defines #:body '()))
      (check-equal? stack '(hello)))))

It should fail if there is nothing to quote:

(test-case "Quote nothing fails"
    (lambda ()
      (let* ([defines (choose-global-builtins 'quote)]
             [ctx (make-context
                    #:definitions defines
                    #:body '(quote))])
        (let-values ([(ctx stack) (interp-run ctx '())])

5.2 Uplevel

context-uplevel moves into the parent context. Normal execution would undo this move immediately, but the builtin uplevel can take a symbol argument off the top of the stack and use interp-eval to sneak in a function to evaluate next.

  (uplevel ctx stack)
  (let* ([ctx (context-uplevel ctx)])
    (if ctx
      (interp-call ctx (cdr stack) (stack-top stack symbol?))
      (interp-error 'root-uplevel))))

A test of quote and uplevel in combination:

  "Uplevel quote"
  (let* ([defines
               'quote 'uplevel)
             'inner-quote '(quote quote uplevel))]
         [ctx (make-context
                #:definitions defines
                #:body '(inner-quote "test"))])
    (let-values ([(ctx stack) (interp-run ctx '())])
      (check-equal? ctx (make-context #:definitions defines #:body '()))
      (check-equal? stack '("test")))))

5.3 Intermission: Utilities

I introduced a few functions there without explaining them. It would be laborious to try and keep track of all defined builtins in order to use them, so let’s keep a set of global builtins and use define-builtin to add to it. define-builtin can use the context and stack, or take some values off the top of the stack using stack-top.

(: *builtins* (Parameterof (Immutable-HashTable Symbol Function)))
(define *builtins* (make-parameter (make-immutable-hash '())))
(: add-global-builtin (Symbol Function . -> . Void))
(define (add-global-builtin name builtin)
  (*builtins* (hash-set (*builtins*) name builtin)))
(define-syntax define-builtin
  (syntax-rules ()
    [(_ (name stack) body ...)
     (define-builtin (name ctx stack) (values ctx (begin body ...)))]
    ; TODO: I tried removing this repetition with a macro,
    ; but it was pretty tough. 3 arguments seems to be enough anyway.
    [(_ (name stack [v1 t1]) body ...)
       (name ctx stack)
       (let ([v1 (stack-top stack t1)])
         (values ctx (begin body ...))))]
    [(_ (name stack [v1 t1] [v2 t2]) body ...)
       (name ctx stack)
       (let ([v1 (stack-top stack t1)]
             [v2 (stack-top (cdr stack) t2)])
         (values ctx (begin body ...))))]
    [(_ (name stack [v1 t1] [v2 t2] [v3 t3]) body ...)
       (name ctx stack)
       (let ([v1 (stack-top stack t1)]
             [v2 (stack-top (cdr stack) t2)]
             [v3 (stack-top (cddr stack) t3)])
         (values ctx (begin body ...))))]
    [(_ (name ctx stack) body ...)
       (Builtin (lambda ([ctx : Context] [stack : Stack]) body ...)))]))
; Pick a subset of builtins, for tests
(: choose-global-builtins (->* () #:rest Symbol
                               (Immutable-HashTable Symbol Function)))
(define (choose-global-builtins . names)
    (map (lambda ([n : Symbol]) (cons n (hash-ref (*builtins*) n))) names)))

stack-top is a simple utility to make sure the stack has a value on top, optionally with the right type.

(: stack-top (All (T) (case-> (Stack . -> . Any)
                              (Stack #t . -> . Any)
                              (Stack (-> Any Boolean : T) . -> . T))))
(define stack-top
     (if (null? stack)
       (interp-error 'stack-empty)
       (car stack))]
    [(stack pred)
       [(null? stack) (interp-error 'stack-empty pred)]
       [(eq? pred #t) (car stack)]
       [(not (pred (car stack)))
        (interp-error 'wrong-type pred)]
       [else (car stack)])]))

5.4 Execution

The builtins call and eval are just wrappers for interp-call and interp-eval respectively.

  (call ctx stack)
  (let ([v (stack-top stack symbol?)]
        [stack (cdr stack)])
    (interp-call ctx stack v)))
  (eval ctx stack)
  (let ([v (stack-top stack function?)]
        [stack (cdr stack)])
    (interp-eval ctx stack v)))

5.5 Conditional execution

Many languages have at least one conditional, usually named if, and often a handful more for specific situations.

Worst only needs one. Every other conditional can be implemented in terms of when, which conditionally performs a call depending on the value of a boolean on the stack.

  (when ctx stack)
  (let* ([name (stack-top stack symbol?)]
         [c (stack-top (cdr stack) boolean?)]
         [stack (cddr stack)])
    (if c
      ; TODO: this could use eval as well
      (interp-call ctx stack name)
      (values ctx stack))))

5.6 Looping

Constructs that require fairly complex syntax, such as for or while, are a little bit chunky compared to everything else defined so far.

Luckily we have recursion, but following in the footsteps of Scheme and automatically squashing tail calls could result in some confusion: uplevel would see a different parent context depending on whether the current function call was in tail position or not.

So, here’s a solution: a builtin that consolidates the current context with the parent, keeping definitions intact. Unlike other “deliberate” tail call systems, this mechanism is used from within the tail call itself. It can serve as a warning that uplevel may require special care, and can be introduced automatically by other looping constructs.

  (tail-call ctx stack)
    ; Only merge if it's safe
      (and (context-parent ctx)
           (context-parent (context-parent ctx))
           (null? (context-body (context-parent ctx)))
           (null? (context-children (context-parent ctx))))
      (context-merge ctx (context-parent ctx))

And context-merge:

(: context-merge (Context Context . -> . Context))
(define (context-merge src dest)
    #:body (context-body src)
    #:children (context-children src)
    #:parent (context-parent dest)
    (let ([src-defs (context-definitions src)]
          [dest-defs (context-definitions dest)])
      (if (hash-empty? dest-defs) src-defs
          ([acc : (Immutable-HashTable Symbol Function) dest-defs])
          ([(k v) (in-hash src-defs)])
          (hash-set acc k v))))))

And a test. This test defines done to return from the interpreter loop early, so it can check the size of the call stack before it has a chance to clean up after itself at the end.

  "Tail calling loop"
  (let ([res
            (lambda ([k : ((Option Context) . -> . Nothing)])
              (let* ([defines
                           'quote 'when 'not 'clone 'tail-call)
                         'done (Builtin
                                 (lambda ([ctx : Context] [_ : Stack])
                                   (k ctx)))
                         'test-tco '(tail-call
                                      clone not quote done when
                                      quote test-tco when))]
                     [ctx (make-context
                            #:definitions defines
                            #:body '(#f #t #t #t #t #t #t #t #t #t #t
                (let-values ([(ctx stack) (interp-run ctx '())])
                  (k #f)))))])
    (check-not-false res)
    (check-false (context-parent (assert res)))))