implementations/scheme-chicken/joy.scm

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