Přemysl Eric Janouch
50057d5149
I'm not entirely sure, but it looks like some people might not like jokes about the Holocaust. On a more serious note, the project has become more serious over the 7 or so years of its existence.
242 lines
9.8 KiB
Scheme
Executable File
242 lines
9.8 KiB
Scheme
Executable File
#!/usr/bin/env guile
|
|
|
|
xB calc plugin, basic Scheme evaluator
|
|
|
|
Copyright 2016 Přemysl Eric Janouch
|
|
See the file LICENSE for licensing information.
|
|
|
|
!#
|
|
|
|
(import (rnrs (6)))
|
|
(use-modules ((rnrs) :version (6)))
|
|
|
|
; --- Message parsing ----------------------------------------------------------
|
|
|
|
(define-record-type message (fields prefix command params))
|
|
(define (parse-message line)
|
|
(let f ([parts '()] [chars (string->list line)])
|
|
(define (take-word w chars)
|
|
(if (or (null? chars) (eqv? (car chars) #\x20))
|
|
(f (cons (list->string (reverse w)) parts)
|
|
(if (null? chars) chars (cdr chars)))
|
|
(take-word (cons (car chars) w) (cdr chars))))
|
|
(if (null? chars)
|
|
(let ([data (reverse parts)])
|
|
(when (< (length data) 2)
|
|
(error 'parse-message "invalid message"))
|
|
(make-message (car data) (cadr data) (cddr data)))
|
|
(if (null? parts)
|
|
(if (eqv? (car chars) #\:)
|
|
(take-word '() (cdr chars))
|
|
(f (cons #f parts) chars))
|
|
(if (eqv? (car chars) #\:)
|
|
(f (cons (list->string (cdr chars)) parts) '())
|
|
(take-word '() chars))))))
|
|
|
|
; --- Utilities ----------------------------------------------------------------
|
|
|
|
(define (display-exception e port)
|
|
(define (puts . x)
|
|
(for-all (lambda (a) (display a port)) x)
|
|
(newline port))
|
|
|
|
(define (record-fields rec)
|
|
(let* ([rtd (record-rtd rec)]
|
|
[v (record-type-field-names rtd)]
|
|
[len (vector-length v)])
|
|
(map (lambda (k i) (cons k ((record-accessor rtd i) rec)))
|
|
(vector->list v)
|
|
(let c ([i len] [ls '()])
|
|
(if (= i 0) ls (c (- i 1) (cons (- i 1) ls)))))))
|
|
|
|
(puts "Caught " (record-type-name (record-rtd e)))
|
|
(for-all
|
|
(lambda (subtype)
|
|
(puts " " (record-type-name (record-rtd subtype)))
|
|
(for-all
|
|
(lambda (field) (puts " " (car field) ": " (cdr field)))
|
|
(record-fields subtype)))
|
|
(simple-conditions e)))
|
|
|
|
; XXX - we have to work around Guile's lack of proper eol-style support
|
|
(define xc (make-transcoder (latin-1-codec) 'lf 'replace))
|
|
(define irc-input-port (transcoded-port (standard-input-port) xc))
|
|
(define irc-output-port (transcoded-port (standard-output-port) xc))
|
|
|
|
(define (send . message)
|
|
(for-all (lambda (x) (display x irc-output-port)) message)
|
|
(display #\return irc-output-port)
|
|
(newline irc-output-port)
|
|
(flush-output-port irc-output-port))
|
|
|
|
(define (get-line-crlf port)
|
|
(define line (get-line port))
|
|
(if (eof-object? line) line
|
|
(let ([len (string-length line)])
|
|
(if (and (> len 0) (eqv? (string-ref line (- len 1)) #\return))
|
|
(substring line 0 (- len 1)) line))))
|
|
|
|
(define (get-config name)
|
|
(send "ZYKLONB get_config :" name)
|
|
(car (message-params (parse-message (get-line-crlf irc-input-port)))))
|
|
|
|
(define (extract-nick prefix)
|
|
(do ([i 0 (+ i 1)] [len (string-length prefix)])
|
|
([or (= i len) (char=? #\! (string-ref prefix i))]
|
|
[substring prefix 0 i])))
|
|
|
|
(define (string-after s start)
|
|
(let ([s-len (string-length s)] [with-len (string-length start)])
|
|
(and (>= s-len with-len)
|
|
(string=? (substring s 0 with-len) start)
|
|
(substring s with-len s-len))))
|
|
|
|
; --- Calculator ---------------------------------------------------------------
|
|
|
|
; Evaluator derived from the example in The Scheme Programming Language.
|
|
;
|
|
; Even though EVAL with a carefully crafted environment would also do a good
|
|
; job at sandboxing, it would probably be impossible to limit execution time...
|
|
|
|
(define (env-new formals actuals env)
|
|
(cond [(null? formals) env]
|
|
[(symbol? formals) (cons (cons formals actuals) env)]
|
|
[else (cons (cons (car formals) (car actuals))
|
|
(env-new (cdr formals) (cdr actuals) env))]))
|
|
(define (env-lookup var env) (cdr (assq var env)))
|
|
(define (env-assign var val env) (set-cdr! (assq var env) val))
|
|
|
|
(define (check-reductions r)
|
|
(if (= (car r) 0)
|
|
(error 'check-reductions "reduction limit exceeded")
|
|
(set-car! r (- (car r) 1))))
|
|
|
|
; TODO - think about implementing more syntactical constructs,
|
|
; however there's not much point in having anything else in a calculator...
|
|
(define (exec expr r env)
|
|
(check-reductions r)
|
|
(cond [(symbol? expr) (env-lookup expr env)]
|
|
[(pair? expr)
|
|
(case (car expr)
|
|
[(quote) (cadr expr)]
|
|
[(lambda) (lambda vals
|
|
(let ([env (env-new (cadr expr) vals env)])
|
|
(let loop ([exprs (cddr expr)])
|
|
(if (null? (cdr exprs))
|
|
(exec (car exprs) r env)
|
|
(begin (exec (car exprs) r env)
|
|
(loop (cdr exprs)))))))]
|
|
[(if) (if (exec (cadr expr) r env)
|
|
(exec (caddr expr) r env)
|
|
(exec (cadddr expr) r env))]
|
|
[(set!) (env-assign (cadr expr) (exec (caddr expr) r env) env)]
|
|
[else (apply (exec (car expr) r env)
|
|
(map (lambda (x) (exec x r env)) (cdr expr)))])]
|
|
[else expr]))
|
|
|
|
(define-syntax forward
|
|
(syntax-rules ()
|
|
[(_) '()]
|
|
[(_ a b ...) (cons (cons (quote a) a) (forward b ...))]))
|
|
|
|
; ...which can't prevent me from simply importing most of the standard library
|
|
(define base-library
|
|
(forward
|
|
; Equivalence, procedure predicate, booleans
|
|
eqv? eq? equal? procedure? boolean? boolean=? not
|
|
; numbers, numerical input and output
|
|
number? complex? real? rational? integer? exact? inexact? exact inexact
|
|
real-valued? rational-valued? integer-valued? number->string string->number
|
|
; Arithmetic
|
|
= < > <= >= zero? positive? negative? odd? even? finite? infinite? nan?
|
|
min max + * - / abs div-and-mod div mod div0-and-mod0 div0 mod0
|
|
gcd lcm numerator denominator floor ceiling truncate round
|
|
rationalize exp log sin cos tan asin acos atan sqrt expt
|
|
make-rectangular make-polar real-part imag-part magnitude angle
|
|
; Pairs and lists
|
|
map for-each cons car cdr caar cadr cdar cddr
|
|
caaar caadr cadar caddr cdaar cdadr cddar cdddr
|
|
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
|
|
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
|
|
pair? null? list? list length append reverse list-tail list-ref
|
|
; Symbols
|
|
symbol? symbol=? symbol->string string->symbol
|
|
; Characters
|
|
char? char=? char<? char>? char<=? char>=? char->integer integer->char
|
|
; Strings; XXX - omitted make-string - can cause OOM
|
|
string? string=? string<? string>? string<=? string>=?
|
|
string string-length string-ref substring
|
|
string-append string->list list->string string-for-each string-copy
|
|
; Vectors; XXX - omitted make-vector - can cause OOM
|
|
vector? vector vector-length vector-ref vector-set!
|
|
vector->list list->vector vector-fill! vector-map vector-for-each
|
|
; Control features
|
|
apply call/cc values call-with-values dynamic-wind))
|
|
(define extended-library
|
|
(forward
|
|
char-upcase char-downcase char-titlecase char-foldcase
|
|
char-ci=? char-ci<? char-ci>? char-ci<=? char-ci>=?
|
|
char-alphabetic? char-numeric? char-whitespace?
|
|
char-upper-case? char-lower-case? char-title-case?
|
|
string-upcase string-downcase string-titlecase string-foldcase
|
|
string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
|
|
find for-all exists filter partition fold-left fold-right
|
|
remp remove remv remq memp member memv memq assp assoc assv assq cons*
|
|
list-sort vector-sort vector-sort!
|
|
bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-if
|
|
bitwise-bit-count bitwise-length bitwise-first-bit-set bitwise-bit-set?
|
|
bitwise-copy-bit bitwise-bit-field bitwise-copy-bit-field
|
|
bitwise-arithmetic-shift bitwise-rotate-bit-field bitwise-reverse-bit-field
|
|
bitwise-arithmetic-shift-left bitwise-arithmetic-shift-right
|
|
set-car! set-cdr! string-set! string-fill!))
|
|
(define (interpret expr)
|
|
(exec expr '(2000) (append base-library extended-library)))
|
|
|
|
; We could show something a bit nicer but it would be quite Guile-specific
|
|
(define (error-string e)
|
|
(map (lambda (x) (string-append " " (symbol->string x)))
|
|
(filter (lambda (x) (not (member x '(&who &message &irritants &guile))))
|
|
(map (lambda (x) (record-type-name (record-rtd x)))
|
|
(simple-conditions e)))))
|
|
|
|
(define (calc input respond)
|
|
(define (stringify x)
|
|
(call-with-string-output-port (lambda (port) (write x port))))
|
|
(guard (e [else (display-exception e (current-error-port))
|
|
(apply respond "caught" (error-string e))])
|
|
(let* ([input (open-string-input-port input)]
|
|
[data (let loop ()
|
|
(define datum (get-datum input))
|
|
(if (eof-object? datum) '() (cons datum (loop))))])
|
|
(call-with-values
|
|
(lambda () (interpret (list (append '(lambda ()) data))))
|
|
(lambda message
|
|
(for-all (lambda (x) (respond (stringify x))) message))))))
|
|
|
|
; --- Main loop ----------------------------------------------------------------
|
|
|
|
(define prefix (get-config "prefix"))
|
|
(send "ZYKLONB register")
|
|
|
|
(define (process msg)
|
|
(when (string-ci=? (message-command msg) "PRIVMSG")
|
|
(let* ([nick (extract-nick (message-prefix msg))]
|
|
[target (car (message-params msg))]
|
|
[response-begin
|
|
(apply string-append "PRIVMSG "
|
|
(if (memv (string-ref target 0) (string->list "#&!+"))
|
|
`(,target " :" ,nick ": ") `(,nick " :")))]
|
|
[respond (lambda args (apply send response-begin args))]
|
|
[text (cadr (message-params msg))]
|
|
[input (or (string-after text (string-append prefix "calc "))
|
|
(string-after text (string-append prefix "= ")))])
|
|
(when input (calc input respond)))))
|
|
|
|
(let main-loop ()
|
|
(define line (get-line-crlf irc-input-port))
|
|
(unless (eof-object? line)
|
|
(guard (e [else (display-exception e (current-error-port))])
|
|
(unless (string=? "" line)
|
|
(process (parse-message line))))
|
|
(main-loop)))
|