bsl/language.rkt
#lang racket

;; file: language.rkt
;; author: Bill Turtle
;;
;; Defines the semantics of pyret/bsl


(require syntax/stx)
(require racket/stxparam)
(require racket/unsafe/ops)

(require (prefix-in htdp/bsl: lang/htdp-beginner))

(provide fun def begin local pyret-struct return)
(provide #%datum
         #%module-begin
         #%top-interaction
         #%top
         #%app)

(define source-name (make-parameter #f))

(define-syntax-rule (return expr) expr)
;; An example:
;; struct point (x,y)
;; =>
;; (define (point x y)
;;   (lambda (n)
;;     (cond
;;       ((equal? n 'x) x)
;;       ((equal? n 'y) y)
;;       (else (error 'point "structure has no field named ~a" n))))
;;
;; so a structure is a function, and field access is the result of calling
;; that function

(define-syntax (pyret-struct stx)
  (syntax-case stx ()
    [(_ name (field ...))
       (quasisyntax/loc stx
         (define-struct name (field ...)
           #:property prop:procedure
           (lambda (a-struct field-name)
             (cond
               [(eq? field-name 'field)
                (unsafe-struct-ref a-struct (struct-field-index field))]
               ...
               [else
                (error 'name "unknown field ~a" field-name)]))))]))

(pyret-struct posn (x y))


(define-syntax (fun stx)
  (syntax-case stx ()
    [(_ id (args ...) body) ; 0-arity functions not allowed
     (syntax/loc stx 
       (define (id args ...)
         body))]))

;; check-for-return: (syntax -> syntax)
;; raises an error if there is no 'return' found in tail
(define (check-for-return stx)
  stx) ; this is on the "TODO list"

(define-syntax (def stx)
  (syntax-case stx ()
    [(_ id (args ...) body) ; 0-arity procedures not allowed
     (syntax/loc stx
       (define (id args ...)
         body))]))

;; features from the language to support
(provide * + - / < <= = > >=)
(provide abs
         acos
         add1
         angle
         asin
         atan
         ceiling
         complex?
         conjugate
         cos
         cosh
         (rename-out (current-seconds current_seconds))
         denominator
         (rename-out (htdp/bsl:e e))
         even?
         (rename-out (exact->inexact exact_to_inexact))
         exact?
         exp
         expt
         floor
         gcd
         (rename-out (imag-part imag_part))
         (rename-out (inexact->exact inexact_to_exact))
         inexact?
         (rename-out (integer->char integer_to_char))
         (rename-out (integer-sqrt integer_to_sqrt))
         integer?
         lcm
         log
         magnitude
         (rename-out (make-polar make_polar))
         (rename-out (make-rectangular make_rectangular))
         max
         min
         modulo
         negative?
         (rename-out (number->string number_to_string))
         number?
         numerator
         odd?
         pi
         positive?
         quotient
         random
         rational?
         (rename-out (real-part real_part))
         real?
         remainder
         round
         sgn
         sin
         sinh
         sqr
         sqrt
         sub1
         tan
         zero?)

;; Booleans
(provide (rename-out (boolean=? boolean_equals?))
         boolean?
         false?
         not)

;; Symbols
(provide (rename-out (symbol->string symbol_to_string))
         (rename-out (symbol=? symbol_equals?))
         symbol?)

;; Lists
(provide append
         assq
         caaar
         caadr
         caar
         cadar
         cadddr
         caddr
         cadr
         car
         cdaar
         cdadr
         cdar
         cddar
         cdddr
         cddr
         cdr
         cons
         cons?
         eighth
         empty?
         fifth
         first
         fourth
         length
         list
         (rename-out (list* list_star))
         (rename-out (list-ref list_ref))
         (rename-out (make-list make_list))
         member
         (rename-out (htdp/bsl:member? member?))
         memq
         memv
         null
         null?
         pair?
         remove
         rest
         reverse
         second
         seventh
         sixth
         third)

;; characters
(provide (rename-out (char->integer char_to_integer))
         (rename-out (char-alphabetic? char_alphabetic?))
         (rename-out (char-ci<=? char_ci_leq?))
         (rename-out (char-ci<? char_ci_lt?))
         (rename-out (char-ci=? char_ci_eq?))
         (rename-out (char-ci>=? char_ci_geq?))
         (rename-out (char-ci>? char_ci_gt?))
         (rename-out (char-downcase char_downcase))
         (rename-out (char-lower-case? char_lower_case?))
         (rename-out (char-numeric? char_numeric?))
         (rename-out (char-upcase char_upcase))
         (rename-out (char-upper-case? char_upper_case?))
         (rename-out (char-whitespace? char_whitespace?))
         (rename-out (char<=? char_leq?))
         (rename-out (char<? char_lt?))
         (rename-out (char=? char_eq?))
         (rename-out (char>=? char_geq?))
         (rename-out (char>? char_gt?))
         char?)

;; Strings
(provide (rename-out (htdp/bsl:explode explode))
         format
         (rename-out (htdp/bsl:implode implode))
         (rename-out (htdp/bsl:int->string int_to_string))
         (rename-out (htdp/bsl:list->string list_to_string))
         (rename-out (make-string make_string))
         (rename-out (htdp/bsl:replicate replicate))
         string
         (rename-out (htdp/bsl:string->int string_to_int))
         (rename-out (htdp/bsl:string->list string_to_list))
         (rename-out (htdp/bsl:string->number string_to_number))
         (rename-out (htdp/bsl:string->symbol string_to_symbol))
         (rename-out (htdp/bsl:string-alphabetic? string_alphabetic?))
         (rename-out (string-append string_append))
         (rename-out (string-ci<? string_ci_lt?))
         (rename-out (string-ci<=? string_ci_leq?))
         (rename-out (string-ci=? string_ci_eq?))
         (rename-out (string-ci>=? string_ci_geq?))
         (rename-out (string-ci>? string_ci_gt?))
         (rename-out (string-copy string_copy))
         (rename-out (htdp/bsl:string-ith string_ith))
         (rename-out (string-length string_length))
         (rename-out (htdp/bsl:string-lower-case? string_lower_case?))
         (rename-out (htdp/bsl:string-numeric? string_numeric?))
         (rename-out (string-ref string_ref))
         (rename-out (htdp/bsl:string-upper-case? string_upper_case?))
         (rename-out (htdp/bsl:string-whitespace? string_whitespace?))
         (rename-out (string<=? string_leq?))
         (rename-out (string<? string_lt?))
         (rename-out (string=? string_eq?))
         (rename-out (string>=? string_geq?))
         (rename-out (string>? string_gt?))
         string?
         substring)

;; Image
(provide (rename-out (htdp/bsl:image=? image_eq?))
         (rename-out (htdp/bsl:image? image?)))

;; Misc
(provide eof
         (rename-out (eof-object? eof_object?))
         eq?
         equal?
         eqv?
         error
         exit)

(provide define quote if cond else and or not)