implementations/scheme-chicken/joy.scm

   1 |*
   2
   3 ████████╗██╗  ██╗██╗   ██╗███╗   ██╗
   4 ╚══██╔══╝██║  ██║██║   ██║████╗  ██║
   5    ██║   ███████║██║   ██║██╔██╗ ██║
   6    ██║   ██╔══██║██║   ██║██║╚██╗██║
   7    ██║   ██║  ██║╚██████╔╝██║ ╚████║
   8    ╚═╝   ╚═╝  ╚═╝ ╚═════╝ ╚═╝  ╚═══╝
   9
  10 Copyright © 2023 Simon Forman
  11
  12 This file is part of Thun
  13
  14 Thun is free software: you can redistribute it and/or modify
  15 it under the terms of the GNU General Public License as published by
  16 the Free Software Foundation, either version 3 of the License, or
  17 (at your option) any later version.
  18
  19 Thun is distributed in the hope that it will be useful,
  20 but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 GNU General Public License for more details.
  23
  24 You should have received a copy of the GNU General Public License
  25 along with Thun.  If not see <http://www.gnu.org/licenses/>.
  26
  27 *|
  28
  29 (import (chicken io))
  30 (import (chicken string))
  31 (import srfi-69)
  32
  33 ;(load "defs.scm") ; csc -prologue defs.scm joy.scm
  34 (cond-expand
  35   (chicken-script (load "defs.scm"))
  36   (else))
  37
  38 (define (joy stack expression dict)
  39   (if (null? expression)
  40     (values stack dict)
  41     (if (string? (car expression))
  42       (receive (s e d)
  43         (joy-eval (car expression) stack (cdr expression) dict)
  44         (joy s e d))
  45       (joy (cons (car expression) stack) (cdr expression) dict))))
  46
  47 (define (joy-eval symbol stack expression dict)
  48   (define (is-it? name) (string=? symbol name))
  49   (cond
  50     ((is-it? "+") (values (joy-add stack) expression dict))
  51     ((is-it? "-") (values (joy-sub stack) expression dict))
  52     ((is-it? "mul") (values (joy-mul stack) expression dict))
  53     ((is-it? "dup") (values (joy-dup stack) expression dict))
  54     ((hash-table-exists? dict symbol)
  55       (values stack (append (hash-table-ref dict symbol) expression) dict))
  56     (else (error "Unknown word."))))
  57
  58 (define (joy-add stack) (cons (+ (cadr stack) (car stack)) (cddr stack)))
  59 (define (joy-sub stack) (cons (- (cadr stack) (car stack)) (cddr stack)))
  60 (define (joy-mul stack) (cons (* (cadr stack) (car stack)) (cddr stack)))
  61 (define (joy-dup stack) (cons (car stack) stack))
  62
  63
  64 (define (string-replace str from to)
  65   (string-intersperse (string-split str from #t) to))
  66
  67 (define (tokenize str)
  68   (string-split
  69     (string-replace (string-replace str "]" " ] ") "[" " [ ")))
  70
  71 (define (tokenator token)
  72   (cond ((string->number token) (string->number token))
  73         ((string=? token "true") #t)
  74         ((string=? token "false") #f)
  75         (else token)))
  76
  77 (define (expect-right-bracket tokens acc)
  78   (if (null? tokens)
  79     (error "Missing closing bracket.")
  80     (expect-right-bracket-lookahead (car tokens) (cdr tokens) acc)))
  81
  82 (define (expect-right-bracket-lookahead token tokens acc)
  83   (cond ((string=? token "]") (values acc tokens))
  84         ((string=? token "[")
  85           (receive (sub_list rest) (expect-right-bracket tokens '())
  86             (receive (el rrest) (expect-right-bracket rest acc)
  87               (values (cons sub_list el) rrest))))
  88         (else
  89           (receive (el rest) (expect-right-bracket tokens acc)
  90             (values (cons (tokenator token) el) rest)))))
  91
  92 (define (one-token-lookahead token tokens)
  93   (cond ((string=? token "]") (error "Extra closing bracket."))
  94         ((string=? token "[") (expect-right-bracket tokens '()))
  95         (else (values (tokenator token) tokens))))
  96
  97 (define (parse0 tokens acc)
  98   (if (null? tokens)
  99     acc
 100     (receive (term rest_of_tokens)
 101       (one-token-lookahead (car tokens) (cdr tokens))
 102       (cons term (parse0 rest_of_tokens acc)))))
 103
 104 (define (parse tokens) (parse0 tokens '()))
 105
 106 (define (text->expression text) (parse (tokenize text)))
 107
 108
 109 (define (joy-term->string term)
 110   (cond ((boolean? term) (if term "true" "false"))
 111         ((number? term) (->string term))
 112         ((list? term) (conc "[" (joy-expression->string term) "]"))
 113         (else term)))
 114
 115 (define (joy-expression->string expr)
 116   (string-intersperse (map joy-term->string expr) " "))
 117
 118 (define (doit text)
 119   (receive (stack _dict)
 120     (joy '() (text->expression text) (initialize))
 121     (joy-expression->string stack)))
 122
 123
 124 (define (initialize)
 125   (load-defs (make-hash-table string=? string-hash)))
 126
 127 (define (load-defs dict)
 128   (map (lambda (def) (add-def def dict)) (defs))  ;defs is defined in defs.scm
 129   dict)
 130
 131 (define (add-def def dict)
 132   (let ((def_list (text->expression def)))
 133     (hash-table-set! dict (car def_list) (cdr def_list))))
 134
 135
 136 (display (doit "12  23 [[  ]] 23 4 - dup - [true] false 23 sqr"))
 137 (newline)
 138