Small-Lisp Ver.1.3

	#!/usr/bin/env bash
	mzscheme slisp.ss

view raw slisp hosted with ❤ by GitHub

	;; mzscheme slisp.ss
	#lang scheme
	(require "small-lisp-ver.1.3.ss")
	(slisp-load "slisp.slisp")
	(slisp)

view raw slisp.ss hosted with ❤ by GitHub

	;; Small-Lisp, based on the textbook "Schemeによる記号処理入門",
	;; implements now 15 Lisp functions such as null?, 1st, 2nd, 3rd, rst,
	;; cons, atom?, is?, +, -, *, /, >, < and fn as primitives.
	;; Version.1.3 has three special operators, if, = and def, which are all
	;; inspired by Paul Graham's Arc. = is setf of CL. def is defun of CL.
	;; Renamed some operators, because I like schemers' way better.
	;; Now Small-Lisp has a file-loading function, slisp-load, then it can
	;; load and evaluate some function-definition files, that define non-primitive
	;; functions defined in Small-Lisp style. "slisp.slisp" provides some functions
	;; such as car, cdr, cadr, caddr, last, append, length, and factorial, all built
	;; on Small-Lisp's primitives.
	;; Redefined some structures by using PLT's hashtables, instead
	;; of using a-lists; therefore, these codes here are heavily
	;; dependent on PLT Scheme.
	;; In addition, REPL is now more CL-like, and true/false is T/NIL, with upper-case.
	(module small-lisp-ver.1.3 scheme
	(provide (all-defined-out))
	;; (s-assoc 'a #hasheq((a . (1 2 3)) (b . 2))) ==> (1 2 3)
	(define (s-assoc x y)
	(hash-ref y x (lambda ()
	(error-message x)
	'())))
	(define (error-message x)
	(for-each display
	`(" **** Unknown expression : " ,x "\n")))
	;; eval 方面
	(define (atom? x)
	(not (pair? x)))
	(define (s-eval exp env)
	(if (atom? exp)
	(s-number? exp env)
	(let ((key (car exp)) (body (cdr exp)))
	(case key
	((if) (eval-if body env))
	((=) (eval-= body env))
	((def) (eval-def body env))
	((quote) (car body))
	(else (s-apply key
	(eval-args body env) env))))))
	;; (eval-args '(a b) #hasheq((a . 3) (b . 4))) ==> (3 4)
	(define (eval-args exp env)
	(map (lambda (x)
	(s-eval x env)) exp))
	(define-syntax s-assoc-helper
	(syntax-rules ()
	((_ exp env pred? proc)
	(let ((it (pred? exp)))
	(if it
	(s-assoc (not it) env)
	(proc exp))))))
	(define (s-number? exp env)
	(if (number? exp)
	exp
	(s-assoc exp env)))
	;; (define ht (make-hasheq))
	;; (hash-set! ht #t 'T)
	;; (hash-set! ht #f '())
	;; (hash-set! ht 'x '(1 2 3))
	;; (eval-if '((atom x) x (1st x)) ht) ==> 1
	;;
	(define (eval-if con env)
	(s-assoc-helper con env null?
	(lambda (x)
	(let ((head (car x)) (tail (cdr x)))
	(let ((eval-head (s-eval head env)))
	(cond ((null? tail) eval-head)
	((not (eq? '() eval-head)) (s-eval (car tail) env))
	(else (eval-if (cdr tail) env))))))))
	(define (eval-= exp env)
	(let ((head (car exp)) (val (s-eval (cadr exp) env)))
	(if (atom? head)
	(begin (hash-set! env head val) val)
	(let ((key (cadr head)))
	(let ((var (s-assoc key env)))
	(case (car head)
	((car) (hash-set! env key
	(cons val (cdr var)))
	(s-assoc key env))
	((cdr) (hash-set! env key
	(cons (car var)
	(if (pair? val)
	val
	`(,val))))
	(s-assoc key env))
	(else (error-message exp))))))))
	(define (eval-def exp env)
	(let ((name (car exp))
	(args (cadr exp))
	(body (third exp)))
	(hash-set! env name `(fn ,args ,body))
	name))
	;; apply 方面
	(define (s-null? foo env)
	(s-eval (null? foo) env))
	;; (s-atom? 4) ==> t
	(define (s-atom? foo env)
	(s-eval (not (pair? foo)) env))
	;; (s-is? 1 1) ==> t
	(define (s-is? foo bar env)
	(s-eval (eq? foo bar) env))
	(define-syntax operator-generator
	(syntax-rules ()
	((_ name foo bar acc pred? proc)
	(cond ((pred? foo)
	acc)
	((pred? bar)
	foo)
	(else
	(name (proc foo (car bar)) (cdr bar)))))))
	(define (s-+ foo bar)
	(operator-generator s-+ foo bar 0 null? +))
	(define (s-- foo bar)
	(operator-generator s-- foo bar 0 null? -))
	(define (s-* foo bar)
	(operator-generator s-* foo bar 1 null? *))
	(define (s-/ foo bar)
	(operator-generator s-/ foo bar 1 null? /))
	(define-syntax compare-helper
	(syntax-rules ()
	((_ name foo bar env pred? proc)
	(cond ((pred? foo)
	(error-message foo))
	((pred? bar)
	(s-assoc #t env))
	(else
	(let ((head (car bar)))
	(if (not (proc foo head))
	(s-assoc (proc foo head) env)
	(name head (cdr bar) env))))))))
	(define (s-> foo bar env)
	(compare-helper s-> foo bar env null? >))
	(define (s-< foo bar env)
	(compare-helper s-< foo bar env null? <))
	(define (s-apply func args env)
	(cond
	((null? func)
	(error-message args))
	((pair? func)
	(s-fn? func args env))
	(else
	(let ((head (s-assoc-helper args env null? car))
	(tail (s-assoc-helper args env null? cdr)))
	(let ((head-of-tail (s-assoc-helper tail env null? car)))
	;; 基本関数の処理
	(case func
	((null?) (s-null? head env))
	((1st) (s-assoc-helper head env null? car))
	((2nd) (s-assoc-helper head env (lambda (x) (< (length x) 2)) cadr))
	((3rd) (s-assoc-helper head env (lambda (x) (< (length x) 3)) caddr))
	((rst) (s-assoc-helper head env null? cdr))
	((cons) (cons head head-of-tail))
	((atom?) (s-atom? head env))
	((is?) (s-is? head head-of-tail env))
	((+) (s-+ head tail))
	((-) (s-- head tail))
	((*) (s-* head tail))
	((/) (s-/ head tail))
	((>) (s-> head tail env))
	((<) (s-< head tail env))
	;; 基本関数以外の関数に対する評価
	(else (s-apply (s-eval func env) args env))))))))
	;; lambda式の処理
	(define (s-fn? func args env)
	(if (eq? (car func) 'fn)
	(s-eval (third func)
	(pairlis->hash (cadr func) args env))
	(error-message args)))
	;; REPL
	;; プロンプトの表示とS式の読み込み
	(define (prompt)
	(begin (display "SL-USER> ")
	(read)))
	(define *version* "Small-Lisp Ver.1.3\n")
	(define (slisp)
	(define (loop exp)
	(if (and (list? exp) ;終了条件のチェック
	(memv (car exp)
	'(bye quit end exit)))
	'GOOD-BYE
	(let ((c (begin (display (null-environment? exp *environment*))
	(newline))))
	(loop (prompt)))))
	(display *version*)
	(init-environment) ;環境の初期設定
	(loop (prompt))) ;プロンプトの表示/S式の読み込み
	(define *environment* (make-hasheq)) ;大域変数の宣言
	(define (init-environment) ;環境の初期設定
	(hash-set! *environment* #t 't)
	(hash-set! *environment* #f '()))
	;; (define ht (make-hasheq))
	;; (hash-set! ht 'foo 3)
	;; (pairlis->hash '(i j k) '(a b c) ht) ==> #hasheq((foo . 3) (k . c) (j . b) (i . a))
	;; (define ht2 (make-hasheq))
	;; (pairlis->hash '(a b) '(1 2) ht2) ==> #hasheq((b . 2) (a . 1))
	;;
	(define (pairlis->hash x y z)
	(cond ((or (null? x) (null? y)) z)
	(else (hash-set! z (car x) (car y))
	(pairlis->hash (cdr x) (cdr y) z))))
	(define (null-environment? exp env)
	(let ((it (s-eval exp env)))
	(if (null? it)
	'NIL
	(capital-symbol it))))
	(define (capital-symbol exp)
	(cond ((symbol? exp)
	(string->symbol (string-upcase (symbol->string exp))))
	((list? exp)
	(map capital-symbol exp))
	(else
	exp)))
	;; 外部ライブラリのロード用手続き
	(define (slisp-load filename)
	(letrec ((s-load
	(lambda (p)
	(let ((x (read p)))
	(cond ((eof-object? x)
	(close-input-port p))
	(else
	(s-eval x *environment*)
	(s-load p)))))))
	(call-with-input-file filename s-load)))
	)

view raw small-lisp-ver.1.3.ss hosted with ❤ by GitHub

	;; basic Small-Lisp functions
	(def car (lst)
	(1st lst))
	(def cdr (lst)
	(rst lst))
	(def cadr (lst)
	(2nd lst))
	(def caddr (lst)
	(3rd lst))
	(def last (a)
	(if (null? (rst a))
	a
	(last (rst a))))
	(def append (x y)
	(if (null? x)
	y
	(cons (1st x) (append (rst x) y))))
	(def len (x)
	(len-aux x 0))
	(def len-aux (x acc)
	(if (null? x)
	acc
	(len-aux (rst x) (+ 1 acc))))
	(def factorial (x)
	(fact-aux x 1))
	(def fact-aux (x acc)
	(if (< x 1)
	acc
	(fact-aux (- x 1) (* x acc))))

view raw slisp.slisp hosted with ❤ by GitHub